1 module Rakka.Storage.DefaultPage
6 import qualified Codec.Binary.Base64 as B64
8 import Control.Arrow.ArrowIO
9 import Control.Arrow.ArrowList
10 import qualified Data.ByteString.Lazy as L
12 import Data.Encoding.UTF8
13 import Paths_Rakka -- Cabal が用意する。
16 import System.Directory
18 import Text.XML.HXT.Arrow.ReadDocument
19 import Text.XML.HXT.Arrow.XmlArrow
20 import Text.XML.HXT.Arrow.XmlIOStateArrow
21 import Text.XML.HXT.Arrow.XmlNodeSet
22 import Text.XML.HXT.DOM.TypeDefs
23 import Text.XML.HXT.DOM.XmlKeywords
26 loadDefaultPage :: PageName -> IO (Maybe Page)
27 loadDefaultPage pageName
28 -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
29 = do let pagePath = "defaultPages/" ++ encodePageName pageName
30 isInDataDir <- doesFileExist pagePath
32 return . Just =<< loadPageFile pageName pagePath
34 do fpath <- getDataFileName pagePath
35 isInstalled <- doesFileExist fpath
37 return . Just =<< loadPageFile pageName fpath
42 loadPageFile :: PageName -> FilePath -> IO Page
43 loadPageFile name path
44 = do [page] <- runX ( setErrorMsgHandler False fail
53 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
55 = proc (name, fpath) ->
56 do tree <- readFromDocument [ (a_validate , v_0)
57 , (a_check_namespaces , v_1)
58 , (a_remove_whitespace, v_1)
60 lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
61 parsePage -< (name, lastMod, tree)
64 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
66 = proc (name, lastMod, tree)
67 -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
69 Nothing -> parseEntity -< (name, lastMod, tree)
70 Just dest -> returnA -< (Redirection {
73 , redirRevision = Nothing
74 , redirLastMod = lastMod
78 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
80 = proc (name, lastMod, tree)
81 -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
84 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
85 >>> parseYesOrNo) -< tree
86 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
87 >>> parseYesOrNo) -< tree
88 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
89 >>> parseYesOrNo) -< tree
90 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
91 >>> parseYesOrNo) -< tree
93 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
95 >>> deleteIfEmpty)) -< tree
97 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
101 getAttrValue0 "page")) -< tree
103 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
104 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
106 let (isBinary, content)
107 = case (textData, binaryData) of
108 (Just text, _ ) -> (False, encodeLazy UTF8 text )
109 (_ , Just binary) -> (True , L.pack $ B64.decode binary)
113 , pageType = mimeType
114 , pageIsTheme = isTheme
115 , pageIsFeed = isFeed
116 , pageIsLocked = isLocked
117 , pageIsBoring = isBoring
118 , pageIsBinary = isBinary
119 , pageRevision = Nothing
120 , pageLastMod = lastMod
121 , pageSummary = summary
122 , pageOtherLang = otherLang
123 , pageContent = content