7 module Rakka.Resource.Search
11 import Control.Applicative
13 import Control.Arrow.ArrowIf
14 import Control.Arrow.ArrowIO
15 import Control.Arrow.ArrowList
16 import Control.Arrow.ArrowTree
17 import Control.Arrow.Unicode
18 import qualified Codec.Binary.UTF8.Generic as UTF8
19 import Control.Monad.Trans
20 import qualified Data.ByteString.Char8 as C8
22 import Data.Monoid.Unicode
23 import Data.Text (Text)
24 import qualified Data.Text as T
26 import qualified Data.Time.RFC1123 as RFC1123
27 import qualified Data.Time.W3C as W3C
28 import Network.HTTP.Lucu
29 import Network.URI hiding (query, fragment)
30 import Prelude.Unicode
31 import Rakka.Environment
35 import Rakka.SystemConfig
37 import Rakka.Wiki.Engine
38 import System.FilePath
39 import Text.HyperEstraier hiding (getText)
40 import Text.XML.HXT.Arrow.Namespace
41 import Text.XML.HXT.Arrow.XmlArrow
42 import Text.XML.HXT.DOM.TypeDefs
43 import Text.XML.HXT.XPath
45 resSearch :: Environment -> ResourceDef
48 resUsesNativeThread = False
50 , resGet = Just $ handleSearch env
58 resultsPerSection :: Int
59 resultsPerSection = 10
62 maxSectionWindowSize :: Int
63 maxSectionWindowSize = 10
65 findQueryParam ∷ String → [(String, FormData)] → Maybe String
66 findQueryParam name qps
67 = UTF8.toString ∘ fdContent <$> lookup name qps
70 <searchResult query="foo bar baz"
75 <page name="Page/1" lastModified="2000-01-01T00:00:00">
76 aaa <hit>foo</hit> bbb
82 handleSearch ∷ Environment → Resource ()
84 = do params ← getQueryForm
86 let query = fromMaybe "" $ findQueryParam "q" params
87 order = findQueryParam "order" params
89 $ fmap read $ findQueryParam "from" params
90 to = fromMaybe (from + resultsPerSection)
91 $ fmap read $ findQueryParam "to" params
93 cond ← liftIO $ mkCond (T.pack query) (T.pack <$> order) from to
94 result ← searchPages (envStorage env) cond
96 let to' = min (from + length (srPages result)) to
98 BaseURI baseURI ← getSysConf (envSysConf env)
99 runIdempotentA baseURI $ proc ()
100 → do tree ← ( eelem "/"
101 += ( eelem "searchResult"
102 += sattr "query" query
104 Just o → sattr "order" o
107 += sattr "from" (show from)
108 += sattr "to" (show to')
109 += sattr "total" (show $ srTotal result)
110 += ( constL (srPages result)
116 returnA ⤙ outputXmlPage' tree (searchResultToXHTML env)
118 mkCond ∷ Text → Maybe Text → Int → Int → IO Condition
119 mkCond query order from to
120 = do cond ← newCondition
123 Just o → setOrder cond o
126 setMax cond (to - from + 1)
129 mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree
130 mkPageElem = ( eelem "page"
131 += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
132 += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
144 mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree
145 mkSnippetTree = proc fragment
147 Boundary → eelem "boundary" ⤙ ()
148 NormalText t → mkText ⤙ T.unpack t
149 HighlightedWord w → ( eelem "hit"
153 searchResultToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
156 searchResultToXHTML env
158 → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
159 BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
160 StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
161 GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
163 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
164 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
166 pageTitle ← listA (readSubPage env) ⤙ "PageTitle"
167 leftSideBar ← listA (readSubPage env) ⤙ "SideBar/Left"
168 rightSideBar ← listA (readSubPage env) ⤙ "SideBar/Right"
172 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
175 += txt (T.unpack siteName)
177 += getXPathTreesInDoc "/searchResult/@query/text()"
182 += sattr "rel" "stylesheet"
183 += sattr "type" "text/css"
184 += attr "href" (arr id ⋙ mkText)
186 += ( constL scriptSrc
189 += sattr "type" "text/javascript"
190 += attr "src" (arr id ⋙ mkText)
193 += sattr "type" "text/javascript"
194 += txt ("Rakka.baseURI=\"" ⊕ uriToString id baseURI "" ⊕ "\";")
195 += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked ⊕ ";" )
196 += txt "Rakka.isSpecialPage=true;" ) )
199 += sattr "class" "header"
202 += sattr "class" "center"
204 += sattr "class" "title"
208 += sattr "class" "body"
210 += txt "Search Result"
213 += sattr "class" "searchStat"
214 += txt "Search result for "
216 += sattr "class" "queryString"
217 += getXPathTreesInDoc "/searchResult/@query/text()"
220 += getXPathTreesInDoc "/searchResult/@total/text()"
223 += ( getXPathTreesInDoc "/searchResult/page"
227 += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
232 maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
237 ( getXPathTreesInDoc "/searchResult/@from/text()"
241 arr ((`div` resultsPerSection) . read)
244 ( getXPathTreesInDoc "/searchResult/@total/text()"
248 arr ((+ 1) . (`div` resultsPerSection) . (\x → x - 1) . read) ) )
250 ( ((> 1) . snd . snd . snd)
252 formatPager baseURI ) ) ) )
254 += sattr "class" "footer"
257 += sattr "class" "left sideBar"
259 += sattr "class" "content"
260 += constL leftSideBar
264 += sattr "class" "right sideBar"
266 += sattr "class" "content"
267 += constL rightSideBar
272 uniqueNamespacesFromDeclAndQNames
275 formatItem ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
280 += sattr "class" "searchResult"
282 += attr "href" ( getAttrValue "name"
284 arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "")
288 += (getAttrValue "name" ⋙ mkText)
291 += sattr "class" "date"
292 += ( getAttrValue "lastModified"
294 arr (zonedTimeToUTC . fromJust . W3C.parse)
296 arrIO utcToLocalZonedTime
306 choiceA [ isText :-> this
307 , hasName "boundary" :-> txt " ... "
308 , hasName "hit" :-> ( eelem "span"
309 += sattr "class" "highlighted"
317 formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
320 += sattr "class" "pager"
326 arr (fst . snd . snd)
334 proc (query, (order, (currentSection, section)))
335 -> if currentSection == section then
339 += sattr "class" "currentSection"
340 += (arr show ⋙ mkText)
346 += attr "href" ( mkSectionURI baseURI
350 += (arr (show . snd . snd) ⋙ mkText)
351 ) ⤙ (query, (order, section))
355 mkSectionWindow :: ArrowList a => a (Int, Int) Int
357 = proc (currentSection, totalSections)
358 -> let windowWidth = min maxSectionWindowSize totalSections
359 windowBegin = currentSection - (windowWidth `div` 2)
360 (begin, end) = if windowBegin < 0 then
364 if windowBegin + windowWidth >= totalSections then
366 (totalSections - windowWidth, totalSections - 1)
369 (windowBegin, windowBegin + windowWidth - 1)
371 arrL id ⤙ [begin .. end]
374 mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
376 = arr $ \ (query, (order, section))
378 uriPath = uriPath baseURI </> "search.html"
379 , uriQuery = '?' : C8.unpack (mkQueryString ( [ ("q" , T.pack query)
380 , ("from", T.pack ∘ show $ section ⋅ resultsPerSection )
381 , ("to" , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1)
385 Just o -> [("order", T.pack o)]
390 uriToText :: ArrowXml a => a URI XmlTree
391 uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText
395 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
396 Environment -> a PageName XmlTree
398 = proc (subPageName) ->
399 do subPage ← getPageA (envStorage env) ⋙ arr fromJust ⋙ xmlizePage ⤙ (subPageName, Nothing)
400 subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) ⤙ (Nothing, Nothing, subPage)