Rakka/Storage/DefaultPage.hs

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