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
118 fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
120 isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
121 >>> parseYesOrNo) -< tree
122 isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
123 >>> parseYesOrNo) -< tree
124 isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
125 >>> parseYesOrNo) -< tree
126 isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
127 >>> parseYesOrNo) -< tree
129 summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
131 >>> deleteIfEmpty)) -< tree
133 otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
135 (getAttrValue0 "lang"
137 getAttrValue0 "page")) -< tree
139 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
140 binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
142 let (isBinary, content)
143 = case (textData, binaryData) of
144 (Just text, _ ) -> (False, encodeLazy UTF8 text )
145 (_ , Just binary) -> (True , L.pack $ B64.decode binary)
149 , pageType = mimeType
150 , pageLanguage = lang
151 , pageFileName = fileName
152 , pageIsTheme = isTheme
153 , pageIsFeed = isFeed
154 , pageIsLocked = isLocked
155 , pageIsBoring = isBoring
156 , pageIsBinary = isBinary
158 , pageLastMod = lastMod
159 , pageSummary = summary
160 , pageOtherLang = M.fromList otherLang
161 , pageContent = content