1 module Rakka.Storage.DefaultPage
7 import qualified Codec.Binary.Base64 as B64
9 import Control.Arrow.ArrowIO
10 import Control.Arrow.ArrowList
11 import qualified Data.ByteString.Lazy as L
13 import Data.Encoding.UTF8
14 import qualified Data.Map as M
16 import qualified Data.Set as S
17 import Paths_Rakka -- Cabal が用意する。
20 import System.FilePath
21 import System.FilePath.Find
22 import System.Directory
24 import Text.XML.HXT.Arrow.ReadDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.Arrow.XmlNodeSet
28 import Text.XML.HXT.DOM.TypeDefs
29 import Text.XML.HXT.DOM.XmlKeywords
32 doesLocalDirExist :: IO Bool
33 doesLocalDirExist = doesDirectoryExist "defaultPages"
36 findAllDefaultPages :: IO (Set PageName)
38 -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
40 = do localDirExists <- doesLocalDirExist
41 if localDirExists then
42 findAllIn "defaultPages"
44 -- FIXME: この getDataFileName の使ひ方は undocumented
45 findAllIn =<< getDataFileName "defaultPages"
47 findAllIn :: FilePath -> IO (Set PageName)
49 = find always (fileType ==? RegularFile) dirPath
51 return . S.fromList . map (decodePageName . makeRelative dirPath)
54 loadDefaultPage :: PageName -> IO (Maybe Page)
55 loadDefaultPage pageName
56 -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
57 -- ば Cabal で defaultPages/Foo を探す。
58 = do let pagePath = "defaultPages/" ++ encodePageName pageName
60 localDirExists <- doesLocalDirExist
61 if localDirExists then
64 tryLoad =<< getDataFileName pagePath
66 tryLoad :: FilePath -> IO (Maybe Page)
68 = do exists <- doesFileExist fpath
70 return . Just =<< loadPageFile pageName fpath
75 loadPageFile :: PageName -> FilePath -> IO Page
76 loadPageFile name path
77 = do [page] <- runX ( setErrorMsgHandler False fail
86 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
88 = proc (name, fpath) ->
89 do tree <- readFromDocument [ (a_validate , v_0)
90 , (a_check_namespaces , v_1)
91 , (a_remove_whitespace, v_1)
93 lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
94 parsePage -< (name, lastMod, tree)
97 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
99 = proc (name, lastMod, tree)
100 -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
102 Nothing -> parseEntity -< (name, lastMod, tree)
103 Just dest -> returnA -< (Redirection {
106 , redirRevision = Nothing
107 , redirLastMod = lastMod
111 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
113 = proc (name, lastMod, tree)
114 -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
115 >>> arr read) -< tree
117 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
119 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
120 >>> parseYesOrNo) -< tree
121 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
122 >>> parseYesOrNo) -< tree
123 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
124 >>> parseYesOrNo) -< tree
125 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
126 >>> parseYesOrNo) -< tree
128 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
130 >>> deleteIfEmpty)) -< tree
132 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
134 (getAttrValue0 "lang"
136 getAttrValue0 "page")) -< tree
138 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
139 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
141 let (isBinary, content)
142 = case (textData, binaryData) of
143 (Just text, _ ) -> (False, encodeLazy UTF8 text )
144 (_ , Just binary) -> (True , L.pack $ B64.decode binary)
148 , pageType = mimeType
149 , pageLanguage = lang
150 , pageIsTheme = isTheme
151 , pageIsFeed = isFeed
152 , pageIsLocked = isLocked
153 , pageIsBoring = isBoring
154 , pageIsBinary = isBinary
156 , pageLastMod = lastMod
157 , pageSummary = summary
158 , pageOtherLang = M.fromList otherLang
159 , pageContent = content