1 module Rakka.Resource.Search
6 import qualified Codec.Binary.UTF8.String as UTF8
8 import Control.Arrow.ArrowIO
9 import Control.Arrow.ArrowIf
10 import Control.Arrow.ArrowList
11 import Control.Arrow.ArrowTree
12 import Control.Monad.Trans
15 import Network.HTTP.Lucu
16 import Network.HTTP.Lucu.RFC1123DateTime
17 import Network.URI hiding (query, fragment)
18 import Rakka.Environment
22 import Rakka.SystemConfig
24 import Rakka.W3CDateTime
25 import Rakka.Wiki.Engine
26 import System.FilePath
27 import Text.HyperEstraier hiding (getText)
28 import Text.XML.HXT.Arrow.Namespace
29 import Text.XML.HXT.Arrow.XmlArrow
30 import Text.XML.HXT.Arrow.XmlNodeSet
31 import Text.XML.HXT.DOM.TypeDefs
34 resSearch :: Environment -> ResourceDef
37 resUsesNativeThread = False
39 , resGet = Just $ handleSearch env
47 resultsPerSection :: Int
48 resultsPerSection = 10
51 maxSectionWindowSize :: Int
52 maxSectionWindowSize = 10
56 <searchResult query="foo bar baz"
61 <page name="Page/1" lastModified="2000-01-01T00:00:00">
62 aaa <hit>foo</hit> bbb
68 handleSearch :: Environment -> Resource ()
70 = do params <- getQueryForm
72 let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
73 order = fmap UTF8.decodeString (lookup "order" params)
75 $ fmap read $ lookup "from" params
76 to = fromMaybe (from + resultsPerSection)
77 $ fmap read $ lookup "to" params
79 cond <- liftIO $ mkCond query order from to
80 result <- searchPages (envStorage env) cond
82 let to' = min (from + length (srPages result)) to
84 BaseURI baseURI <- getSysConf (envSysConf env)
85 runIdempotentA baseURI $ proc ()
86 -> do tree <- ( eelem "/"
87 += ( eelem "searchResult"
88 += sattr "query" query
90 Just o -> sattr "order" o
93 += sattr "from" (show from)
94 += sattr "to" (show to')
95 += sattr "total" (show $ srTotal result)
96 += ( constL (srPages result)
102 returnA -< outputXmlPage' tree (searchResultToXHTML env)
104 mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
105 mkCond query order from to
106 = do cond <- newCondition
109 Just o -> setOrder cond o
112 setMax cond (to - from + 1)
115 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
116 mkPageElem = ( eelem "page"
117 += attr "name" (arr hpPageName >>> mkText)
118 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
120 arr formatW3CDateTime
130 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
131 mkSnippetTree = proc fragment
133 Boundary -> eelem "boundary" -< ()
134 NormalText t -> mkText -< t
135 HighlightedWord w -> ( eelem "hit"
140 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
141 searchResultToXHTML env
143 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
144 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
145 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
146 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
148 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
149 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
151 pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
152 leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
153 rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
157 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
162 += getXPathTreesInDoc "/searchResult/@query/text()"
167 += sattr "rel" "stylesheet"
168 += sattr "type" "text/css"
169 += attr "href" (arr id >>> mkText)
171 += ( constL scriptSrc
174 += sattr "type" "text/javascript"
175 += attr "src" (arr id >>> mkText)
178 += sattr "type" "text/javascript"
179 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
180 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
181 += txt "Rakka.isSpecialPage=true;"
186 += sattr "class" "header"
189 += sattr "class" "center"
191 += sattr "class" "title"
195 += sattr "class" "body"
197 += txt "Search Result"
200 += sattr "class" "searchStat"
201 += txt "Search result for "
203 += sattr "class" "queryString"
204 += getXPathTreesInDoc "/searchResult/@query/text()"
207 += getXPathTreesInDoc "/searchResult/@total/text()"
210 += ( getXPathTreesInDoc "/searchResult/page"
214 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
219 maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
224 ( getXPathTreesInDoc "/searchResult/@from/text()"
228 arr ((`div` resultsPerSection) . read)
231 ( getXPathTreesInDoc "/searchResult/@total/text()"
235 arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
239 ( ((> 1) . snd . snd . snd)
247 += sattr "class" "footer"
250 += sattr "class" "left sideBar"
252 += sattr "class" "content"
253 += constL leftSideBar
257 += sattr "class" "right sideBar"
259 += sattr "class" "content"
260 += constL rightSideBar
265 uniqueNamespacesFromDeclAndQNames
268 formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
271 += sattr "class" "searchResult"
273 += attr "href" ( getAttrValue "name"
275 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
279 += (getAttrValue "name" >>> mkText)
282 += sattr "class" "date"
283 += ( getAttrValue "lastModified"
285 arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
287 arrIO utcToLocalZonedTime
289 arr formatRFC1123DateTime
297 choiceA [ isText :-> this
298 , hasName "boundary" :-> txt " ... "
299 , hasName "hit" :-> ( eelem "span"
300 += sattr "class" "highlighted"
308 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
311 += sattr "class" "pager"
317 arr (fst . snd . snd)
325 proc (query, (order, (currentSection, section)))
326 -> if currentSection == section then
330 += sattr "class" "currentSection"
331 += (arr show >>> mkText)
337 += attr "href" ( mkSectionURI baseURI
341 += (arr (show . snd . snd) >>> mkText)
342 ) -< (query, (order, section))
346 mkSectionWindow :: ArrowList a => a (Int, Int) Int
348 = proc (currentSection, totalSections)
349 -> let windowWidth = min maxSectionWindowSize totalSections
350 windowBegin = currentSection - (windowWidth `div` 2)
351 (begin, end) = if windowBegin < 0 then
355 if windowBegin + windowWidth >= totalSections then
357 (totalSections - windowWidth, totalSections - 1)
360 (windowBegin, windowBegin + windowWidth - 1)
362 arrL id -< [begin .. end]
365 mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
367 = arr $ \ (query, (order, section))
369 uriPath = uriPath baseURI </> "search.html"
370 , uriQuery = '?' : mkQueryString ( [ ("q" , query)
371 , ("from", show $ section * resultsPerSection)
372 , ("to" , show $ (section + 1) * resultsPerSection - 1)
376 Just o -> [("order", o)]
381 uriToText :: ArrowXml a => a URI XmlTree
382 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
385 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
387 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
389 = proc (mainPageName, mainPage, subPageName) ->
390 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
391 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
392 -< (mainPageName, mainPage, subPage)