module Rakka.Resource.PageEntity
    ( fallbackPageEntity
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowIf
import           Control.Arrow.ArrowList
import           Data.Char
import           Data.Maybe
import           Network.HTTP.Lucu
import           Network.HTTP.Lucu.Utils
import           Network.URI hiding (path)
import           Rakka.Environment
import           Rakka.Page
import           Rakka.Resource
import           Rakka.Storage
import           Rakka.SystemConfig
import           Rakka.Wiki.Engine
import           System.FilePath
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlNodeSet
import           Text.XML.HXT.DOM.TypeDefs


fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
fallbackPageEntity env path
    | null path                  = return Nothing
    | null $ head path           = return Nothing
    | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
    | otherwise
        = return $ Just $ ResourceDef {
            resUsesNativeThread = False
          , resIsGreedy         = True
          , resGet              = Just $ handleGet env (toPageName path)
          , resHead             = Nothing
          , resPost             = Nothing
          , resPut              = Just $ handlePut env (toPageName path)
          , resDelete           = Nothing
          }
    where
      toPageName :: [String] -> PageName
      toPageName = decodePageName . dropExtension . joinWith "/"


handleGet :: Environment -> PageName -> Resource ()
handleGet env name
    = runIdempotentA $ proc ()
    -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
          case pageM of
            Nothing
                -> handlePageNotFound env -< name

            Just redir@(Redirection _ _ _ _)
                -> handleRedirect env -< redir

            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
                -> handleGetEntity env -< entity

{-
  HTTP/1.1 302 Found
  Location: http://example.org/Destination?from=Source
-}
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
    = proc redir
    -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
          returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME


handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
    = proc page
    -> do tree <- xmlizePage -< page
          returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
                        -- てゐる可能性があるので、ETag も
                        -- Last-Modified も返す事が出來ない。
                        case pageType page of
                          MIMEType "text" "x-rakka" _
                              -> return ()
                          _   -> case pageRevision page of
                                   0   -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
                                   rev -> foundEntity (strongETag $ show rev) (pageLastMod page)

                        outputXmlPage tree (entityToXHTML env)


entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
entityToXHTML env
    = proc page
    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()

          name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page

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

          pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
          leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
          rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
          pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page

          ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                 += ( getXPathTreesInDoc "/page/@lang"
                      `guards`
                      qattr (QN "xml" "lang" "")
                                ( getXPathTreesInDoc "/page/@lang/text()" )
                    )
                 += ( eelem "head"
                      += ( eelem "title"
                           += txt siteName
                           += txt " - "
                           += getXPathTreesInDoc "/page/@name/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 "body"
                      += ( eelem "div"
                           += sattr "class" "header"
                         )
                      += ( eelem "div"
                           += sattr "class" "center"
                           += ( eelem "div"
                                += sattr "class" "title"
                                += constL pageTitle
                              )
                           += ( eelem "div"
                                += sattr "class" "body"
                                += constL pageBody
                              )
                         )
                      += ( 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
                              )
                         )
                    )
               ) ) -<< page


readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
               Environment
            -> a (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


{-
  <pageNotFound name="Foo/Bar" />
-}
handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
handlePageNotFound env
    = proc name
    -> do tree <- ( eelem "/"
                    += ( eelem "pageNotFound"
                         += attr "name" (arr id >>> mkText)
                       )
                  ) -< name
          returnA -< do setStatus NotFound
                        outputXmlPage tree (notFoundToXHTML env)


notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
notFoundToXHTML env
    = proc pageNotFound
    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()

          name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound

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

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

          ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                 += ( eelem "head"
                      += ( eelem "title"
                           += txt siteName
                           += txt " - "
                           += getXPathTreesInDoc "/pageNotFound/@name/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 "body"
                      += ( eelem "div"
                           += sattr "class" "header"
                         )
                      += ( eelem "div"
                           += sattr "class" "center"
                           += ( eelem "div"
                                += sattr "class" "title"
                                += constL pageTitle
                              )
                           += ( eelem "div"
                                += sattr "class" "body"
                                += txt "404 Not Found (FIXME)" -- FIXME
                              )
                         )
                      += ( 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
                              )
                         )
                    )
               ) ) -<< pageNotFound


handlePut :: Environment -> PageName -> Resource ()
handlePut env name
    = runXmlA env "rakka-page-1.0.rng" $ proc tree
    -> returnA -< do setStatus Created