X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Rakka%2FStorage%2FDefaultPage.hs;h=f9b73f0ca9ee8083360462145bd598a93b4f27c1;hb=45bce2c29948649f74ada71f2fa851bdb812e96c;hp=bba22798d4597a15442ecf762517169d140ca76f;hpb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;p=Rakka.git

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index bba2279..f9b73f0 100644
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,46 +1,82 @@
+{-# LANGUAGE
+    Arrows
+  , DoAndIfThenElse
+  , UnicodeSyntax
+  #-}
 module Rakka.Storage.DefaultPage
     ( findAllDefaultPages
+    , getDefaultDirContents
     , loadDefaultPage
     )
     where
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Monad.Unicode
+import Data.Set (Set)
+import qualified Data.Set  as S
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX
+import Paths_Rakka
+import Prelude.Unicode
+import Rakka.Page
+import System.Directory
+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.XmlState
 
-import           Control.Arrow
-import           Control.Arrow.ArrowIO
-import           Control.Arrow.ArrowList
-import           Data.Set (Set)
-import qualified Data.Set as S
-import           Data.Time.Clock.POSIX
-import           Paths_Rakka -- Cabal が用意する。
-import           Rakka.Page
-import           System.Directory
-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
-
-
-doesLocalDirExist :: IO Bool
+doesLocalDirExist ∷ IO Bool
 doesLocalDirExist = doesDirectoryExist "defaultPages"
 
-
-findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages ∷ IO (Set PageName)
 findAllDefaultPages
+    -- If ./defaultPages exists, find pages in it. Otherwise find
+    -- defaultPages using Cabal's Paths_Rakka.
+    = do localDirExists ← doesLocalDirExist
+         if localDirExists then
+             findAllIn "defaultPages"
+         else
+             -- FIXME: This usage of getDataFileName is undocumented.
+             findAllIn =≪ getDataFileName "defaultPages"
+    where
+      findAllIn ∷ FilePath → IO (Set PageName)
+      findAllIn dirPath
+          = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>))
+            <$>
+            find always (fileType ==? RegularFile) dirPath
+
+getDefaultDirContents :: PageName -> IO (Set PageName)
+getDefaultDirContents dir
     -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
     -- defaultPages を探す。
     = do localDirExists <- doesLocalDirExist
          if localDirExists then
-             findAllIn "defaultPages"
+             getDir' "defaultPages"
            else
              -- FIXME: この getDataFileName の使ひ方は undocumented
-             findAllIn =<< getDataFileName "defaultPages"
+             getDir' =<< getDataFileName "defaultPages"
     where
-      findAllIn :: FilePath -> IO (Set PageName)
-      findAllIn dirPath
-          = find always (fileType ==? RegularFile) dirPath
-            >>=
-            return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
+      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 = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension
+
+      f :: FilePath -> Bool
+      f "."  = False
+      f ".." = False
+      f _    = True
 
 
 loadDefaultPage :: PageName -> IO (Maybe Page)
@@ -74,29 +110,25 @@ loadPageFile name path
                         )
          return page
 
-
-loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
+loadPageFileA ∷ IOStateArrow s (PageName, FilePath) Page
 loadPageFileA
-    = proc (name, fpath) ->
-      do tree    <- readFromDocument [ (a_validate         , v_0)
-                                     , (a_check_namespaces , v_1)
-                                     , (a_remove_whitespace, v_1)
-                                     ] -< fpath
-         lastMod <- arrIO (\ x -> getFileStatus x
-                                  >>=
-                                  return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
-                    -< fpath
-         page    <- parseXmlizedPage -< (name, tree)
-
-         case page of
-           Redirection _ _ _ _ _
-               -> returnA -< page {
-                     redirRevision = 0
-                   , redirLastMod  = lastMod
-                   }
-
-           Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
-               -> returnA -< page {
-                     entityRevision = 0
-                   , entityLastMod  = lastMod
-                   }
+    = proc (name, fpath) →
+      do tree    ← readFromDocument [ withValidate        no
+                                    , withCheckNamespaces yes
+                                    , withRemoveWS        yes
+                                    ] ⤙ fpath
+         lastMod ← arrIO ( \x → getFileStatus x
+                                ≫=
+                                pure ∘ posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime
+                         ) ⤙ fpath
+         page    ← parseXmlizedPage ⤙ (name, tree)
+         if isEntity page then
+             returnA ⤙ page {
+                         entityRevision = 0
+                       , entityLastMod  = lastMod
+                       }
+           else
+             returnA ⤙ page {
+                         redirRevision = 0
+                       , redirLastMod  = lastMod
+                       }