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' basePath
  60           = do let childDirPath = basePath </> encodePageName dir
  61                exists <- doesDirectoryExist childDirPath
  62                if exists then
  63                    getDirectoryContents childDirPath
  64                       >>=
  65                       return . S.fromList . map (m basePath) . filter f
  66                  else
  67                    return S.empty
  68
  69       m :: FilePath -> FilePath -> PageName
  70       m basePath = (dir </>) . decodePageName . makeRelative basePath . dropExtension
  71
  72       f :: FilePath -> Bool
  73       f "."  = False
  74       f ".." = False
  75       f _    = True
  76
  77
  78 loadDefaultPage :: PageName -> IO (Maybe Page)
  79 loadDefaultPage name
  80     -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
  81     -- ければ Cabal で defaultPages/Foo.xml を探す。
  82     = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
  83
  84          localDirExists <- doesLocalDirExist
  85          if localDirExists then
  86              tryLoad pagePath
  87            else
  88              tryLoad =<< getDataFileName pagePath
  89     where
  90       tryLoad :: FilePath -> IO (Maybe Page)
  91       tryLoad fpath
  92           = do exists <- doesFileExist fpath
  93                if exists then
  94                    return . Just =<< loadPageFile name fpath
  95                  else
  96                    return Nothing
  97
  98
  99 loadPageFile :: PageName -> FilePath -> IO Page
 100 loadPageFile name path
 101     = do [page] <- runX ( setErrorMsgHandler False fail
 102                           >>>
 103                           constA (name, path)
 104                           >>>
 105                           loadPageFileA
 106                         )
 107          return page
 108
 109
 110 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
 111 loadPageFileA
 112     = proc (name, fpath) ->
 113       do tree    <- readFromDocument [ (a_validate         , v_0)
 114                                      , (a_check_namespaces , v_1)
 115                                      , (a_remove_whitespace, v_1)
 116                                      ] -< fpath
 117          lastMod <- arrIO (\ x -> getFileStatus x
 118                                   >>=
 119                                   return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
 120                     -< fpath
 121          page    <- parseXmlizedPage -< (name, tree)
 122
 123          if isEntity page then
 124              returnA -< page {
 125                            entityRevision = 0
 126                          , entityLastMod  = lastMod
 127                          }
 128            else
 129              returnA -< page {
 130                            redirRevision = 0
 131                          , redirLastMod  = lastMod
 132                          }