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.URI hiding (query, fragment)
17 import Rakka.Environment
21 import Rakka.SystemConfig
23 import Rakka.W3CDateTime
24 import Rakka.Wiki.Engine
25 import System.FilePath
26 import Text.HyperEstraier hiding (getText)
27 import Text.XML.HXT.Arrow.Namespace
28 import Text.XML.HXT.Arrow.XmlArrow
29 import Text.XML.HXT.Arrow.XmlNodeSet
30 import Text.XML.HXT.DOM.TypeDefs
33 resSearch :: Environment -> ResourceDef
36 resUsesNativeThread = False
38 , resGet = Just $ handleSearch env
46 resultsPerSection :: Int
47 resultsPerSection = 10
50 maxSectionWindowSize :: Int
51 maxSectionWindowSize = 10
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 = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
73 $ fmap read $ lookup "from" params
74 to = fromMaybe (from + resultsPerSection)
75 $ fmap read $ lookup "to" params
77 cond <- liftIO $ mkCond query from to
78 result <- searchPages (envStorage env) cond
80 let to' = min (from + length (srPages result)) to
82 BaseURI baseURI <- getSysConf (envSysConf env)
83 runIdempotentA baseURI $ proc ()
84 -> do tree <- ( eelem "/"
85 += ( eelem "searchResult"
86 += sattr "query" query
87 += sattr "from" (show from)
88 += sattr "to" (show to')
89 += sattr "total" (show $ srTotal result)
90 += ( constL (srPages result)
96 returnA -< outputXmlPage' tree (searchResultToXHTML env)
98 mkCond :: String -> Int -> Int -> IO Condition
100 = do cond <- newCondition
103 setMax cond (to - from)
106 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
107 mkPageElem = ( eelem "page"
108 += attr "name" (arr hpPageName >>> mkText)
109 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
111 arr formatW3CDateTime
121 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
122 mkSnippetTree = proc fragment
124 Boundary -> eelem "boundary" -< ()
125 NormalText t -> mkText -< t
126 HighlightedWord w -> ( eelem "hit"
131 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
132 searchResultToXHTML env
134 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
135 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
136 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
137 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
139 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
140 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
142 pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
143 leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
144 rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
148 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
153 += getXPathTreesInDoc "/searchResult/@query/text()"
158 += sattr "rel" "stylesheet"
159 += sattr "type" "text/css"
160 += attr "href" (arr id >>> mkText)
162 += ( constL scriptSrc
165 += sattr "type" "text/javascript"
166 += attr "src" (arr id >>> mkText)
169 += sattr "type" "text/javascript"
170 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
171 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
172 += txt "Rakka.isSpecialPage=true;"
177 += sattr "class" "header"
180 += sattr "class" "center"
182 += sattr "class" "title"
186 += sattr "class" "body"
188 += txt "Search Result"
191 += sattr "class" "searchStat"
192 += txt "Search result for "
194 += sattr "class" "queryString"
195 += getXPathTreesInDoc "/searchResult/@query/text()"
198 += getXPathTreesInDoc "/searchResult/@total/text()"
201 += ( getXPathTreesInDoc "/searchResult/page"
205 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
210 ( getXPathTreesInDoc "/searchResult/@from/text()"
214 arr ((`div` resultsPerSection) . read)
217 ( getXPathTreesInDoc "/searchResult/@total/text()"
221 arr ((+ 1) . (`div` resultsPerSection) . read)
225 ( ((> 1) . snd . snd)
233 += sattr "class" "footer"
236 += sattr "class" "left sideBar"
238 += sattr "class" "content"
239 += constL leftSideBar
243 += sattr "class" "right sideBar"
245 += sattr "class" "content"
246 += constL rightSideBar
251 uniqueNamespacesFromDeclAndQNames
254 formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
257 += sattr "class" "searchResult"
259 += attr "href" ( getAttrValue "name"
261 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
265 += (getAttrValue "name" >>> mkText)
270 choiceA [ isText :-> this
271 , hasName "boundary" :-> txt " ... "
272 , hasName "hit" :-> ( eelem "span"
273 += sattr "class" "highlighted"
281 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
284 += sattr "class" "pager"
296 proc (query, (currentSection, section))
297 -> if currentSection == section then
301 += sattr "class" "currentSection"
302 += (arr show >>> mkText)
308 += attr "href" ( mkSectionURI baseURI
312 += (arr (show . snd) >>> mkText)
313 ) -< (query, section)
317 mkSectionWindow :: ArrowList a => a (Int, Int) Int
319 = proc (currentSection, totalSections)
320 -> let windowWidth = min maxSectionWindowSize totalSections
321 windowBegin = currentSection - (windowWidth `div` 2)
322 (begin, end) = if windowBegin < 0 then
326 if windowBegin + windowWidth >= totalSections then
328 (totalSections - windowWidth, totalSections - 1)
331 (windowBegin, windowBegin + windowWidth - 1)
333 arrL id -< [begin .. end]
336 mkSectionURI :: Arrow a => URI -> a (String, Int) URI
338 = arr $ \ (query, section)
340 uriPath = uriPath baseURI </> "search"
341 , uriQuery = '?' : mkQueryString [ ("q" , query)
342 , ("from", show $ section * resultsPerSection)
343 , ("to" , show $ (section + 1) * resultsPerSection - 1)
347 uriToText :: ArrowXml a => a URI XmlTree
348 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
350 mkQueryString :: [(String, String)] -> String
351 mkQueryString [] = ""
352 mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
356 ';' : mkQueryString(xs)
358 encode :: String -> String
359 encode = escapeURIString isSafeChar . UTF8.encodeString
362 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
364 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
366 = proc (mainPageName, mainPage, subPageName) ->
367 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
368 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
369 -< (mainPageName, mainPage, subPage)