Implemented makeDraft and others

[Rakka.git] / Rakka / Storage / DefaultPage.hs

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 30b5fcf5f1c918d963052b57cd8db293adcf7bb8..b5648cf49b64c6c69b7d8cf2ba8b5b06b8313092 100644 (file)
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,5 +1,6 @@
 module Rakka.Storage.DefaultPage
-    ( loadDefaultPage
+    ( findAllDefaultPages
+    , loadDefaultPage
     )
     where
 
@@ -11,9 +12,13 @@ import qualified Data.ByteString.Lazy as L
 import           Data.Encoding
 import           Data.Encoding.UTF8
 import qualified Data.Map as M
+import           Data.Set (Set)
+import qualified Data.Set as S
 import           Paths_Rakka -- Cabal が用意する。
 import           Rakka.Page
 import           Rakka.Utils
+import           System.FilePath
+import           System.FilePath.Find
 import           System.Directory
 import           System.Time
 import           Text.XML.HXT.Arrow.ReadDocument
@@ -24,20 +29,47 @@ import           Text.XML.HXT.DOM.TypeDefs
 import           Text.XML.HXT.DOM.XmlKeywords
 
 
+doesLocalDirExist :: IO Bool
+doesLocalDirExist = doesDirectoryExist "defaultPages"
+
+
+findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages
+    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+    -- defaultPages を探す。
+    = do localDirExists <- doesLocalDirExist
+         if localDirExists then
+             findAllIn "defaultPages"
+           else
+             -- FIXME: この getDataFileName の使ひ方は undocumented
+             findAllIn =<< getDataFileName "defaultPages"
+    where
+      findAllIn :: FilePath -> IO (Set PageName)
+      findAllIn dirPath
+          = find always (fileType ==? RegularFile) dirPath
+            >>=
+            return . S.fromList . map (decodePageName . makeRelative dirPath)
+
+
 loadDefaultPage :: PageName -> IO (Maybe Page)
 loadDefaultPage pageName
-    -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
+    -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
+    -- ば Cabal で defaultPages/Foo を探す。
     = do let pagePath = "defaultPages/" ++ encodePageName pageName
-         isInDataDir <- doesFileExist pagePath
-         if isInDataDir then
-             return . Just =<< loadPageFile pageName pagePath
+
+         localDirExists <- doesLocalDirExist
+         if localDirExists then
+             tryLoad pagePath
            else
-             do fpath       <- getDataFileName pagePath
-                isInstalled <- doesFileExist fpath
-                if isInstalled then
-                    return . Just =<< loadPageFile pageName fpath
-                  else
-                    return Nothing
+             tryLoad =<< getDataFileName pagePath
+    where
+      tryLoad :: FilePath -> IO (Maybe Page)
+      tryLoad fpath
+          = do exists <- doesFileExist fpath
+               if exists then
+                   return . Just =<< loadPageFile pageName fpath
+                 else
+                   return Nothing
 
 
 loadPageFile :: PageName -> FilePath -> IO Page
@@ -120,7 +152,7 @@ parseEntity
                       , pageIsLocked  = isLocked
                       , pageIsBoring  = isBoring
                       , pageIsBinary  = isBinary
-                      , pageRevision  = Nothing
+                      , pageRevision  = 0
                       , pageLastMod   = lastMod
                       , pageSummary   = summary
                       , pageOtherLang = M.fromList otherLang