{-# LANGUAGE
    Arrows
  , OverloadedStrings
  , TypeOperators
  , UnicodeSyntax
  #-}
module Rakka.Resource.Search
    ( resSearch
    )
    where
import Control.Applicative
import Control.Arrow
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Control.Arrow.ArrowTree
import Control.Arrow.Unicode
import qualified Codec.Binary.UTF8.Generic as UTF8
import           Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
import           Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
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 Prelude.Unicode
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.Namespace
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
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 → [(String, FormData)] → Maybe String
findQueryParam name qps
    = UTF8.toString ∘ fdContent <$> lookup name qps

{-
  <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 (T.pack query) (T.pack <$> 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 ∷ Text → Maybe Text → 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)
               pure cond

      mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree
      mkPageElem = ( eelem "page"
                     += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
                     += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
                                              ⋙
                                              arr W3C.format
                                              ⋙
                                              mkText
                                            )
                     += ( arrL hpSnippet
                          ⋙
                          mkSnippetTree
                        )
                   )

      mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree
      mkSnippetTree = proc fragment
                    → case fragment of
                        Boundary          → eelem "boundary" ⤙ ()
                        NormalText      t → mkText           ⤙ T.unpack t
                        HighlightedWord w → ( eelem "hit"
                                              += mkText
                                            ) ⤙ T.unpack w

searchResultToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
                    ⇒ Environment
                    → 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 (T.unpack 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 (⇝), ArrowChoice (⇝), ArrowIO (⇝))
                 ⇒ URI
                 → XmlTree ⇝ XmlTree
      formatItem baseURI
          = ( eelem "div"
              += sattr "class" "searchResult"
              += ( eelem "a"
                   += attr "href" ( getAttrValue "name"
                                    ⋙
                                    arr (\x → uriToString id (mkPageURI baseURI (T.pack 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 = '?' : C8.unpack (mkQueryString ( [ ("q"   , T.pack query)
                                                           , ("from", T.pack ∘ show $ section       ⋅ resultsPerSection    )
                                                           , ("to"  , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1)
                                                           ]
                                                           ++
                                                           case order of
                                                             Just o  -> [("order", T.pack 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