1 module Rakka.Resource.Search
5 import Control.Monad.Trans
9 import qualified Data.Time.RFC1123 as RFC1123
10 import qualified Data.Time.W3C as W3C
11 import Network.HTTP.Lucu
12 import Network.URI hiding (query, fragment)
13 import Rakka.Environment
17 import Rakka.SystemConfig
19 import Rakka.Wiki.Engine
20 import System.FilePath
21 import Text.HyperEstraier hiding (getText)
22 import Text.XML.HXT.XPath
25 resSearch :: Environment -> ResourceDef
28 resUsesNativeThread = False
30 , resGet = Just $ handleSearch env
38 resultsPerSection :: Int
39 resultsPerSection = 10
42 maxSectionWindowSize :: Int
43 maxSectionWindowSize = 10
46 findQueryParam :: String -> [FormData] -> Maybe String
47 findQueryParam name qps
48 = do fd <- find (\ qp -> fdName qp == name) qps
49 return $ UTF8.toString $ fdContent fd
52 <searchResult query="foo bar baz"
57 <page name="Page/1" lastModified="2000-01-01T00:00:00">
58 aaa <hit>foo</hit> bbb
64 handleSearch :: Environment -> Resource ()
66 = do params <- getQueryForm
68 let query = fromMaybe "" $ findQueryParam "q" params
69 order = findQueryParam "order" params
71 $ fmap read $ findQueryParam "from" params
72 to = fromMaybe (from + resultsPerSection)
73 $ fmap read $ findQueryParam "to" params
75 cond <- liftIO $ mkCond query order from to
76 result <- searchPages (envStorage env) cond
78 let to' = min (from + length (srPages result)) to
80 BaseURI baseURI <- getSysConf (envSysConf env)
81 runIdempotentA baseURI $ proc ()
82 -> do tree <- ( eelem "/"
83 += ( eelem "searchResult"
84 += sattr "query" query
86 Just o -> sattr "order" o
89 += sattr "from" (show from)
90 += sattr "to" (show to')
91 += sattr "total" (show $ srTotal result)
92 += ( constL (srPages result)
98 returnA -< outputXmlPage' tree (searchResultToXHTML env)
100 mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
101 mkCond query order from to
102 = do cond <- newCondition
105 Just o -> setOrder cond o
108 setMax cond (to - from + 1)
111 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
112 mkPageElem = ( eelem "page"
113 += attr "name" (arr hpPageName >>> mkText)
114 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
126 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
127 mkSnippetTree = proc fragment
129 Boundary -> eelem "boundary" -< ()
130 NormalText t -> mkText -< t
131 HighlightedWord w -> ( eelem "hit"
136 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
137 searchResultToXHTML env
139 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
140 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
141 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
142 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
144 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
145 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
147 pageTitle <- listA (readSubPage env) -< "PageTitle"
148 leftSideBar <- listA (readSubPage env) -< "SideBar/Left"
149 rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
153 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
158 += getXPathTreesInDoc "/searchResult/@query/text()"
163 += sattr "rel" "stylesheet"
164 += sattr "type" "text/css"
165 += attr "href" (arr id >>> mkText)
167 += ( constL scriptSrc
170 += sattr "type" "text/javascript"
171 += attr "src" (arr id >>> mkText)
174 += sattr "type" "text/javascript"
175 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
176 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
177 += txt "Rakka.isSpecialPage=true;"
182 += sattr "class" "header"
185 += sattr "class" "center"
187 += sattr "class" "title"
191 += sattr "class" "body"
193 += txt "Search Result"
196 += sattr "class" "searchStat"
197 += txt "Search result for "
199 += sattr "class" "queryString"
200 += getXPathTreesInDoc "/searchResult/@query/text()"
203 += getXPathTreesInDoc "/searchResult/@total/text()"
206 += ( getXPathTreesInDoc "/searchResult/page"
210 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
215 maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
220 ( getXPathTreesInDoc "/searchResult/@from/text()"
224 arr ((`div` resultsPerSection) . read)
227 ( getXPathTreesInDoc "/searchResult/@total/text()"
231 arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
235 ( ((> 1) . snd . snd . snd)
243 += sattr "class" "footer"
246 += sattr "class" "left sideBar"
248 += sattr "class" "content"
249 += constL leftSideBar
253 += sattr "class" "right sideBar"
255 += sattr "class" "content"
256 += constL rightSideBar
261 uniqueNamespacesFromDeclAndQNames
264 formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
267 += sattr "class" "searchResult"
269 += attr "href" ( getAttrValue "name"
271 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
275 += (getAttrValue "name" >>> mkText)
278 += sattr "class" "date"
279 += ( getAttrValue "lastModified"
281 arr (zonedTimeToUTC . fromJust . W3C.parse)
283 arrIO utcToLocalZonedTime
293 choiceA [ isText :-> this
294 , hasName "boundary" :-> txt " ... "
295 , hasName "hit" :-> ( eelem "span"
296 += sattr "class" "highlighted"
304 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
307 += sattr "class" "pager"
313 arr (fst . snd . snd)
321 proc (query, (order, (currentSection, section)))
322 -> if currentSection == section then
326 += sattr "class" "currentSection"
327 += (arr show >>> mkText)
333 += attr "href" ( mkSectionURI baseURI
337 += (arr (show . snd . snd) >>> mkText)
338 ) -< (query, (order, section))
342 mkSectionWindow :: ArrowList a => a (Int, Int) Int
344 = proc (currentSection, totalSections)
345 -> let windowWidth = min maxSectionWindowSize totalSections
346 windowBegin = currentSection - (windowWidth `div` 2)
347 (begin, end) = if windowBegin < 0 then
351 if windowBegin + windowWidth >= totalSections then
353 (totalSections - windowWidth, totalSections - 1)
356 (windowBegin, windowBegin + windowWidth - 1)
358 arrL id -< [begin .. end]
361 mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
363 = arr $ \ (query, (order, section))
365 uriPath = uriPath baseURI </> "search.html"
366 , uriQuery = '?' : mkQueryString ( [ ("q" , query)
367 , ("from", show $ section * resultsPerSection)
368 , ("to" , show $ (section + 1) * resultsPerSection - 1)
372 Just o -> [("order", o)]
377 uriToText :: ArrowXml a => a URI XmlTree
378 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
382 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
383 Environment -> a PageName XmlTree
385 = proc (subPageName) ->
386 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
387 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)