module Rakka.Storage.DefaultPage
- ( loadDefaultPage
+ ( findAllDefaultPages
+ , getDefaultDirContents
+ , loadDefaultPage
)
where
-import qualified Codec.Binary.Base64.String as B64
import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
-import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time.Clock.POSIX
import Paths_Rakka -- Cabal が用意する。
import Rakka.Page
-import Rakka.Utils
import System.Directory
+import System.FilePath
+import System.FilePath.Find hiding (fileName, modificationTime)
+import System.Posix.Files
import Text.XML.HXT.Arrow.ReadDocument
-import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
-import Text.XML.HXT.Arrow.XmlNodeSet
-import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.DOM.XmlKeywords
+doesLocalDirExist :: IO Bool
+doesLocalDirExist = doesDirectoryExist "defaultPages"
+
+
+findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages
+ -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+ -- defaultPages を探す。
+ = do localDirExists <- doesLocalDirExist
+ if localDirExists then
+ findAllIn "defaultPages"
+ else
+ -- FIXME: この getDataFileName の使ひ方は undocumented
+ findAllIn =<< getDataFileName "defaultPages"
+ where
+ findAllIn :: FilePath -> IO (Set PageName)
+ findAllIn dirPath
+ = find always (fileType ==? RegularFile) dirPath
+ >>=
+ return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
+
+
+getDefaultDirContents :: PageName -> IO (Set PageName)
+getDefaultDirContents dir
+ -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
+ -- defaultPages を探す。
+ = do localDirExists <- doesLocalDirExist
+ if localDirExists then
+ getDir' "defaultPages"
+ else
+ -- FIXME: この getDataFileName の使ひ方は undocumented
+ getDir' =<< getDataFileName "defaultPages"
+ where
+ getDir' :: FilePath -> IO (Set PageName)
+ getDir' basePath
+ = do let childDirPath = basePath </> encodePageName dir
+ exists <- doesDirectoryExist childDirPath
+ if exists then
+ getDirectoryContents childDirPath
+ >>=
+ return . S.fromList . map (m basePath) . filter f
+ else
+ return S.empty
+
+ m :: FilePath -> FilePath -> PageName
+ m basePath = (dir </>) . decodePageName . makeRelative basePath . dropExtension
+
+ f :: FilePath -> Bool
+ f "." = False
+ f ".." = False
+ f _ = True
+
+
loadDefaultPage :: PageName -> IO (Maybe Page)
-loadDefaultPage pageName
- -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。
- = do let pagePath = encodePageName pageName
- isInDataDir <- doesFileExist ("./data/" ++ pagePath)
- if isInDataDir then
- return . Just =<< loadPageFile pageName ("./data/" ++ pagePath)
+loadDefaultPage name
+ -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無
+ -- ければ Cabal で defaultPages/Foo.xml を探す。
+ = do let pagePath = "defaultPages" </> encodePageName name <.> "xml"
+
+ localDirExists <- doesLocalDirExist
+ if localDirExists then
+ tryLoad pagePath
else
- do fpath <- getDataFileName ("defaultPages/" ++ pagePath)
- isInstalled <- doesFileExist fpath
- if isInstalled then
- return . Just =<< loadPageFile pageName fpath
- else
- return Nothing
+ tryLoad =<< getDataFileName pagePath
+ where
+ tryLoad :: FilePath -> IO (Maybe Page)
+ tryLoad fpath
+ = do exists <- doesFileExist fpath
+ if exists then
+ return . Just =<< loadPageFile name fpath
+ else
+ return Nothing
loadPageFile :: PageName -> FilePath -> IO Page
loadPageFile name path
- = do [page] <- runX ( constA (name, path)
+ = do [page] <- runX ( setErrorMsgHandler False fail
+ >>>
+ constA (name, path)
>>>
loadPageFileA
)
loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
loadPageFileA
= proc (name, fpath) ->
- do tree <- readFromDocument [ (a_validate , v_0)
- , (a_check_namespaces , v_1)
- , (a_remove_whitespace, v_1)
- ] -< fpath
- parsePage -< (name, tree)
-
-
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
-parsePage
- = proc (name, tree)
- -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
- >>> arr read) -< tree
-
- isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
- >>> defaultTo "no"
- >>> parseYesOrNo) -< tree
- isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
- >>> defaultTo "no"
- >>> parseYesOrNo) -< tree
- isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
- >>> defaultTo "no"
- >>> parseYesOrNo) -< tree
- isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
- >>> defaultTo "no"
- >>> parseYesOrNo) -< tree
-
- summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
- >>> getText
- >>> deleteIfEmpty)) -< tree
-
- otherLang <- listA (getXPathTreesInDoc "/page/otherLang/link"
- >>>
- (getAttrValue0 "lang"
- &&&
- getAttrValue0 "page")) -< tree
-
- textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree
- binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
-
- let content = case (textData, binaryData) of
- (Just text, _ ) -> L8.pack text
- (_ , Just binary) -> L8.pack $ B64.decode binary
-
- returnA -< Page {
- pageName = name
- , pageType = mimeType
- , pageIsTheme = isTheme
- , pageIsFeed = isFeed
- , pageIsLocked = isLocked
- , pageIsBoring = isBoring
- , pageRevision = Nothing
- , pageSummary = summary
- , pageOtherLang = otherLang
- , pageContent = content
- }
\ No newline at end of file
+ do tree <- readFromDocument [ (a_validate , v_0)
+ , (a_check_namespaces , v_1)
+ , (a_remove_whitespace, v_1)
+ ] -< fpath
+ lastMod <- arrIO (\ x -> getFileStatus x
+ >>=
+ return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
+ -< fpath
+ page <- parseXmlizedPage -< (name, tree)
+
+ if isEntity page then
+ returnA -< page {
+ entityRevision = 0
+ , entityLastMod = lastMod
+ }
+ else
+ returnA -< page {
+ redirRevision = 0
+ , redirLastMod = lastMod
+ }
projects / Rakka.git / blobdiff