module Rakka.Resource.Render
    ( fallbackRender
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import           Data.Char
import           Network.HTTP.Lucu
import           Network.HTTP.Lucu.Utils
import           Network.URI
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           System.Time
import           Text.XML.HXT.Arrow.Namespace
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlNodeSet
import           Text.XML.HXT.DOM.TypeDefs


fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
fallbackRender env path
    | null path                        = return Nothing
    | null $ head path                 = return Nothing
    | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
    | otherwise
        = return $ Just $ ResourceDef {
            resUsesNativeThread = False
          , resIsGreedy         = True
          , resGet              = Just $ handleGet env (toPageName path)
          , resHead             = Nothing
          , resPost             = Nothing
          , resPut              = Nothing
          , 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
          case pageM of
            Nothing
                -> returnA -< foundNoEntity Nothing

            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) (BaseURI undefined) -< ()
          returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME


{-
  <page site="CieloNegro"
        styleSheet="http://example.org/object/StyleSheet/Default"
        name="Foo/Bar"
        type="text/x-rakka"
        isTheme="no"        -- text/css の場合のみ存在
        isFeed="no"         -- text/x-rakka の場合のみ存在
        isLocked="no"
        revision="112">     -- デフォルトでない場合のみ存在
        lastModified="2000-01-01T00:00:00" />

    <summary>
        blah blah...
    </summary> -- 存在しない場合もある

    <otherLang> -- 存在しない場合もある
      <link lang="ja" page="Bar/Baz" />
    </otherLang>

    <content>
      blah blah...
    </content>
  </page>
-}
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
    = let sysConf = envSysConf env
      in
        proc page
          -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
                BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
                StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()

                tree <- ( eelem "/"
                          += ( eelem "page"
                               += sattr "site"       siteName
                               += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
                               += sattr "name"       (pageName page)
                               += sattr "type"       (show $ pageType page)
                               += ( case pageType page of
                                      MIMEType "text" "css" _
                                          -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
                                      _   -> none
                                  )
                               += ( case pageType page of
                                      MIMEType "text" "x-rakka" _
                                          -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
                                      _   -> none
                                  )
                               += sattr "isLocked" (yesOrNo $ pageIsLocked page)
                               += ( case pageRevision page of
                                      Nothing  -> none
                                      Just rev -> sattr "revision" (show rev)
                                  )
                               += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)

                               += ( case pageSummary page of
                                      Nothing -> none
                                      Just s  -> eelem "summary" += txt s
                                  )

                               += ( case pageOtherLang page of
                                      [] -> none
                                      xs -> selem "otherLang"
                                            [ eelem "link"
                                              += sattr "lang" lang
                                              += sattr "page" page
                                                  | (lang, page) <- xs ]
                                  )
                               += ( eelem "content"
                                    += (constA page >>> formatPage env )
                                  )
                               >>>
                               uniqueNamespacesFromDeclAndQNames
                             )
                        ) -<< ()

                returnA -< do let lastMod = toClockTime $ pageLastMod page

                              case pageRevision page of
                                Nothing  -> foundTimeStamp lastMod
                                Just rev -> foundEntity (strongETag $ show rev) lastMod

                              outputXmlPage tree entityToXHTML


entityToXHTML :: ArrowXml a => a XmlTree XmlTree
entityToXHTML
    = eelem "/"
      += ( eelem "html"
           += sattr "xmlns" "http://www.w3.org/1999/xhtml"
           += ( eelem "head"
                += ( eelem "title"
                     += getXPathTreesInDoc "/page/@site/text()"
                     += txt " - "
                     += getXPathTreesInDoc "/page/@name/text()"
                   )
                += ( eelem "link"
                     += sattr "rel"  "stylesheet"
                     += sattr "type" "text/css"
                     += attr "href"
                            ( getXPathTreesInDoc "/page/@styleSheet/text()" )
                   )
              )
           += ( eelem "body"
                += ( eelem "div"
                     += sattr "class" "header"
                   )
                += ( eelem "div"
                     += sattr "class" "center"
                     += ( eelem "div"
                          += sattr "class" "title"
                        )
                     += ( eelem "div"
                          += sattr "class" "body"
                          += getXPathTreesInDoc "/page/content/*"
                        )
                   )
                += ( eelem "div"
                     += sattr "class" "footer"
                   )
                += ( eelem "div"
                     += sattr "class" "left side-bar"
                     += ( eelem "div"
                          += sattr "class" "content"
                        )
                   )
                += ( eelem "div"
                     += sattr "class" "right side-bar"
                     += ( eelem "div"
                          += sattr "class" "content"
                        )
                   )
              )
           >>>
           uniqueNamespacesFromDeclAndQNames
         )