1 module Rakka.Storage.DefaultPage
7 import qualified Codec.Binary.Base64 as B64
8 import Codec.Binary.UTF8.String
10 import Control.Arrow.ArrowIO
11 import Control.Arrow.ArrowList
12 import qualified Data.ByteString.Lazy as L
13 import qualified Data.Map as M
15 import qualified Data.Set as S
17 import Data.Time.Clock.POSIX
18 import Paths_Rakka -- Cabal が用意する。
21 import System.Directory
22 import System.FilePath
23 import System.FilePath.Find hiding (fileName, modificationTime)
24 import System.Posix.Files
25 import Text.XML.HXT.Arrow.ReadDocument
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.Arrow.XmlIOStateArrow
28 import Text.XML.HXT.Arrow.XmlNodeSet
29 import Text.XML.HXT.DOM.TypeDefs
30 import Text.XML.HXT.DOM.XmlKeywords
33 doesLocalDirExist :: IO Bool
34 doesLocalDirExist = doesDirectoryExist "defaultPages"
37 findAllDefaultPages :: IO (Set PageName)
39 -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
41 = do localDirExists <- doesLocalDirExist
42 if localDirExists then
43 findAllIn "defaultPages"
45 -- FIXME: この getDataFileName の使ひ方は undocumented
46 findAllIn =<< getDataFileName "defaultPages"
48 findAllIn :: FilePath -> IO (Set PageName)
50 = find always (fileType ==? RegularFile) dirPath
52 return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
55 loadDefaultPage :: PageName -> IO (Maybe Page)
57 -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
58 -- ければ Cabal で defaultPages/Foo.xml を探す。
59 = do let pagePath = "defaultPages" </> (encodePageName name `addExtension` "xml")
61 localDirExists <- doesLocalDirExist
62 if localDirExists then
65 tryLoad =<< getDataFileName pagePath
67 tryLoad :: FilePath -> IO (Maybe Page)
69 = do exists <- doesFileExist fpath
71 return . Just =<< loadPageFile name fpath
76 loadPageFile :: PageName -> FilePath -> IO Page
77 loadPageFile name path
78 = do [page] <- runX ( setErrorMsgHandler False fail
87 loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
89 = proc (name, fpath) ->
90 do tree <- readFromDocument [ (a_validate , v_0)
91 , (a_check_namespaces , v_1)
92 , (a_remove_whitespace, v_1)
94 lastMod <- arrIO (\ x -> getFileStatus x
96 return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
98 parsePage -< (name, lastMod, tree)
101 parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
103 = proc (name, lastMod, tree)
104 -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
106 Nothing -> parseEntity -< (name, lastMod, tree)
107 Just dest -> returnA -< (Redirection {
110 , redirRevision = Nothing
111 , redirLastMod = lastMod
115 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
117 = proc (name, lastMod, tree)
118 -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
119 >>> arr read) -< tree
121 lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
122 fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
124 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
125 >>> parseYesOrNo) -< tree
126 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
127 >>> parseYesOrNo) -< tree
128 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
129 >>> parseYesOrNo) -< tree
130 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
131 >>> parseYesOrNo) -< tree
133 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
135 >>> deleteIfEmpty)) -< tree
137 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
139 (getAttrValue0 "lang"
141 getAttrValue0 "page")) -< tree
143 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
144 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
146 let (isBinary, content)
147 = case (textData, binaryData) of
148 (Just text, Nothing ) -> (False, L.pack $ encode text )
149 (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
150 _ -> error "one of textData or binaryData is required"
154 , pageType = mimeType
155 , pageLanguage = lang
156 , pageFileName = fileName
157 , pageIsTheme = isTheme
158 , pageIsFeed = isFeed
159 , pageIsLocked = isLocked
160 , pageIsBoring = isBoring
161 , pageIsBinary = isBinary
163 , pageLastMod = lastMod
164 , pageSummary = summary
165 , pageOtherLang = M.fromList otherLang
166 , pageContent = content