module Rakka.Resource.Search
    ( resSearch
    )
    where

import qualified Codec.Binary.UTF8.String as UTF8
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowIf
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree
import           Control.Monad.Trans
import           Data.Maybe
import           Network.HTTP.Lucu
import           Network.URI hiding (query, fragment)
import           Rakka.Environment
import           Rakka.Page
import           Rakka.Resource
import           Rakka.Storage
import           Rakka.SystemConfig
import           Rakka.Utils
import           Rakka.Wiki.Engine
import           System.FilePath
import           Text.HyperEstraier
import           Text.XML.HXT.Arrow.Namespace
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlNodeSet
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
      }


defaultResultsPerPage :: Int
defaultResultsPerPage = 20


{-
  <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 = UTF8.decodeString $ fromMaybe ""  $ lookup "q" params
             from  = fromMaybe 0
                     $ fmap read $ lookup "from" params
             to    = fromMaybe defaultResultsPerPage
                     $ fmap read $ lookup "to"   params

         cond   <- liftIO $ mkCond query from to
         result <- searchPages (envStorage env) cond

         let to' = min (from + length (srPages result)) to

         runIdempotentA $ proc ()
             -> do tree <- ( eelem "/"
                             += ( eelem "searchResult"
                                  += sattr "query" query
                                  += sattr "from"  (show from)
                                  += sattr "to"    (show to')
                                  += sattr "total" (show $ srTotal result)
                                  += ( constL (srPages 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 HitPage XmlTree
      mkPageElem = ( eelem "page"
                     += attr "name" (arr hpPageName >>> mkText)
                     += ( arrL hpSnippet
                          >>>
                          mkSnippetTree
                        )
                   )

      mkSnippetTree :: ArrowXml a => a SnippetFragment XmlTree
      mkSnippetTree = proc fragment
                    -> case fragment of
                         Boundary          -> eelem "boundary"
                         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
    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()

          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]

          pageTitle    <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle")
          leftSideBar  <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left")
          rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right")

          ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                 += ( eelem "head"
                      += ( eelem "title"
                           += txt siteName
                           += txt " - "
                           += getXPathTreesInDoc "/searchResult/@query/text()"
                         )
                      += ( constL cssHref
                           >>>
                           eelem "link"
                           += sattr "rel"  "stylesheet"
                           += sattr "type" "text/css"
                           += attr "href" (arr id >>> mkText)
                         )
                      += ( constL scriptSrc
                           >>>
                           eelem "script"
                           += sattr "type" "text/javascript"
                           += attr "src" (arr id >>> mkText)
                         )
                      += ( eelem "script"
                           += sattr "type" "text/javascript"
                           += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
                           += txt  "Rakka.isSpecialPage=true;"
                         )
                    )
                 += ( eelem "body"
                      += ( eelem "div"
                           += sattr "class" "header"
                         )
                      += ( eelem "div"
                           += sattr "class" "center"
                           += ( eelem "div"
                                += sattr "class" "title"
                                += constL pageTitle
                              )
                           += ( eelem "div"
                                += sattr "class" "body"
                                += ( eelem "h1"
                                     += txt "Search Result"
                                   )
                                += ( eelem "div"
                                     += sattr "class" "searchStat"
                                     += txt "Search result for "
                                     += ( eelem "span"
                                          += sattr "class" "queryString"
                                          += getXPathTreesInDoc "/searchResult/@query/text()"
                                        )
                                     += txt ": found "
                                     += getXPathTreesInDoc "/searchResult/@total/text()"
                                     += txt " pages."
                                   )
                                += ( getXPathTreesInDoc "/searchResult/page"
                                     >>>
                                     eelem "div"
                                     += sattr "class" "searchResult"
                                     += ( eelem "a"
                                          += attr "href" ( getAttrValue "name"
                                                           >>>
                                                           arr (\ x -> uriToString id (mkPageURI baseURI x) "")
                                                           >>>
                                                           mkText
                                                         )
                                          += (getAttrValue "name" >>> mkText)
                                        )
                                     += ( eelem "p"
                                          += ( getChildren
                                               >>>
                                               choiceA [ isText             :-> this
                                                       , hasName "boundary" :-> txt " ... "
                                                       , hasName "hit"      :-> ( eelem "span"
                                                                                  += sattr "class" "highlighted"
                                                                                  += getChildren
                                                                                )
                                                       ]
                                             )
                                        )
                                   )
                              )
                         )
                      += ( eelem "div"
                           += sattr "class" "footer"
                         )
                      += ( eelem "div"
                           += sattr "class" "left sideBar"
                           += ( eelem "div"
                                += sattr "class" "content"
                                += constL leftSideBar
                              )
                         )
                      += ( eelem "div"
                           += sattr "class" "right sideBar"
                           += ( eelem "div"
                                += sattr "class" "content"
                                += constL rightSideBar
                              )
                         )
                    )
                 >>>
                 uniqueNamespacesFromDeclAndQNames
               ) ) -<< tree


readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
               Environment
            -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
readSubPage env
    = proc (mainPageName, mainPage, subPageName) ->
      do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
         subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
                     -< (mainPageName, mainPage, subPage)
         returnA -< subXHTML