Rakka/Storage/DefaultPage.hs

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