X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=e6f51a55a284dbc8737b3274a00a5acf4501c08f;hb=49b4f4696b29862524792bcc610dd09aa93c187c;hp=8770ef05264a2f18ece8047b0f1b4861da9967d7;hpb=484e15845d9c06d0fa62044d3b6b3ff8c78a6e04;p=Rakka.git

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 8770ef0..e6f51a5 100644
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,43 +1,106 @@
 module Rakka.Storage.DefaultPage
-    ( loadDefaultPage
+    ( findAllDefaultPages
+    , getDefaultDirContents
+    , loadDefaultPage
     )
     where
 
-import qualified Codec.Binary.Base64.String as B64
 import           Control.Arrow
+import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
-import qualified Data.ByteString.Lazy.Char8 as L8
+import           Data.Set (Set)
+import qualified Data.Set as S
+import           Data.Time.Clock.POSIX
 import           Paths_Rakka -- Cabal が用意する。
 import           Rakka.Page
-import           Rakka.Utils
 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.XmlArrow
 import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.Arrow.XmlNodeSet
-import           Text.XML.HXT.DOM.TypeDefs
 import           Text.XML.HXT.DOM.XmlKeywords
 
 
+doesLocalDirExist :: IO Bool
+doesLocalDirExist = doesDirectoryExist "defaultPages"
+
+
+findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages
+    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+    -- defaultPages を探す。
+    = do localDirExists <- doesLocalDirExist
+         if localDirExists then
+             findAllIn "defaultPages"
+           else
+             -- FIXME: この getDataFileName の使ひ方は undocumented
+             findAllIn =<< getDataFileName "defaultPages"
+    where
+      findAllIn :: FilePath -> IO (Set PageName)
+      findAllIn dirPath
+          = find always (fileType ==? RegularFile) dirPath
+            >>=
+            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 pageName
-    -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
-    = do let pagePath = encodePageName pageName
-         isInDataDir <- doesFileExist ("./data/" ++ pagePath)
-         if isInDataDir then
-             return . Just =<< loadPageFile pageName ("./data/" ++ pagePath)
+loadDefaultPage name
+    -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
+    -- ければ Cabal で defaultPages/Foo.xml を探す。
+    = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
+
+         localDirExists <- doesLocalDirExist
+         if localDirExists then
+             tryLoad pagePath
            else
-             do fpath       <- getDataFileName ("defaultPages/" ++ pagePath)
-                isInstalled <- doesFileExist fpath
-                if isInstalled then
-                    return . Just =<< loadPageFile pageName fpath
-                  else
-                    return Nothing
+             tryLoad =<< getDataFileName pagePath
+    where
+      tryLoad :: FilePath -> IO (Maybe Page)
+      tryLoad fpath
+          = do exists <- doesFileExist fpath
+               if exists then
+                   return . Just =<< loadPageFile name fpath
+                 else
+                   return Nothing
 
 
 loadPageFile :: PageName -> FilePath -> IO Page
 loadPageFile name path
-    = do [page] <- runX ( constA (name, path)
+    = do [page] <- runX ( setErrorMsgHandler False fail
+                          >>>
+                          constA (name, path)
                           >>>
                           loadPageFileA
                         )
@@ -47,58 +110,23 @@ loadPageFile name path
 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
-         parsePage -< (name, tree)
-
-
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
-parsePage
-    = proc (name, tree)
-    -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
-                       >>> arr read) -< tree
-
-          isTheme  <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
-                       >>> defaultTo "no"
-                       >>> parseYesOrNo) -< tree
-          isFeed   <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
-                       >>> defaultTo "no"
-                       >>> parseYesOrNo) -< tree
-          isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
-                       >>> defaultTo "no"
-                       >>> parseYesOrNo) -< tree
-          isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
-                       >>> defaultTo "no"
-                       >>> parseYesOrNo) -< tree
-
-          summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
-                              >>> getText
-                              >>> deleteIfEmpty)) -< tree
-                      
-          otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
-                              >>>
-                              (getAttrValue0 "lang"
-                               &&&
-                               getAttrValue0 "page")) -< tree
-
-          textData   <- maybeA (getXPathTreesInDoc "/page/textData"   >>> getText) -< tree
-          binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
-
-          let content = case (textData, binaryData) of
-                          (Just text, _          ) -> L8.pack text
-                          (_        , Just binary) -> L8.pack $ B64.decode binary
-
-          returnA -< Page {
-                        pageName      = name
-                      , pageType      = mimeType
-                      , pageIsTheme   = isTheme
-                      , pageIsFeed    = isFeed
-                      , pageIsLocked  = isLocked
-                      , pageIsBoring  = isBoring
-                      , pageRevision  = Nothing
-                      , pageSummary   = summary
-                      , pageOtherLang = otherLang
-                      , pageContent   = content
-                      }
\ No newline at end of file
+      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)
+
+         if isEntity page then
+             returnA -< page {
+                           entityRevision = 0
+                         , entityLastMod  = lastMod
+                         }
+           else
+             returnA -< page {
+                           redirRevision = 0
+                         , redirLastMod  = lastMod
+                         }