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
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
45 <searchResult query="foo bar baz"
51 aaa <hit>foo</hit> bbb
57 handleSearch :: Environment -> Resource ()
59 = do params <- getQueryForm
61 let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params
62 from = read $ fromMaybe "0" $ lookup "from" params
63 to = read $ fromMaybe "20" $ lookup "to" params
65 cond <- liftIO $ mkCond query from to
66 result <- searchPages (envStorage env) cond
68 let to' = min (from + length result) to
70 runIdempotentA $ proc ()
71 -> do tree <- ( eelem "/"
72 += ( eelem "searchResult"
73 += sattr "query" query
74 += sattr "from" (show from)
75 += sattr "to" (show to')
76 += sattr "total" (show $ length result)
83 returnA -< outputXmlPage' tree (searchResultToXHTML env)
85 mkCond :: String -> Int -> Int -> IO Condition
87 = do cond <- newCondition
90 setMax cond (to - from)
93 mkPageElem :: ArrowXml a => a SearchResult XmlTree
94 mkPageElem = ( eelem "page"
95 += attr "name" (arr srPageName >>> mkText)
102 mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
103 mkSnippetTree = proc fragment
105 Boundary -> eelem "boundary"
106 NormalText t -> txt t
107 HighlightedWord w -> eelem "hit" += txt w
111 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
112 searchResultToXHTML env
114 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
115 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
116 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
117 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
119 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
120 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
122 pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
123 leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
124 rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")
128 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
133 += getXPathTreesInDoc "/searchResult/@query/text()"
138 += sattr "rel" "stylesheet"
139 += sattr "type" "text/css"
140 += attr "href" (arr id >>> mkText)
142 += ( constL scriptSrc
145 += sattr "type" "text/javascript"
146 += attr "src" (arr id >>> mkText)
149 += sattr "type" "text/javascript"
150 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
151 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
152 += txt "Rakka.isSpecialPage=true;"
157 += sattr "class" "header"
160 += sattr "class" "center"
162 += sattr "class" "title"
166 += sattr "class" "body"
168 += txt "Search Result"
171 += sattr "class" "searchStat"
172 += txt "Search result for "
174 += sattr "class" "queryString"
175 += getXPathTreesInDoc "/searchResult/@query/text()"
178 += getXPathTreesInDoc "/searchResult/@total/text()"
181 += ( getXPathTreesInDoc "/searchResult/page"
184 += sattr "class" "searchResult"
186 += attr "href" ( getAttrValue "name"
188 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
192 += (getAttrValue "name" >>> mkText)
197 choiceA [ isText :-> this
198 , hasName "boundary" :-> txt " ... "
199 , hasName "hit" :-> ( eelem "span"
200 += sattr "class" "highlighted"
210 += sattr "class" "footer"
213 += sattr "class" "left sideBar"
215 += sattr "class" "content"
216 += constL leftSideBar
220 += sattr "class" "right sideBar"
222 += sattr "class" "content"
223 += constL rightSideBar
228 uniqueNamespacesFromDeclAndQNames
232 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
234 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
236 = proc (mainPageName, mainPage, subPageName) ->
237 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
238 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
239 -< (mainPageName, mainPage, subPage)