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
14 import Network.HTTP.Lucu
15 import Network.URI hiding (query, fragment)
16 import Rakka.Environment
20 import Rakka.SystemConfig
22 import Rakka.Wiki.Engine
23 import System.FilePath
24 import Text.HyperEstraier hiding (getText)
25 import Text.XML.HXT.Arrow.Namespace
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.Arrow.XmlNodeSet
28 import Text.XML.HXT.DOM.TypeDefs
31 resSearch :: Environment -> ResourceDef
34 resUsesNativeThread = False
36 , resGet = Just $ handleSearch env
44 resultsPerSection :: Int
45 resultsPerSection = 10
48 maxSectionWindowSize :: Int
49 maxSectionWindowSize = 10
53 <searchResult query="foo bar baz"
59 aaa <hit>foo</hit> bbb
65 handleSearch :: Environment -> Resource ()
67 = do params <- getQueryForm
69 let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
71 $ fmap read $ lookup "from" params
72 to = fromMaybe (from + resultsPerSection)
73 $ fmap read $ lookup "to" params
75 cond <- liftIO $ mkCond query from to
76 result <- searchPages (envStorage env) cond
78 let to' = min (from + length (srPages result)) to
80 runIdempotentA $ proc ()
81 -> do tree <- ( eelem "/"
82 += ( eelem "searchResult"
83 += sattr "query" query
84 += sattr "from" (show from)
85 += sattr "to" (show to')
86 += sattr "total" (show $ srTotal result)
87 += ( constL (srPages result)
93 returnA -< outputXmlPage' tree (searchResultToXHTML env)
95 mkCond :: String -> Int -> Int -> IO Condition
97 = do cond <- newCondition
100 setMax cond (to - from)
103 mkPageElem :: ArrowXml a => a HitPage XmlTree
104 mkPageElem = ( eelem "page"
105 += attr "name" (arr hpPageName >>> mkText)
112 mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
113 mkSnippetTree = proc fragment
115 Boundary -> eelem "boundary"
116 NormalText t -> txt t
117 HighlightedWord w -> eelem "hit" += txt w
121 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
122 searchResultToXHTML env
124 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
125 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
126 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
127 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
129 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
130 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
132 pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
133 leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
134 rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
138 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
143 += getXPathTreesInDoc "/searchResult/@query/text()"
148 += sattr "rel" "stylesheet"
149 += sattr "type" "text/css"
150 += attr "href" (arr id >>> mkText)
152 += ( constL scriptSrc
155 += sattr "type" "text/javascript"
156 += attr "src" (arr id >>> mkText)
159 += sattr "type" "text/javascript"
160 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
161 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
162 += txt "Rakka.isSpecialPage=true;"
167 += sattr "class" "header"
170 += sattr "class" "center"
172 += sattr "class" "title"
176 += sattr "class" "body"
178 += txt "Search Result"
181 += sattr "class" "searchStat"
182 += txt "Search result for "
184 += sattr "class" "queryString"
185 += getXPathTreesInDoc "/searchResult/@query/text()"
188 += getXPathTreesInDoc "/searchResult/@total/text()"
191 += ( getXPathTreesInDoc "/searchResult/page"
195 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
200 ( getXPathTreesInDoc "/searchResult/@from/text()"
204 arr ((`div` resultsPerSection) . read)
207 ( getXPathTreesInDoc "/searchResult/@total/text()"
211 arr ((+ 1) . (`div` resultsPerSection) . read)
215 ( ((> 1) . snd . snd)
223 += sattr "class" "footer"
226 += sattr "class" "left sideBar"
228 += sattr "class" "content"
229 += constL leftSideBar
233 += sattr "class" "right sideBar"
235 += sattr "class" "content"
236 += constL rightSideBar
241 uniqueNamespacesFromDeclAndQNames
244 formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree
247 += sattr "class" "searchResult"
249 += attr "href" ( getAttrValue "name"
251 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
255 += (getAttrValue "name" >>> mkText)
260 choiceA [ isText :-> this
261 , hasName "boundary" :-> txt " ... "
262 , hasName "hit" :-> ( eelem "span"
263 += sattr "class" "highlighted"
271 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
274 += sattr "class" "pager"
286 proc (query, (currentSection, section))
287 -> if currentSection == section then
291 += sattr "class" "currentSection"
292 += (arr show >>> mkText)
298 += attr "href" ( mkSectionURI baseURI
302 += (arr (show . snd) >>> mkText)
303 ) -< (query, section)
307 mkSectionWindow :: ArrowList a => a (Int, Int) Int
309 = proc (currentSection, totalSections)
310 -> let windowWidth = min maxSectionWindowSize totalSections
311 windowBegin = currentSection - (windowWidth `div` 2)
312 (begin, end) = if windowBegin < 0 then
316 if windowBegin + windowWidth >= totalSections then
318 (totalSections - windowWidth, totalSections - 1)
321 (windowBegin, windowBegin + windowWidth - 1)
323 arrL id -< [begin .. end]
326 mkSectionURI :: Arrow a => URI -> a (String, Int) URI
328 = arr $ \ (query, section)
330 uriPath = uriPath baseURI </> "search"
331 , uriQuery = '?' : mkQueryString [ ("q" , query)
332 , ("from", show $ section * resultsPerSection)
333 , ("to" , show $ (section + 1) * resultsPerSection - 1)
337 uriToText :: ArrowXml a => a URI XmlTree
338 uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
340 mkQueryString :: [(String, String)] -> String
341 mkQueryString [] = ""
342 mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
346 ';' : mkQueryString(xs)
348 encode :: String -> String
349 encode = escapeURIString isSafeChar . UTF8.encodeString
352 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
354 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
356 = proc (mainPageName, mainPage, subPageName) ->
357 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
358 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
359 -< (mainPageName, mainPage, subPage)