X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=de1e3a1321029aa3dcd19b7a72dd373f53651068;hb=02cf9c5f184e1ee977479fa43cadce79f8f93d09;hp=5362cc7d33771cd3a8c5ec89c6760a7c6ebe61cf;hpb=885faf1cabc3f79c90e1885268e2a9138b1ddefb;p=Rakka.git

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 5362cc7..de1e3a1 100644
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,20 +1,27 @@
 module Rakka.Storage.DefaultPage
-    ( loadDefaultPage
+    ( findAllDefaultPages
+    , loadDefaultPage
     )
     where
 
 import qualified Codec.Binary.Base64 as B64
+import           Codec.Binary.UTF8.String
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
 import qualified Data.ByteString.Lazy as L
-import           Data.Encoding
-import           Data.Encoding.UTF8
+import qualified Data.Map as M
+import           Data.Set (Set)
+import qualified Data.Set as S
+import           Data.Time
+import           Data.Time.Clock.POSIX
 import           Paths_Rakka -- Cabal が用意する。
 import           Rakka.Page
 import           Rakka.Utils
 import           System.Directory
-import           System.Time
+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
@@ -23,20 +30,47 @@ 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)
+
+
 loadDefaultPage :: PageName -> IO (Maybe Page)
-loadDefaultPage pageName
-    -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
-    = do let pagePath = "defaultPages/" ++ encodePageName pageName
-         isInDataDir <- doesFileExist pagePath
-         if isInDataDir then
-             return . Just =<< loadPageFile pageName pagePath
+loadDefaultPage name
+    -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
+    -- ければ Cabal で defaultPages/Foo.xml を探す。
+    = do let pagePath = "defaultPages" </> (encodePageName name `addExtension` "xml")
+
+         localDirExists <- doesLocalDirExist
+         if localDirExists then
+             tryLoad pagePath
            else
-             do fpath       <- getDataFileName 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
@@ -57,11 +91,14 @@ loadPageFileA
                                      , (a_check_namespaces , v_1)
                                      , (a_remove_whitespace, v_1)
                                      ] -< fpath
-         lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
+         lastMod <- arrIO (\ x -> getFileStatus x
+                                  >>=
+                                  return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
+                    -< fpath
          parsePage -< (name, lastMod, tree)
 
 
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
 parsePage 
     = proc (name, lastMod, tree)
     -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
@@ -75,23 +112,22 @@ parsePage
                                          })
             
 
-parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
 parseEntity
     = proc (name, lastMod, tree)
     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
                        >>> arr read) -< tree
 
-          isTheme  <- (maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText)
-                       >>> defaultTo "no"
+          lang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
+          fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
+
+          isTheme  <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
-          isFeed   <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
-                       >>> defaultTo "no"
+          isFeed   <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
-          isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
-                       >>> defaultTo "no"
+          isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
-          isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
-                       >>> defaultTo "no"
+          isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
                        >>> parseYesOrNo) -< tree
 
           summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
@@ -109,20 +145,23 @@ parseEntity
 
           let (isBinary, content)
                   = case (textData, binaryData) of
-                      (Just text, _          ) -> (False, encodeLazy UTF8 text      )
-                      (_        , Just binary) -> (True , L.pack $ B64.decode binary)
+                      (Just text, Nothing    ) -> (False, L.pack $ encode text      )
+                      (Nothing  , Just binary) -> (True , L.pack $ B64.decode binary)
+                      _                        -> error "one of textData or binaryData is required"
 
           returnA -< Entity {
                         pageName      = name
                       , pageType      = mimeType
+                      , pageLanguage  = lang
+                      , pageFileName  = fileName
                       , pageIsTheme   = isTheme
                       , pageIsFeed    = isFeed
                       , pageIsLocked  = isLocked
                       , pageIsBoring  = isBoring
                       , pageIsBinary  = isBinary
-                      , pageRevision  = Nothing
+                      , pageRevision  = 0
                       , pageLastMod   = lastMod
                       , pageSummary   = summary
-                      , pageOtherLang = otherLang
+                      , pageOtherLang = M.fromList otherLang
                       , pageContent   = content
                       }
\ No newline at end of file