+module Rakka.Resource.Search
+ ( resSearch
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Monad.Trans
+import Data.Maybe
+import Network.HTTP.Lucu
+import Rakka.Environment
+import Rakka.Resource
+import Rakka.Storage
+import Text.HyperEstraier
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+
+
+resSearch :: Environment -> ResourceDef
+resSearch env
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = False
+ , resGet = Just $ handleSearch env
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+
+{-
+ <searchResult query="foo bar baz"
+ from="0"
+ to="5"
+ total="5">
+
+ <page name="Page/1">
+ aaa <hit>foo</hit> bbb
+ </page>
+
+ ...
+ </searchResult>
+-}
+handleSearch :: Environment -> Resource ()
+handleSearch env
+ = do params <- getQueryForm
+
+ let query = fromMaybe "" $ lookup "q" params
+ from = read $ fromMaybe "0" $ lookup "from" params
+ to = read $ fromMaybe "20" $ lookup "to" params
+
+ cond <- liftIO $ mkCond query from to
+ result <- searchPages (envStorage env) cond
+
+ let to' = min (from + length result) to
+
+ runIdempotentA $ proc ()
+ -> do tree <- ( eelem "/"
+ += ( eelem "searchResult"
+ += sattr "query" query
+ += sattr "from" (show from)
+ += sattr "to" (show to')
+ += sattr "total" (show $ length result)
+ += ( constL result
+ >>>
+ mkPageElem
+ )
+ )
+ ) -< ()
+ returnA -< outputXmlPage' tree (searchResultToXHTML env)
+ where
+ mkCond :: String -> Int -> Int -> IO Condition
+ mkCond query from to
+ = do cond <- newCondition
+ setPhrase cond query
+ setSkip cond from
+ setMax cond (to - from)
+ return cond
+
+ mkPageElem :: ArrowXml a => a SearchResult XmlTree
+ mkPageElem = ( eelem "page"
+ += attr "name" (arr srPageName >>> mkText)
+ += ( arrL srSnippet
+ >>>
+ mkSnippetTree
+ )
+ )
+
+ mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
+ mkSnippetTree = proc fragment
+ -> case fragment of
+ NormalText t -> txt t
+ HighlightedWord w -> eelem "hit" += txt w
+ -<< ()
+
+
+searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+searchResultToXHTML env
+ = proc tree
+ -> this -< tree