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           Data.Time
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.W3CDateTime
import           Rakka.Wiki.Engine
import           System.FilePath
import           Text.HyperEstraier hiding (getText)
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
      }


resultsPerSection :: Int
resultsPerSection = 10


maxSectionWindowSize :: Int
maxSectionWindowSize = 10


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

         cond   <- liftIO $ mkCond query 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
                                  += 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 :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
      mkPageElem = ( eelem "page"
                     += attr "name" (arr hpPageName >>> mkText)
                     += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
                                              >>>
                                              arr formatW3CDateTime
                                              >>>
                                              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) -< (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"
                                     >>>
                                     formatItem baseURI
                                   )
                                += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
                                         >>>
                                         getText
                                       )
                                       &&&
                                       ( getXPathTreesInDoc "/searchResult/@from/text()"
                                         >>>
                                         getText
                                         >>>
                                         arr ((`div` resultsPerSection) . read)
                                       )
                                       &&&
                                       ( getXPathTreesInDoc "/searchResult/@total/text()"
                                         >>>
                                         getText
                                         >>>
                                         arr ((+ 1) . (`div` resultsPerSection) . read)
                                       )
                                     )
                                     >>>
                                     ( ((> 1) . 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) => 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 "p"
                   += ( getChildren
                        >>>
                        choiceA [ isText             :-> this
                                , hasName "boundary" :-> txt " ... "
                                , hasName "hit"      :-> ( eelem "span"
                                                           += sattr "class" "highlighted"
                                                           += getChildren
                                                         )
                                ]
                      )
                 )
            )

      formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree
      formatPager baseURI
          = ( eelem "div"
              += sattr "class" "pager"
              += txt "Page."
              += ( ( arr fst
                     &&&
                     arr (fst . snd)
                     &&&
                     ( arr snd
                       >>>
                       mkSectionWindow
                     )
                   )
                   >>>
                   proc (query, (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) >>> mkText)
                              ) -< (query, 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, Int) URI
      mkSectionURI baseURI
          = arr $ \ (query, section)
          -> baseURI {
               uriPath  = uriPath baseURI </> "search"
             , uriQuery = '?' : mkQueryString [ ("q"   , query)
                                              , ("from", show $ section * resultsPerSection)
                                              , ("to"  , show $ (section + 1) * resultsPerSection - 1)
                                              ]
             }

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

      mkQueryString :: [(String, String)] -> String
      mkQueryString []            = ""
      mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
                                    if xs == [] then
                                        ""
                                    else
                                        ';' : mkQueryString(xs)

      encode :: String -> String
      encode = escapeURIString isSafeChar . UTF8.encodeString


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