1 module Rakka.Resource.Search
6 import qualified Codec.Binary.UTF8.String as UTF8
7 import Control.Monad.Trans
10 import Network.HTTP.Lucu
11 import Network.HTTP.Lucu.RFC1123DateTime
12 import Network.URI hiding (query, fragment)
13 import Rakka.Environment
17 import Rakka.SystemConfig
19 import Rakka.W3CDateTime
20 import Rakka.Wiki.Engine
21 import System.FilePath
22 import Text.HyperEstraier hiding (getText)
23 import Text.XML.HXT.Arrow
24 import Text.XML.HXT.DOM.TypeDefs
27 resSearch :: Environment -> ResourceDef
30 resUsesNativeThread = False
32 , resGet = Just $ handleSearch env
40 resultsPerSection :: Int
41 resultsPerSection = 10
44 maxSectionWindowSize :: Int
45 maxSectionWindowSize = 10
49 <searchResult query="foo bar baz"
54 <page name="Page/1" lastModified="2000-01-01T00:00:00">
55 aaa <hit>foo</hit> bbb
61 handleSearch :: Environment -> Resource ()
63 = do params <- getQueryForm
65 let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
66 order = fmap UTF8.decodeString (lookup "order" params)
68 $ fmap read $ lookup "from" params
69 to = fromMaybe (from + resultsPerSection)
70 $ fmap read $ lookup "to" params
72 cond <- liftIO $ mkCond query order from to
73 result <- searchPages (envStorage env) cond
75 let to' = min (from + length (srPages result)) to
77 BaseURI baseURI <- getSysConf (envSysConf env)
78 runIdempotentA baseURI $ proc ()
79 -> do tree <- ( eelem "/"
80 += ( eelem "searchResult"
81 += sattr "query" query
83 Just o -> sattr "order" o
86 += sattr "from" (show from)
87 += sattr "to" (show to')
88 += sattr "total" (show $ srTotal result)
89 += ( constL (srPages result)
95 returnA -< outputXmlPage' tree (searchResultToXHTML env)
97 mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
98 mkCond query order from to
99 = do cond <- newCondition
102 Just o -> setOrder cond o
105 setMax cond (to - from + 1)
108 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
109 mkPageElem = ( eelem "page"
110 += attr "name" (arr hpPageName >>> mkText)
111 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
113 arr formatW3CDateTime
123 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
124 mkSnippetTree = proc fragment
126 Boundary -> eelem "boundary" -< ()
127 NormalText t -> mkText -< t
128 HighlightedWord w -> ( eelem "hit"
133 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
134 searchResultToXHTML env
136 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
137 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
138 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
139 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
141 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
142 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
144 pageTitle <- listA (readSubPage env) -< "PageTitle"
145 leftSideBar <- listA (readSubPage env) -< "SideBar/Left"
146 rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
150 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
155 += getXPathTreesInDoc "/searchResult/@query/text()"
160 += sattr "rel" "stylesheet"
161 += sattr "type" "text/css"
162 += attr "href" (arr id >>> mkText)
164 += ( constL scriptSrc
167 += sattr "type" "text/javascript"
168 += attr "src" (arr id >>> mkText)
171 += sattr "type" "text/javascript"
172 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
173 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
174 += txt "Rakka.isSpecialPage=true;"
179 += sattr "class" "header"
182 += sattr "class" "center"
184 += sattr "class" "title"
188 += sattr "class" "body"
190 += txt "Search Result"
193 += sattr "class" "searchStat"
194 += txt "Search result for "
196 += sattr "class" "queryString"
197 += getXPathTreesInDoc "/searchResult/@query/text()"
200 += getXPathTreesInDoc "/searchResult/@total/text()"
203 += ( getXPathTreesInDoc "/searchResult/page"
207 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
212 maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
217 ( getXPathTreesInDoc "/searchResult/@from/text()"
221 arr ((`div` resultsPerSection) . read)
224 ( getXPathTreesInDoc "/searchResult/@total/text()"
228 arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
232 ( ((> 1) . snd . snd . snd)
240 += sattr "class" "footer"
243 += sattr "class" "left sideBar"
245 += sattr "class" "content"
246 += constL leftSideBar
250 += sattr "class" "right sideBar"
252 += sattr "class" "content"
253 += constL rightSideBar
258 uniqueNamespacesFromDeclAndQNames
261 formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
264 += sattr "class" "searchResult"
266 += attr "href" ( getAttrValue "name"
268 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
272 += (getAttrValue "name" >>> mkText)
275 += sattr "class" "date"
276 += ( getAttrValue "lastModified"
278 arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
280 arrIO utcToLocalZonedTime
282 arr formatRFC1123DateTime
290 choiceA [ isText :-> this
291 , hasName "boundary" :-> txt " ... "
292 , hasName "hit" :-> ( eelem "span"
293 += sattr "class" "highlighted"
301 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
304 += sattr "class" "pager"
310 arr (fst . snd . snd)
318 proc (query, (order, (currentSection, section)))
319 -> if currentSection == section then
323 += sattr "class" "currentSection"
324 += (arr show >>> mkText)
330 += attr "href" ( mkSectionURI baseURI
334 += (arr (show . snd . snd) >>> mkText)
335 ) -< (query, (order, section))
339 mkSectionWindow :: ArrowList a => a (Int, Int) Int
341 = proc (currentSection, totalSections)
342 -> let windowWidth = min maxSectionWindowSize totalSections
343 windowBegin = currentSection - (windowWidth `div` 2)
344 (begin, end) = if windowBegin < 0 then
348 if windowBegin + windowWidth >= totalSections then
350 (totalSections - windowWidth, totalSections - 1)
353 (windowBegin, windowBegin + windowWidth - 1)
355 arrL id -< [begin .. end]
358 mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
360 = arr $ \ (query, (order, section))
362 uriPath = uriPath baseURI </> "search.html"
363 , uriQuery = '?' : mkQueryString ( [ ("q" , query)
364 , ("from", show $ section * resultsPerSection)
365 , ("to" , show $ (section + 1) * resultsPerSection - 1)
369 Just o -> [("order", o)]
374 uriToText :: ArrowXml a => a URI XmlTree
375 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
379 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
380 Environment -> a PageName XmlTree
382 = proc (subPageName) ->
383 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
384 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)