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