Bugfix

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

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 06b40361908ff39e1f2bf20b028d3a16fa0e8fe6..e6f51a55a284dbc8737b3274a00a5acf4501c08f 100644 (file)
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,5 +1,6 @@
 module Rakka.Storage.DefaultPage
     ( findAllDefaultPages
+    , getDefaultDirContents
     , loadDefaultPage
     )
     where
@@ -43,6 +44,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 を探す。無