6 module Rakka.Storage.DefaultPage
8 , getDefaultDirContents
12 import Control.Applicative
14 import Control.Arrow.ArrowIO
15 import Control.Arrow.ArrowList
16 import Control.Monad.Unicode
18 import qualified Data.Set as S
19 import qualified Data.Text as T
20 import Data.Time.Clock.POSIX
22 import Prelude.Unicode
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
31 doesLocalDirExist ∷ IO Bool
32 doesLocalDirExist = doesDirectoryExist "defaultPages"
34 findAllDefaultPages ∷ IO (Set PageName)
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"
42 -- FIXME: This usage of getDataFileName is undocumented.
43 findAllIn =≪ getDataFileName "defaultPages"
45 findAllIn ∷ FilePath → IO (Set PageName)
47 = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>))
49 find always (fileType ==? RegularFile) dirPath
51 getDefaultDirContents :: PageName -> IO (Set PageName)
52 getDefaultDirContents dir
53 -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
55 = do localDirExists <- doesLocalDirExist
56 if localDirExists then
57 getDir' "defaultPages"
59 -- FIXME: この getDataFileName の使ひ方は undocumented
60 getDir' =<< getDataFileName "defaultPages"
62 getDir' :: FilePath -> IO (Set PageName)
64 = do let childDirPath = basePath </> encodePageName dir
65 exists <- doesDirectoryExist childDirPath
67 getDirectoryContents childDirPath
69 return . S.fromList . map (m basePath) . filter f
73 m ∷ FilePath → FilePath → PageName
74 m basePath = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension
82 loadDefaultPage :: PageName -> IO (Maybe Page)
84 -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
85 -- ければ Cabal で defaultPages/Foo.xml を探す。
86 = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
88 localDirExists <- doesLocalDirExist
89 if localDirExists then
92 tryLoad =<< getDataFileName pagePath
94 tryLoad :: FilePath -> IO (Maybe Page)
96 = do exists <- doesFileExist fpath
98 return . Just =<< loadPageFile name fpath
103 loadPageFile :: PageName -> FilePath -> IO Page
104 loadPageFile name path
105 = do [page] <- runX ( setErrorMsgHandler False fail
113 loadPageFileA ∷ IOStateArrow s (PageName, FilePath) Page
115 = proc (name, fpath) →
116 do tree ← readFromDocument [ withValidate no
117 , withCheckNamespaces yes
120 lastMod ← arrIO ( \x → getFileStatus x
122 pure ∘ posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime
124 page ← parseXmlizedPage ⤙ (name, tree)
125 if isEntity page then
128 , entityLastMod = lastMod
133 , redirLastMod = lastMod