module Rakka.Storage.DefaultPage
    ( findAllDefaultPages
    , loadDefaultPage
    )
    where

import qualified Codec.Binary.Base64 as B64
import           Codec.Binary.UTF8.String
import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.Time
import           Data.Time.Clock.POSIX
import           Paths_Rakka -- Cabal が用意する。
import           Rakka.Page
import           Rakka.Utils
import           System.Directory
import           System.FilePath
import           System.FilePath.Find hiding (fileName, modificationTime)
import           System.Posix.Files
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


doesLocalDirExist :: IO Bool
doesLocalDirExist = doesDirectoryExist "defaultPages"


findAllDefaultPages :: IO (Set PageName)
findAllDefaultPages
    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
    -- defaultPages を探す。
    = do localDirExists <- doesLocalDirExist
         if localDirExists then
             findAllIn "defaultPages"
           else
             -- FIXME: この getDataFileName の使ひ方は undocumented
             findAllIn =<< getDataFileName "defaultPages"
    where
      findAllIn :: FilePath -> IO (Set PageName)
      findAllIn dirPath
          = find always (fileType ==? RegularFile) dirPath
            >>=
            return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)


loadDefaultPage :: PageName -> IO (Maybe Page)
loadDefaultPage name
    -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
    -- ければ Cabal で defaultPages/Foo.xml を探す。
    = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"

         localDirExists <- doesLocalDirExist
         if localDirExists then
             tryLoad pagePath
           else
             tryLoad =<< getDataFileName pagePath
    where
      tryLoad :: FilePath -> IO (Maybe Page)
      tryLoad fpath
          = do exists <- doesFileExist fpath
               if exists then
                   return . Just =<< loadPageFile name 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 -> getFileStatus x
                                  >>=
                                  return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
                    -< fpath
         parsePage -< (name, lastMod, tree)


parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, 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, UTCTime, XmlTree) Page
parseEntity
    = proc (name, lastMod, tree)
    -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
                       >>> arr read) -< tree

          lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
          fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< 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, Nothing    ) -> (False, L.pack $ encode text      )
                      (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
                      _                        -> error "one of textData or binaryData is required"

          returnA -< Entity {
                        pageName      = name
                      , pageType      = mimeType
                      , pageLanguage  = lang
                      , pageFileName  = fileName
                      , pageIsTheme   = isTheme
                      , pageIsFeed    = isFeed
                      , pageIsLocked  = isLocked
                      , pageIsBoring  = isBoring
                      , pageIsBinary  = isBinary
                      , pageRevision  = 0
                      , pageLastMod   = lastMod
                      , pageSummary   = summary
                      , pageOtherLang = M.fromList otherLang
                      , pageContent   = content
                      }