module Rakka.Storage.DefaultPage ( 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 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 import Text.XML.HXT.Arrow.XmlNodeSet import Text.XML.HXT.DOM.TypeDefs 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) if isInDataDir then return . Just =<< loadPageFile pageName ("./data/" ++ pagePath) else do fpath <- getDataFileName ("defaultPages/" ++ pagePath) isInstalled <- doesFileExist fpath if isInstalled then return . Just =<< loadPageFile pageName fpath else return Nothing loadPageFile :: PageName -> FilePath -> IO Page loadPageFile name path = do [page] <- runX ( setErrorMsgHandler False fail >>> constA (name, path) >>> loadPageFileA ) return page 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 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 }) 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" >>> 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 -< Entity { pageName = name , pageType = mimeType , pageIsTheme = isTheme , pageIsFeed = isFeed , pageIsLocked = isLocked , pageIsBoring = isBoring , pageRevision = Nothing , pageLastMod = lastMod , pageSummary = summary , pageOtherLang = otherLang , pageContent = content }