Rakka/Resource/Search.hs

   1 module Rakka.Resource.Search
   2     ( resSearch
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIO
   8 import           Control.Arrow.ArrowList
   9 import           Control.Monad.Trans
  10 import           Data.Maybe
  11 import           Network.HTTP.Lucu
  12 import           Rakka.Environment
  13 import           Rakka.Resource
  14 import           Rakka.Storage
  15 import           Text.HyperEstraier
  16 import           Text.XML.HXT.Arrow.XmlArrow
  17 import           Text.XML.HXT.DOM.TypeDefs
  18
  19
  20 resSearch :: Environment -> ResourceDef
  21 resSearch env
  22     = ResourceDef {
  23         resUsesNativeThread = False
  24       , resIsGreedy         = False
  25       , resGet              = Just $ handleSearch env
  26       , resHead             = Nothing
  27       , resPost             = Nothing
  28       , resPut              = Nothing
  29       , resDelete           = Nothing
  30       }
  31
  32
  33 {-
  34   <searchResult query="foo bar baz"
  35                 from="0"
  36                 to="5"
  37                 total="5">
  38
  39     <page name="Page/1">
  40       aaa <hit>foo</hit> bbb
  41     </page>
  42
  43     ...
  44   </searchResult>
  45 -}
  46 handleSearch :: Environment -> Resource ()
  47 handleSearch env
  48     = do params <- getQueryForm
  49
  50          let query = fromMaybe ""  $ lookup "q" params
  51              from  = read $ fromMaybe "0"  $ lookup "from" params
  52              to    = read $ fromMaybe "20" $ lookup "to"   params
  53
  54          cond   <- liftIO $ mkCond query from to
  55          result <- searchPages (envStorage env) cond
  56
  57          let to' = min (from + length result) to
  58
  59          runIdempotentA $ proc ()
  60              -> do tree <- ( eelem "/"
  61                              += ( eelem "searchResult"
  62                                   += sattr "query" query
  63                                   += sattr "from"  (show from)
  64                                   += sattr "to"    (show to')
  65                                   += sattr "total" (show $ length result)
  66                                   += ( constL result
  67                                        >>>
  68                                        mkPageElem
  69                                      )
  70                                 )
  71                            ) -< ()
  72                    returnA -< outputXmlPage' tree (searchResultToXHTML env)
  73     where
  74       mkCond :: String -> Int -> Int -> IO Condition
  75       mkCond query from to
  76           = do cond <- newCondition
  77                setPhrase cond query
  78                setSkip   cond from
  79                setMax    cond (to - from)
  80                return cond
  81
  82       mkPageElem :: ArrowXml a => a SearchResult XmlTree
  83       mkPageElem = ( eelem "page"
  84                      += attr "name" (arr srPageName >>> mkText)
  85                      += ( arrL srSnippet
  86                           >>>
  87                           mkSnippetTree
  88                         )
  89                    )
  90
  91       mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
  92       mkSnippetTree = proc fragment
  93                     -> case fragment of
  94                          NormalText      t -> txt t
  95                          HighlightedWord w -> eelem "hit" += txt w
  96                          -<< ()
  97
  98
  99 searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
 100 searchResultToXHTML env
 101     = proc tree
 102     -> this -< tree