Rakka/Storage/DefaultPage.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , DoAndIfThenElse
   4   , UnicodeSyntax
   5   #-}
   6 module Rakka.Storage.DefaultPage
   7     ( findAllDefaultPages
   8     , getDefaultDirContents
   9     , loadDefaultPage
  10     )
  11     where
  12 import Control.Applicative
  13 import Control.Arrow
  14 import Control.Arrow.ArrowIO
  15 import Control.Arrow.ArrowList
  16 import Control.Monad.Unicode
  17 import Data.Set (Set)
  18 import qualified Data.Set  as S
  19 import qualified Data.Text as T
  20 import Data.Time.Clock.POSIX
  21 import Paths_Rakka
  22 import Prelude.Unicode
  23 import Rakka.Page
  24 import System.Directory
  25 import System.FilePath
  26 import System.FilePath.Find hiding (fileName, modificationTime)
  27 import System.Posix.Files
  28 import Text.XML.HXT.Arrow.ReadDocument
  29 import Text.XML.HXT.Arrow.XmlState
  30
  31 doesLocalDirExist ∷ IO Bool
  32 doesLocalDirExist = doesDirectoryExist "defaultPages"
  33
  34 findAllDefaultPages ∷ IO (Set PageName)
  35 findAllDefaultPages
  36     -- If ./defaultPages exists, find pages in it. Otherwise find
  37     -- defaultPages using Cabal's Paths_Rakka.
  38     = do localDirExists ← doesLocalDirExist
  39          if localDirExists then
  40              findAllIn "defaultPages"
  41          else
  42              -- FIXME: This usage of getDataFileName is undocumented.
  43              findAllIn =≪ getDataFileName "defaultPages"
  44     where
  45       findAllIn ∷ FilePath → IO (Set PageName)
  46       findAllIn dirPath
  47           = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>))
  48             <$>
  49             find always (fileType ==? RegularFile) dirPath
  50
  51 getDefaultDirContents :: PageName -> IO (Set PageName)
  52 getDefaultDirContents dir
  53     -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
  54     -- defaultPages を探す。
  55     = do localDirExists <- doesLocalDirExist
  56          if localDirExists then
  57              getDir' "defaultPages"
  58            else
  59              -- FIXME: この getDataFileName の使ひ方は undocumented
  60              getDir' =<< getDataFileName "defaultPages"
  61     where
  62       getDir' :: FilePath -> IO (Set PageName)
  63       getDir' basePath
  64           = do let childDirPath = basePath </> encodePageName dir
  65                exists <- doesDirectoryExist childDirPath
  66                if exists then
  67                    getDirectoryContents childDirPath
  68                       >>=
  69                       return . S.fromList . map (m basePath) . filter f
  70                  else
  71                    return S.empty
  72
  73       m ∷ FilePath → FilePath → PageName
  74       m basePath = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension
  75
  76       f :: FilePath -> Bool
  77       f "."  = False
  78       f ".." = False
  79       f _    = True
  80
  81
  82 loadDefaultPage :: PageName -> IO (Maybe Page)
  83 loadDefaultPage name
  84     -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
  85     -- ければ Cabal で defaultPages/Foo.xml を探す。
  86     = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
  87
  88          localDirExists <- doesLocalDirExist
  89          if localDirExists then
  90              tryLoad pagePath
  91            else
  92              tryLoad =<< getDataFileName pagePath
  93     where
  94       tryLoad :: FilePath -> IO (Maybe Page)
  95       tryLoad fpath
  96           = do exists <- doesFileExist fpath
  97                if exists then
  98                    return . Just =<< loadPageFile name fpath
  99                  else
 100                    return Nothing
 101
 102
 103 loadPageFile :: PageName -> FilePath -> IO Page
 104 loadPageFile name path
 105     = do [page] <- runX ( setErrorMsgHandler False fail
 106                           >>>
 107                           constA (name, path)
 108                           >>>
 109                           loadPageFileA
 110                         )
 111          return page
 112
 113 loadPageFileA ∷ IOStateArrow s (PageName, FilePath) Page
 114 loadPageFileA
 115     = proc (name, fpath) →
 116       do tree    ← readFromDocument [ withValidate        no
 117                                     , withCheckNamespaces yes
 118                                     , withRemoveWS        yes
 119                                     ] ⤙ fpath
 120          lastMod ← arrIO ( \x → getFileStatus x
 121                                 ≫=
 122                                 pure ∘ posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime
 123                          ) ⤙ fpath
 124          page    ← parseXmlizedPage ⤙ (name, tree)
 125          if isEntity page then
 126              returnA ⤙ page {
 127                          entityRevision = 0
 128                        , entityLastMod  = lastMod
 129                        }
 130            else
 131              returnA ⤙ page {
 132                          redirRevision = 0
 133                        , redirLastMod  = lastMod
 134                        }