1 module Rakka.Storage.DefaultPage
6 import qualified Codec.Binary.Base64.String as B64
8 import Control.Arrow.ArrowList
9 import qualified Data.ByteString.Lazy.Char8 as L8
10 import Paths_Rakka -- Cabal が用意する。
13 import System.Directory
14 import Text.XML.HXT.Arrow.ReadDocument
15 import Text.XML.HXT.Arrow.XmlArrow
16 import Text.XML.HXT.Arrow.XmlIOStateArrow
17 import Text.XML.HXT.Arrow.XmlNodeSet
18 import Text.XML.HXT.DOM.TypeDefs
19 import Text.XML.HXT.DOM.XmlKeywords
22 loadDefaultPage :: PageName -> IO (Maybe Page)
23 loadDefaultPage pageName
24 -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
25 = do let pagePath = encodePageName pageName
26 isInDataDir <- doesFileExist ("./data/" ++ pagePath)
28 return . Just =<< loadPageFile pageName ("./data/" ++ pagePath)
30 do fpath <- getDataFileName ("defaultPages/" ++ pagePath)
31 isInstalled <- doesFileExist fpath
33 return . Just =<< loadPageFile pageName fpath
38 loadPageFile :: PageName -> FilePath -> IO Page
39 loadPageFile name path
40 = do [page] <- runX ( constA (name, path)
47 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
49 = proc (name, fpath) ->
50 do tree <- readFromDocument [ (a_validate , v_0)
51 , (a_check_namespaces , v_1)
52 , (a_remove_whitespace, v_1)
54 parsePage -< (name, tree)
57 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
60 -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
63 isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
65 >>> parseYesOrNo) -< tree
66 isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
68 >>> parseYesOrNo) -< tree
69 isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
71 >>> parseYesOrNo) -< tree
72 isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
74 >>> parseYesOrNo) -< tree
76 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
78 >>> deleteIfEmpty)) -< tree
80 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
84 getAttrValue0 "page")) -< tree
86 textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree
87 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
89 let content = case (textData, binaryData) of
90 (Just text, _ ) -> L8.pack text
91 (_ , Just binary) -> L8.pack $ B64.decode binary
96 , pageIsTheme = isTheme
98 , pageIsLocked = isLocked
99 , pageIsBoring = isBoring
100 , pageRevision = Nothing
101 , pageSummary = summary
102 , pageOtherLang = otherLang
103 , pageContent = content