Fixing build breakage...

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

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 06b40361908ff39e1f2bf20b028d3a16fa0e8fe6..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 を探す。無