implemented page listing

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

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 06b40361908ff39e1f2bf20b028d3a16fa0e8fe6..c8efd4c800a0a09f3bb9887ba2df82c88614715c 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,32 @@ 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' dirPath
+          = getDirectoryContents (dirPath </> encodePageName dir)
+            >>=
+            return . S.fromList . map (m dirPath) . filter f
+
+      m :: FilePath -> FilePath -> PageName
+      m dirPath = (dir </>) . decodePageName . makeRelative dirPath . dropExtension
+
+      f :: FilePath -> Bool
+      f "."  = False
+      f ".." = False
+      f _    = True
+
+
 loadDefaultPage :: PageName -> IO (Maybe Page)
 loadDefaultPage name
     -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無