module Rakka.Resource.Search
    ( resSearch
    )
    where

import qualified Codec.Binary.UTF8.Generic as UTF8
import           Control.Monad.Trans
import           Data.List
import           Data.Maybe
import           Data.Time
import qualified Data.Time.RFC1123 as RFC1123
import qualified Data.Time.W3C as W3C
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 hiding (getText)
import           Text.XML.HXT.Arrow
import           Text.XML.HXT.XPath


resSearch :: Environment -> ResourceDef
resSearch env
    = ResourceDef {
        resUsesNativeThread = False
      , resIsGreedy         = False
      , resGet              = Just $ handleSearch env
      , resHead             = Nothing
      , resPost             = Nothing
      , resPut              = Nothing
      , resDelete           = Nothing
      }


resultsPerSection :: Int
resultsPerSection = 10


maxSectionWindowSize :: Int
maxSectionWindowSize = 10


findQueryParam :: String -> [FormData] -> Maybe String
findQueryParam name qps
    = do fd <- find (\ qp -> fdName qp == name) qps
         return $ UTF8.toString $ fdContent fd

{-
  <searchResult query="foo bar baz"
                from="0"
                to="5"
                total="5">

    <page name="Page/1" lastModified="2000-01-01T00:00:00">
      aaa <hit>foo</hit> bbb
    </page>

    ...
  </searchResult>
-}
handleSearch :: Environment -> Resource ()
handleSearch env
    = do params <- getQueryForm

         let query = fromMaybe "" $ findQueryParam "q" params
             order = findQueryParam "order" params
             from  = fromMaybe 0
                     $ fmap read $ findQueryParam "from" params
             to    = fromMaybe (from + resultsPerSection)
                     $ fmap read $ findQueryParam "to" params

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

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

         BaseURI baseURI <- getSysConf (envSysConf env)
         runIdempotentA baseURI $ proc ()
             -> do tree <- ( eelem "/"
                             += ( eelem "searchResult"
                                  += sattr "query" query
                                  += ( case order of
                                         Just o  -> sattr "order" o
                                         Nothing -> none
                                     )
                                  += 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 -> Maybe String -> Int -> Int -> IO Condition
      mkCond query order from to
          = do cond <- newCondition
               setPhrase cond query
               case order of
                 Just o  -> setOrder cond o
                 Nothing -> return ()
               setSkip   cond from
               setMax    cond (to - from + 1)
               return cond

      mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
      mkPageElem = ( eelem "page"
                     += attr "name" (arr hpPageName >>> mkText)
                     += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
                                              >>>
                                              arr W3C.format
                                              >>>
                                              mkText
                                            )
                     += ( arrL hpSnippet
                          >>>
                          mkSnippetTree
                        )
                   )

      mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
      mkSnippetTree = proc fragment
                    -> case fragment of
                         Boundary          -> eelem "boundary" -< ()
                         NormalText      t -> mkText           -< t
                         HighlightedWord w -> ( eelem "hit"
                                                += mkText
                                              ) -< 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) -< "PageTitle"
          leftSideBar  <- listA (readSubPage env) -< "SideBar/Left"
          rightSideBar <- listA (readSubPage env) -< "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"
                                     >>>
                                     formatItem baseURI
                                   )
                                += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
                                         >>>
                                         getText
                                       )
                                       &&&
                                       maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
                                                >>>
                                                getText
                                              )
                                       &&&
                                       ( getXPathTreesInDoc "/searchResult/@from/text()"
                                         >>>
                                         getText
                                         >>>
                                         arr ((`div` resultsPerSection) . read)
                                       )
                                       &&&
                                       ( getXPathTreesInDoc "/searchResult/@total/text()"
                                         >>>
                                         getText
                                         >>>
                                         arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
                                       )
                                     )
                                     >>>
                                     ( ((> 1) . snd . snd . snd)
                                       `guardsP`
                                       formatPager baseURI
                                     )
                                   )
                              )
                         )
                      += ( 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
    where
      formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
      formatItem baseURI
          = ( eelem "div"
              += sattr "class" "searchResult"
              += ( eelem "a"
                   += attr "href" ( getAttrValue "name"
                                    >>>
                                    arr (\ x -> uriToString id (mkPageURI baseURI x) "")
                                    >>>
                                    mkText
                                  )
                   += (getAttrValue "name" >>> mkText)
                 )
              += ( eelem "div"
                   += sattr "class" "date"
                   += ( getAttrValue "lastModified"
                        >>>
                        arr (zonedTimeToUTC . fromJust . W3C.parse)
                        >>>
                        arrIO utcToLocalZonedTime
                        >>>
                        arr RFC1123.format
                        >>>
                        mkText
                      )
                 )
              += ( eelem "p"
                   += ( getChildren
                        >>>
                        choiceA [ isText             :-> this
                                , hasName "boundary" :-> txt " ... "
                                , hasName "hit"      :-> ( eelem "span"
                                                           += sattr "class" "highlighted"
                                                           += getChildren
                                                         )
                                ]
                      )
                 )
            )

      formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
      formatPager baseURI
          = ( eelem "div"
              += sattr "class" "pager"
              += txt "Page."
              += ( ( arr fst
                     &&&
                     arr (fst . snd)
                     &&&
                     arr (fst . snd . snd)
                     &&&
                     ( arr (snd . snd)
                       >>>
                       mkSectionWindow
                     )
                   )
                   >>>
                   proc (query, (order, (currentSection, section)))
                       -> if currentSection == section then
                              ( txt " "
                                <+> 
                                eelem "span"
                                += sattr "class" "currentSection"
                                += (arr show >>> mkText)
                              ) -< section
                          else
                              ( txt " "
                                <+>
                                eelem "a"
                                += attr "href" ( mkSectionURI baseURI
                                                 >>>
                                                 uriToText
                                               )
                                += (arr (show . snd . snd) >>> mkText)
                              ) -< (query, (order, section))
                 )
            )

      mkSectionWindow :: ArrowList a => a (Int, Int) Int
      mkSectionWindow 
          = proc (currentSection, totalSections)
          -> let windowWidth  = min maxSectionWindowSize totalSections
                 windowBegin  = currentSection - (windowWidth `div` 2)
                 (begin, end) = if windowBegin < 0 then
                                    -- 左に溢れた
                                    (0, windowWidth - 1)
                                else
                                    if windowBegin + windowWidth >= totalSections then
                                        -- 右に溢れた
                                        (totalSections - windowWidth, totalSections - 1)
                                    else
                                        -- どちらにも溢れない
                                        (windowBegin, windowBegin + windowWidth - 1)
             in
               arrL id -< [begin .. end]
                       

      mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
      mkSectionURI baseURI
          = arr $ \ (query, (order, section))
          -> baseURI {
               uriPath  = uriPath baseURI </> "search.html"
             , uriQuery = '?' : mkQueryString ( [ ("q"   , query)
                                                , ("from", show $ section * resultsPerSection)
                                                , ("to"  , show $ (section + 1) * resultsPerSection - 1)
                                                ]
                                                ++ 
                                                case order of
                                                  Just o  -> [("order", o)]
                                                  Nothing -> []
                                              )
             }

      uriToText :: ArrowXml a => a URI XmlTree
      uriToText = arr (\ uri -> uriToString id uri "") >>> mkText


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