import Control.Arrow.ArrowTree
import Control.Monad.Trans
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu
+import Network.HTTP.Lucu.RFC1123DateTime
import Network.URI hiding (query, fragment)
import Rakka.Environment
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
+import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
to="5"
total="5">
- <page name="Page/1">
+ <page name="Page/1" lastModified="2000-01-01T00:00:00">
aaa <hit>foo</hit> bbb
</page>
= do params <- getQueryForm
let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
+ order = fmap UTF8.decodeString (lookup "order" params)
from = fromMaybe 0
$ fmap read $ lookup "from" params
to = fromMaybe (from + resultsPerSection)
$ fmap read $ lookup "to" params
- cond <- liftIO $ mkCond query from to
+ cond <- liftIO $ mkCond query order from to
result <- searchPages (envStorage env) cond
let to' = min (from + length (srPages result)) to
-> do tree <- ( eelem "/"
+= ( eelem "searchResult"
+= sattr "query" query
+ += ( case order of
+ Just o -> sattr "order" o
+ Nothing -> none
+ )
+= sattr "from" (show from)
+= sattr "to" (show to')
+= sattr "total" (show $ srTotal result)
) -< ()
returnA -< outputXmlPage' tree (searchResultToXHTML env)
where
- mkCond :: String -> Int -> Int -> IO Condition
- mkCond query from to
+ mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
+ mkCond query order from to
= do cond <- newCondition
setPhrase cond query
+ case order of
+ Just o -> setOrder cond o
+ Nothing -> return ()
setSkip cond from
- setMax cond (to - from)
+ setMax cond (to - from + 1)
return cond
- mkPageElem :: ArrowXml a => a HitPage XmlTree
+ mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
mkPageElem = ( eelem "page"
+= attr "name" (arr hpPageName >>> mkText)
+ += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
+ >>>
+ arr formatW3CDateTime
+ >>>
+ mkText
+ )
+= ( arrL hpSnippet
>>>
mkSnippetTree
)
)
- mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
+ mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
mkSnippetTree = proc fragment
-> case fragment of
- Boundary -> eelem "boundary"
- NormalText t -> txt t
- HighlightedWord w -> eelem "hit" += txt w
- -<< ()
+ Boundary -> eelem "boundary" -< ()
+ NormalText t -> mkText -< t
+ HighlightedWord w -> ( eelem "hit"
+ += mkText
+ ) -< w
searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
getText
)
&&&
+ maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+ >>>
+ getText
+ )
+ &&&
( getXPathTreesInDoc "/searchResult/@from/text()"
>>>
getText
>>>
getText
>>>
- arr ((+ 1) . (`div` resultsPerSection) . read)
+ arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
)
)
>>>
- ( ((> 1) . snd . snd)
+ ( ((> 1) . snd . snd . snd)
`guardsP`
formatPager baseURI
)
uniqueNamespacesFromDeclAndQNames
) ) -<< tree
where
- formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
+ formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
formatItem baseURI
= ( eelem "div"
+= sattr "class" "searchResult"
)
+= (getAttrValue "name" >>> mkText)
)
+ += ( eelem "div"
+ += sattr "class" "date"
+ += ( getAttrValue "lastModified"
+ >>>
+ arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+ >>>
+ arrIO utcToLocalZonedTime
+ >>>
+ arr formatRFC1123DateTime
+ >>>
+ mkText
+ )
+ )
+= ( eelem "p"
+= ( getChildren
>>>
)
)
- formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
+ formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
formatPager baseURI
= ( eelem "div"
+= sattr "class" "pager"
&&&
arr (fst . snd)
&&&
- ( arr snd
+ arr (fst . snd . snd)
+ &&&
+ ( arr (snd . snd)
>>>
mkSectionWindow
)
)
>>>
- proc (query, (currentSection, section))
+ proc (query, (order, (currentSection, section)))
-> if currentSection == section then
( txt " "
<+>
>>>
uriToText
)
- += (arr (show . snd) >>> mkText)
- ) -< (query, section)
+ += (arr (show . snd . snd) >>> mkText)
+ ) -< (query, (order, section))
)
)
arrL id -< [begin .. end]
- mkSectionURI :: Arrow a => URI -> a (String, Int) URI
+ mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
mkSectionURI baseURI
- = arr $ \ (query, section)
+ = arr $ \ (query, (order, section))
-> baseURI {
- uriPath = uriPath baseURI </> "search"
- , uriQuery = '?' : mkQueryString [ ("q" , query)
- , ("from", show $ section * resultsPerSection)
- , ("to" , show $ (section + 1) * resultsPerSection - 1)
- ]
+ uriPath = uriPath baseURI </> "search.html"
+ , uriQuery = '?' : mkQueryString ( [ ("q" , query)
+ , ("from", show $ section * resultsPerSection)
+ , ("to" , show $ (section + 1) * resultsPerSection - 1)
+ ]
+ ++
+ case order of
+ Just o -> [("order", o)]
+ Nothing -> []
+ )
}
uriToText :: ArrowXml a => a URI XmlTree
uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
- mkQueryString :: [(String, String)] -> String
- mkQueryString [] = ""
- mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
- if xs == [] then
- ""
- else
- ';' : mkQueryString(xs)
-
- encode :: String -> String
- encode = escapeURIString isSafeChar . UTF8.encodeString
-
readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Environment
projects / Rakka.git / blobdiff