1 module Rakka.Page.Loader.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 ("./data/" ++ pagePath)
30 do fpath <- getDataFileName ("defaultPages/" ++ pagePath)
31 isInstalled <- doesFileExist fpath
33 return . Just =<< loadPageFile fpath
38 loadPageFile :: FilePath -> IO Page
40 = do [page] <- runX ( constA path
47 loadPageFileA :: IOStateArrow s FilePath Page
48 loadPageFileA = ( readFromDocument [ (a_validate , v_0)
49 , (a_check_namespaces , v_1)
50 , (a_remove_whitespace, v_1)
57 parsePage :: (ArrowXml a, ArrowChoice a) => a XmlTree Page
59 = proc tree -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
62 isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
64 >>> parseYesOrNo) -< tree
65 isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
67 >>> parseYesOrNo) -< tree
68 isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
70 >>> parseYesOrNo) -< tree
71 isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
73 >>> parseYesOrNo) -< tree
75 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
77 >>> deleteIfEmpty)) -< tree
79 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
83 getAttrValue0 "page")) -< tree
85 textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree
86 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
88 let content = case (textData, binaryData) of
89 (Just text, _ ) -> L8.pack text
90 (_ , Just binary) -> L8.pack $ B64.decode binary
94 , pageIsTheme = isTheme
96 , pageIsLocked = isLocked
97 , pageIsBoring = isBoring
98 , pageSummary = summary
99 , pageOtherLang = otherLang
100 , pageContent = content