1 module Rakka.Resource.Search
6 import qualified Codec.Binary.UTF8.Generic as UTF8
7 import Control.Monad.Trans
11 import Network.HTTP.Lucu
12 import Network.HTTP.Lucu.RFC1123DateTime
13 import Network.URI hiding (query, fragment)
14 import Rakka.Environment
18 import Rakka.SystemConfig
20 import Rakka.W3CDateTime
21 import Rakka.Wiki.Engine
22 import System.FilePath
23 import Text.HyperEstraier hiding (getText)
24 import Text.XML.HXT.Arrow
25 import Text.XML.HXT.XPath
28 resSearch :: Environment -> ResourceDef
31 resUsesNativeThread = False
33 , resGet = Just $ handleSearch env
41 resultsPerSection :: Int
42 resultsPerSection = 10
45 maxSectionWindowSize :: Int
46 maxSectionWindowSize = 10
49 findQueryParam :: String -> [FormData] -> Maybe String
50 findQueryParam name qps
51 = do fd <- find (\ qp -> fdName qp == name) qps
52 return $ UTF8.toString $ fdContent fd
55 <searchResult query="foo bar baz"
60 <page name="Page/1" lastModified="2000-01-01T00:00:00">
61 aaa <hit>foo</hit> bbb
67 handleSearch :: Environment -> Resource ()
69 = do params <- getQueryForm
71 let query = fromMaybe "" $ findQueryParam "q" params
72 order = findQueryParam "order" params
74 $ fmap read $ findQueryParam "from" params
75 to = fromMaybe (from + resultsPerSection)
76 $ fmap read $ findQueryParam "to" params
78 cond <- liftIO $ mkCond query order from to
79 result <- searchPages (envStorage env) cond
81 let to' = min (from + length (srPages result)) to
83 BaseURI baseURI <- getSysConf (envSysConf env)
84 runIdempotentA baseURI $ proc ()
85 -> do tree <- ( eelem "/"
86 += ( eelem "searchResult"
87 += sattr "query" query
89 Just o -> sattr "order" o
92 += sattr "from" (show from)
93 += sattr "to" (show to')
94 += sattr "total" (show $ srTotal result)
95 += ( constL (srPages result)
101 returnA -< outputXmlPage' tree (searchResultToXHTML env)
103 mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
104 mkCond query order from to
105 = do cond <- newCondition
108 Just o -> setOrder cond o
111 setMax cond (to - from + 1)
114 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
115 mkPageElem = ( eelem "page"
116 += attr "name" (arr hpPageName >>> mkText)
117 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
119 arr formatW3CDateTime
129 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
130 mkSnippetTree = proc fragment
132 Boundary -> eelem "boundary" -< ()
133 NormalText t -> mkText -< t
134 HighlightedWord w -> ( eelem "hit"
139 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
140 searchResultToXHTML env
142 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
143 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
144 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
145 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
147 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
148 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
150 pageTitle <- listA (readSubPage env) -< "PageTitle"
151 leftSideBar <- listA (readSubPage env) -< "SideBar/Left"
152 rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
156 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
161 += getXPathTreesInDoc "/searchResult/@query/text()"
166 += sattr "rel" "stylesheet"
167 += sattr "type" "text/css"
168 += attr "href" (arr id >>> mkText)
170 += ( constL scriptSrc
173 += sattr "type" "text/javascript"
174 += attr "src" (arr id >>> mkText)
177 += sattr "type" "text/javascript"
178 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
179 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
180 += txt "Rakka.isSpecialPage=true;"
185 += sattr "class" "header"
188 += sattr "class" "center"
190 += sattr "class" "title"
194 += sattr "class" "body"
196 += txt "Search Result"
199 += sattr "class" "searchStat"
200 += txt "Search result for "
202 += sattr "class" "queryString"
203 += getXPathTreesInDoc "/searchResult/@query/text()"
206 += getXPathTreesInDoc "/searchResult/@total/text()"
209 += ( getXPathTreesInDoc "/searchResult/page"
213 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
218 maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
223 ( getXPathTreesInDoc "/searchResult/@from/text()"
227 arr ((`div` resultsPerSection) . read)
230 ( getXPathTreesInDoc "/searchResult/@total/text()"
234 arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
238 ( ((> 1) . snd . snd . snd)
246 += sattr "class" "footer"
249 += sattr "class" "left sideBar"
251 += sattr "class" "content"
252 += constL leftSideBar
256 += sattr "class" "right sideBar"
258 += sattr "class" "content"
259 += constL rightSideBar
264 uniqueNamespacesFromDeclAndQNames
267 formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
270 += sattr "class" "searchResult"
272 += attr "href" ( getAttrValue "name"
274 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
278 += (getAttrValue "name" >>> mkText)
281 += sattr "class" "date"
282 += ( getAttrValue "lastModified"
284 arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
286 arrIO utcToLocalZonedTime
288 arr formatRFC1123DateTime
296 choiceA [ isText :-> this
297 , hasName "boundary" :-> txt " ... "
298 , hasName "hit" :-> ( eelem "span"
299 += sattr "class" "highlighted"
307 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
310 += sattr "class" "pager"
316 arr (fst . snd . snd)
324 proc (query, (order, (currentSection, section)))
325 -> if currentSection == section then
329 += sattr "class" "currentSection"
330 += (arr show >>> mkText)
336 += attr "href" ( mkSectionURI baseURI
340 += (arr (show . snd . snd) >>> mkText)
341 ) -< (query, (order, section))
345 mkSectionWindow :: ArrowList a => a (Int, Int) Int
347 = proc (currentSection, totalSections)
348 -> let windowWidth = min maxSectionWindowSize totalSections
349 windowBegin = currentSection - (windowWidth `div` 2)
350 (begin, end) = if windowBegin < 0 then
354 if windowBegin + windowWidth >= totalSections then
356 (totalSections - windowWidth, totalSections - 1)
359 (windowBegin, windowBegin + windowWidth - 1)
361 arrL id -< [begin .. end]
364 mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
366 = arr $ \ (query, (order, section))
368 uriPath = uriPath baseURI </> "search.html"
369 , uriQuery = '?' : mkQueryString ( [ ("q" , query)
370 , ("from", show $ section * resultsPerSection)
371 , ("to" , show $ (section + 1) * resultsPerSection - 1)
375 Just o -> [("order", o)]
380 uriToText :: ArrowXml a => a URI XmlTree
381 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
385 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
386 Environment -> a PageName XmlTree
388 = proc (subPageName) ->
389 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
390 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)