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
74 $ fmap read $ lookup "from" params
75 to = fromMaybe (from + resultsPerSection)
76 $ fmap read $ lookup "to" params
78 cond <- liftIO $ mkCond query 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
88 += sattr "from" (show from)
89 += sattr "to" (show to')
90 += sattr "total" (show $ srTotal result)
91 += ( constL (srPages result)
97 returnA -< outputXmlPage' tree (searchResultToXHTML env)
99 mkCond :: String -> Int -> Int -> IO Condition
101 = do cond <- newCondition
104 setMax cond (to - from)
107 mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
108 mkPageElem = ( eelem "page"
109 += attr "name" (arr hpPageName >>> mkText)
110 += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
112 arr formatW3CDateTime
122 mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
123 mkSnippetTree = proc fragment
125 Boundary -> eelem "boundary" -< ()
126 NormalText t -> mkText -< t
127 HighlightedWord w -> ( eelem "hit"
132 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
133 searchResultToXHTML env
135 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
136 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
137 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
138 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
140 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
141 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
143 pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
144 leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
145 rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
149 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
154 += getXPathTreesInDoc "/searchResult/@query/text()"
159 += sattr "rel" "stylesheet"
160 += sattr "type" "text/css"
161 += attr "href" (arr id >>> mkText)
163 += ( constL scriptSrc
166 += sattr "type" "text/javascript"
167 += attr "src" (arr id >>> mkText)
170 += sattr "type" "text/javascript"
171 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
172 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
173 += txt "Rakka.isSpecialPage=true;"
178 += sattr "class" "header"
181 += sattr "class" "center"
183 += sattr "class" "title"
187 += sattr "class" "body"
189 += txt "Search Result"
192 += sattr "class" "searchStat"
193 += txt "Search result for "
195 += sattr "class" "queryString"
196 += getXPathTreesInDoc "/searchResult/@query/text()"
199 += getXPathTreesInDoc "/searchResult/@total/text()"
202 += ( getXPathTreesInDoc "/searchResult/page"
206 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
211 ( getXPathTreesInDoc "/searchResult/@from/text()"
215 arr ((`div` resultsPerSection) . read)
218 ( getXPathTreesInDoc "/searchResult/@total/text()"
222 arr ((+ 1) . (`div` resultsPerSection) . read)
226 ( ((> 1) . snd . snd)
234 += sattr "class" "footer"
237 += sattr "class" "left sideBar"
239 += sattr "class" "content"
240 += constL leftSideBar
244 += sattr "class" "right sideBar"
246 += sattr "class" "content"
247 += constL rightSideBar
252 uniqueNamespacesFromDeclAndQNames
255 formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
258 += sattr "class" "searchResult"
260 += attr "href" ( getAttrValue "name"
262 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
266 += (getAttrValue "name" >>> mkText)
269 += sattr "class" "date"
270 += ( getAttrValue "lastModified"
272 arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
274 arrIO utcToLocalZonedTime
276 arr formatRFC1123DateTime
284 choiceA [ isText :-> this
285 , hasName "boundary" :-> txt " ... "
286 , hasName "hit" :-> ( eelem "span"
287 += sattr "class" "highlighted"
295 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
298 += sattr "class" "pager"
310 proc (query, (currentSection, section))
311 -> if currentSection == section then
315 += sattr "class" "currentSection"
316 += (arr show >>> mkText)
322 += attr "href" ( mkSectionURI baseURI
326 += (arr (show . snd) >>> mkText)
327 ) -< (query, section)
331 mkSectionWindow :: ArrowList a => a (Int, Int) Int
333 = proc (currentSection, totalSections)
334 -> let windowWidth = min maxSectionWindowSize totalSections
335 windowBegin = currentSection - (windowWidth `div` 2)
336 (begin, end) = if windowBegin < 0 then
340 if windowBegin + windowWidth >= totalSections then
342 (totalSections - windowWidth, totalSections - 1)
345 (windowBegin, windowBegin + windowWidth - 1)
347 arrL id -< [begin .. end]
350 mkSectionURI :: Arrow a => URI -> a (String, Int) URI
352 = arr $ \ (query, section)
354 uriPath = uriPath baseURI </> "search"
355 , uriQuery = '?' : mkQueryString [ ("q" , query)
356 , ("from", show $ section * resultsPerSection)
357 , ("to" , show $ (section + 1) * resultsPerSection - 1)
361 uriToText :: ArrowXml a => a URI XmlTree
362 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
364 mkQueryString :: [(String, String)] -> String
365 mkQueryString [] = ""
366 mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
370 ';' : mkQueryString(xs)
372 encode :: String -> String
373 encode = escapeURIString isSafeChar . UTF8.encodeString
376 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
378 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
380 = proc (mainPageName, mainPage, subPageName) ->
381 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
382 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
383 -< (mainPageName, mainPage, subPage)