X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=00fdf06dd9e8557f778d46e727a738823ef16d5e;hb=8a7556db44cd91ac0bb52279472bcc2abaa3f18e;hp=8770ef05264a2f18ece8047b0f1b4861da9967d7;hpb=484e15845d9c06d0fa62044d3b6b3ff8c78a6e04;p=Rakka.git

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 8770ef0..00fdf06 100644
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -3,14 +3,18 @@ module Rakka.Storage.DefaultPage
     )
     where
 
-import qualified Codec.Binary.Base64.String as B64
+import qualified Codec.Binary.Base64 as B64
 import           Control.Arrow
+import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
-import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy as L
+import           Data.Encoding
+import           Data.Encoding.UTF8
 import           Paths_Rakka -- Cabal が用意する。
 import           Rakka.Page
 import           Rakka.Utils
 import           System.Directory
+import           System.Time
 import           Text.XML.HXT.Arrow.ReadDocument
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.XmlIOStateArrow
@@ -21,13 +25,13 @@ import           Text.XML.HXT.DOM.XmlKeywords
 
 loadDefaultPage :: PageName -> IO (Maybe Page)
 loadDefaultPage pageName
-    -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
-    = do let pagePath = encodePageName pageName
-         isInDataDir <- doesFileExist ("./data/" ++ pagePath)
+    -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
+    = do let pagePath = "defaultPages/" ++ encodePageName pageName
+         isInDataDir <- doesFileExist pagePath
          if isInDataDir then
-             return . Just =<< loadPageFile pageName ("./data/" ++ pagePath)
+             return . Just =<< loadPageFile pageName pagePath
            else
-             do fpath       <- getDataFileName ("defaultPages/" ++ pagePath)
+             do fpath       <- getDataFileName pagePath
                 isInstalled <- doesFileExist fpath
                 if isInstalled then
                     return . Just =<< loadPageFile pageName fpath
@@ -37,7 +41,9 @@ loadDefaultPage pageName
 
 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,30 +53,41 @@ 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)
+      do tree    <- readFromDocument [ (a_validate         , v_0)
+                                     , (a_check_namespaces , v_1)
+                                     , (a_remove_whitespace, v_1)
+                                     ] -< fpath
+         lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
+         parsePage -< (name, lastMod, tree)
+
 
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parsePage 
+    = proc (name, lastMod, tree)
+    -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
+          case redirect of
+            Nothing   -> parseEntity -< (name, lastMod, tree)
+            Just dest -> returnA     -< (Redirection {
+                                           redirName     = name
+                                         , redirDest     = dest
+                                         , redirRevision = Nothing
+                                         , redirLastMod  = lastMod
+                                         })
+            
 
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
-parsePage
-    = proc (name, tree)
+parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parseEntity
+    = proc (name, lastMod, tree)
     -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
                        >>> arr read) -< tree
 
-          isTheme  <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
-                       >>> defaultTo "no"
+          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()"
@@ -83,21 +100,24 @@ parsePage
                                &&&
                                getAttrValue0 "page")) -< tree
 
-          textData   <- maybeA (getXPathTreesInDoc "/page/textData"   >>> getText) -< tree
-          binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
+          textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
+          binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 
-          let content = case (textData, binaryData) of
-                          (Just text, _          ) -> L8.pack text
-                          (_        , Just binary) -> L8.pack $ B64.decode binary
+          let (isBinary, content)
+                  = case (textData, binaryData) of
+                      (Just text, _          ) -> (False, encodeLazy UTF8 text      )
+                      (_        , Just binary) -> (True , L.pack $ B64.decode binary)
 
-          returnA -< Page {
+          returnA -< Entity {
                         pageName      = name
                       , pageType      = mimeType
                       , pageIsTheme   = isTheme
                       , pageIsFeed    = isFeed
                       , pageIsLocked  = isLocked
                       , pageIsBoring  = isBoring
+                      , pageIsBinary  = isBinary
                       , pageRevision  = Nothing
+                      , pageLastMod   = lastMod
                       , pageSummary   = summary
                       , pageOtherLang = otherLang
                       , pageContent   = content