Rakka/Storage/DefaultPage.hs

   1 module Rakka.Storage.DefaultPage
   2     ( findAllDefaultPages
   3     , loadDefaultPage
   4     )
   5     where
   6
   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.Arrow.XmlIOStateArrow
  21 import           Text.XML.HXT.DOM.XmlKeywords
  22
  23
  24 doesLocalDirExist :: IO Bool
  25 doesLocalDirExist = doesDirectoryExist "defaultPages"
  26
  27
  28 findAllDefaultPages :: IO (Set PageName)
  29 findAllDefaultPages
  30     -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
  31     -- defaultPages を探す。
  32     = do localDirExists <- doesLocalDirExist
  33          if localDirExists then
  34              findAllIn "defaultPages"
  35            else
  36              -- FIXME: この getDataFileName の使ひ方は undocumented
  37              findAllIn =<< getDataFileName "defaultPages"
  38     where
  39       findAllIn :: FilePath -> IO (Set PageName)
  40       findAllIn dirPath
  41           = find always (fileType ==? RegularFile) dirPath
  42             >>=
  43             return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
  44
  45
  46 loadDefaultPage :: PageName -> IO (Maybe Page)
  47 loadDefaultPage name
  48     -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
  49     -- ければ Cabal で defaultPages/Foo.xml を探す。
  50     = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
  51
  52          localDirExists <- doesLocalDirExist
  53          if localDirExists then
  54              tryLoad pagePath
  55            else
  56              tryLoad =<< getDataFileName pagePath
  57     where
  58       tryLoad :: FilePath -> IO (Maybe Page)
  59       tryLoad fpath
  60           = do exists <- doesFileExist fpath
  61                if exists then
  62                    return . Just =<< loadPageFile name fpath
  63                  else
  64                    return Nothing
  65
  66
  67 loadPageFile :: PageName -> FilePath -> IO Page
  68 loadPageFile name path
  69     = do [page] <- runX ( setErrorMsgHandler False fail
  70                           >>>
  71                           constA (name, path)
  72                           >>>
  73                           loadPageFileA
  74                         )
  75          return page
  76
  77
  78 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
  79 loadPageFileA
  80     = proc (name, fpath) ->
  81       do tree    <- readFromDocument [ (a_validate         , v_0)
  82                                      , (a_check_namespaces , v_1)
  83                                      , (a_remove_whitespace, v_1)
  84                                      ] -< fpath
  85          lastMod <- arrIO (\ x -> getFileStatus x
  86                                   >>=
  87                                   return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
  88                     -< fpath
  89          page    <- parseXmlizedPage -< (name, tree)
  90
  91          if isEntity page then
  92              returnA -< page {
  93                            entityRevision = 0
  94                          , entityLastMod  = lastMod
  95                          }
  96            else
  97              returnA -< page {
  98                            redirRevision = 0
  99                          , redirLastMod  = lastMod
 100                          }