Fixing build breakage...

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

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index bba22798d4597a15442ecf762517169d140ca76f..a6fbc10ddea89e3eeabba86d55c2532a82897e3c 100644 (file)
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,9 +1,9 @@
 module Rakka.Storage.DefaultPage
     ( findAllDefaultPages
+    , getDefaultDirContents
     , loadDefaultPage
     )
     where
-
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
@@ -17,7 +17,6 @@ import           System.FilePath
 import           System.FilePath.Find hiding (fileName, modificationTime)
 import           System.Posix.Files
 import           Text.XML.HXT.Arrow.ReadDocument
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
 import           Text.XML.HXT.DOM.XmlKeywords
 
 
@@ -43,6 +42,37 @@ findAllDefaultPages
             return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
 
 
+getDefaultDirContents :: PageName -> IO (Set PageName)
+getDefaultDirContents dir
+    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+    -- defaultPages を探す。
+    = do localDirExists <- doesLocalDirExist
+         if localDirExists then
+             getDir' "defaultPages"
+           else
+             -- FIXME: この getDataFileName の使ひ方は undocumented
+             getDir' =<< getDataFileName "defaultPages"
+    where
+      getDir' :: FilePath -> IO (Set PageName)
+      getDir' basePath
+          = do let childDirPath = basePath </> encodePageName dir
+               exists <- doesDirectoryExist childDirPath
+               if exists then
+                   getDirectoryContents childDirPath
+                      >>=
+                      return . S.fromList . map (m basePath) . filter f
+                 else
+                   return S.empty
+
+      m :: FilePath -> FilePath -> PageName
+      m basePath = (dir </>) . decodePageName . makeRelative basePath . dropExtension
+
+      f :: FilePath -> Bool
+      f "."  = False
+      f ".." = False
+      f _    = True
+
+
 loadDefaultPage :: PageName -> IO (Maybe Page)
 loadDefaultPage name
     -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
@@ -88,15 +118,13 @@ loadPageFileA
                     -< fpath
          page    <- parseXmlizedPage -< (name, tree)
 
-         case page of
-           Redirection _ _ _ _ _
-               -> returnA -< page {
-                     redirRevision = 0
-                   , redirLastMod  = lastMod
-                   }
-
-           Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
-               -> returnA -< page {
-                     entityRevision = 0
-                   , entityLastMod  = lastMod
-                   }
+         if isEntity page then
+             returnA -< page {
+                           entityRevision = 0
+                         , entityLastMod  = lastMod
+                         }
+           else
+             returnA -< page {
+                           redirRevision = 0
+                         , redirLastMod  = lastMod
+                         }