Exodus to GHC 6.8.1

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

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index 3e4e421b4a65d3a61f8daa8196154635cff58318..46fda3ac636b45032fc89a5419b09292427f238e 100644 (file)
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -5,22 +5,23 @@ module Rakka.Storage.DefaultPage
     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.FilePath
-import           System.FilePath.Find
 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
@@ -52,10 +53,10 @@ findAllDefaultPages
 
 
 loadDefaultPage :: PageName -> IO (Maybe Page)
-loadDefaultPage pageName
+loadDefaultPage name
     -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
     -- ば Cabal で defaultPages/Foo を探す。
-    = do let pagePath = "defaultPages/" ++ encodePageName pageName
+    = do let pagePath = "defaultPages/" ++ encodePageName name
 
          localDirExists <- doesLocalDirExist
          if localDirExists then
@@ -67,7 +68,7 @@ loadDefaultPage pageName
       tryLoad fpath
           = do exists <- doesFileExist fpath
                if exists then
-                   return . Just =<< loadPageFile pageName fpath
+                   return . Just =<< loadPageFile name fpath
                  else
                    return Nothing
 
@@ -90,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
@@ -108,7 +112,7 @@ 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
@@ -141,8 +145,9 @@ 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