{-# LANGUAGE
    Arrows
  , DoAndIfThenElse
  , UnicodeSyntax
  #-}
module Rakka.Storage.DefaultPage
    ( findAllDefaultPages
    , getDefaultDirContents
    , loadDefaultPage
    )
    where
import Control.Applicative
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Control.Monad.Unicode
import Data.Set (Set)
import qualified Data.Set  as S
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import Paths_Rakka
import Prelude.Unicode
import Rakka.Page
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.XmlState

doesLocalDirExist ∷ IO Bool
doesLocalDirExist = doesDirectoryExist "defaultPages"

findAllDefaultPages ∷ IO (Set PageName)
findAllDefaultPages
    -- If ./defaultPages exists, find pages in it. Otherwise find
    -- defaultPages using Cabal's Paths_Rakka.
    = do localDirExists ← doesLocalDirExist
         if localDirExists then
             findAllIn "defaultPages"
         else
             -- FIXME: This usage of getDataFileName is undocumented.
             findAllIn =≪ getDataFileName "defaultPages"
    where
      findAllIn ∷ FilePath → IO (Set PageName)
      findAllIn dirPath
          = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>))
            <$>
            find always (fileType ==? RegularFile) dirPath

getDefaultDirContents :: PageName -> IO (Set PageName)
getDefaultDirContents dir
    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
    -- defaultPages を探す。
    = do localDirExists <- doesLocalDirExist
         if localDirExists then
             getDir' "defaultPages"
           else
             -- FIXME: この getDataFileName の使ひ方は undocumented
             getDir' =<< getDataFileName "defaultPages"
    where
      getDir' :: FilePath -> IO (Set PageName)
      getDir' basePath
          = do let childDirPath = basePath </> encodePageName dir
               exists <- doesDirectoryExist childDirPath
               if exists then
                   getDirectoryContents childDirPath
                      >>=
                      return . S.fromList . map (m basePath) . filter f
                 else
                   return S.empty

      m ∷ FilePath → FilePath → PageName
      m basePath = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension

      f :: FilePath -> Bool
      f "."  = False
      f ".." = False
      f _    = True


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 [ withValidate        no
                                    , withCheckNamespaces yes
                                    , withRemoveWS        yes
                                    ] ⤙ fpath
         lastMod ← arrIO ( \x → getFileStatus x
                                ≫=
                                pure ∘ posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime
                         ) ⤙ fpath
         page    ← parseXmlizedPage ⤙ (name, tree)
         if isEntity page then
             returnA ⤙ page {
                         entityRevision = 0
                       , entityLastMod  = lastMod
                       }
           else
             returnA ⤙ page {
                         redirRevision = 0
                       , redirLastMod  = lastMod
                       }