)
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
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
loadPageFile :: PageName -> FilePath -> IO Page
loadPageFile name path
- = do [page] <- runX ( constA (name, path)
+ = do [page] <- runX ( setErrorMsgHandler False fail
+ >>>
+ constA (name, path)
>>>
loadPageFileA
)
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()"
&&&
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