continue working on page search

[Rakka.git] / Rakka / Resource / Search.hs

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
new file mode 100644 (file)
index 0000000..8271640
--- /dev/null
+++ b/Rakka/Resource/Search.hs
@@ -0,0 +1,102 @@
+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