module Rakka.Storage.DefaultPage
    ( loadDefaultPage
    )
    where

import qualified Codec.Binary.Base64 as B64
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
import           Data.Encoding
import           Data.Encoding.UTF8
import           Paths_Rakka -- Cabal が用意する。
import           Rakka.Page
import           Rakka.Utils
import           System.Directory
import           System.Time
import           Text.XML.HXT.Arrow.ReadDocument
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlIOStateArrow
import           Text.XML.HXT.Arrow.XmlNodeSet
import           Text.XML.HXT.DOM.TypeDefs
import           Text.XML.HXT.DOM.XmlKeywords


loadDefaultPage :: PageName -> IO (Maybe Page)
loadDefaultPage pageName
    -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
    = do let pagePath = "defaultPages/" ++ encodePageName pageName
         isInDataDir <- doesFileExist pagePath
         if isInDataDir then
             return . Just =<< loadPageFile pageName pagePath
           else
             do fpath       <- getDataFileName pagePath
                isInstalled <- doesFileExist fpath
                if isInstalled then
                    return . Just =<< loadPageFile pageName fpath
                  else
                    return Nothing


loadPageFile :: PageName -> FilePath -> IO Page
loadPageFile name path
    = do [page] <- runX ( setErrorMsgHandler False fail
                          >>>
                          constA (name, path)
                          >>>
                          loadPageFileA
                        )
         return page


loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
loadPageFileA
    = proc (name, fpath) ->
      do tree    <- readFromDocument [ (a_validate         , v_0)
                                     , (a_check_namespaces , v_1)
                                     , (a_remove_whitespace, v_1)
                                     ] -< fpath
         lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
         parsePage -< (name, lastMod, tree)


parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
parsePage 
    = proc (name, lastMod, tree)
    -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
          case redirect of
            Nothing   -> parseEntity -< (name, lastMod, tree)
            Just dest -> returnA     -< (Redirection {
                                           redirName     = name
                                         , redirDest     = dest
                                         , redirRevision = Nothing
                                         , redirLastMod  = lastMod
                                         })
            

parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
parseEntity
    = proc (name, lastMod, tree)
    -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
                       >>> arr read) -< tree

          isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
                       >>> parseYesOrNo) -< tree
          isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
                       >>> parseYesOrNo) -< tree
          isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
                       >>> parseYesOrNo) -< tree
          isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
                       >>> parseYesOrNo) -< tree

          summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
                              >>> getText
                              >>> deleteIfEmpty)) -< tree
                      
          otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
                              >>>
                              (getAttrValue0 "lang"
                               &&&
                               getAttrValue0 "page")) -< tree

          textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
          binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree

          let (isBinary, content)
                  = case (textData, binaryData) of
                      (Just text, _          ) -> (False, encodeLazy UTF8 text      )
                      (_        , Just binary) -> (True , L.pack $ B64.decode binary)

          returnA -< Entity {
                        pageName      = name
                      , pageType      = mimeType
                      , pageIsTheme   = isTheme
                      , pageIsFeed    = isFeed
                      , pageIsLocked  = isLocked
                      , pageIsBoring  = isBoring
                      , pageIsBinary  = isBinary
                      , pageRevision  = Nothing
                      , pageLastMod   = lastMod
                      , pageSummary   = summary
                      , pageOtherLang = otherLang
                      , pageContent   = content
                      }