module Rakka.Storage.DefaultPage
- ( loadDefaultPage
+ ( findAllDefaultPages
+ , loadDefaultPage
)
where
-import qualified Codec.Binary.Base64.String as B64
+import qualified Codec.Binary.Base64 as B64
+import Codec.Binary.UTF8.String
import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
-import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time
+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.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)
+
+
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 を探す。無けれ
+ -- ば Cabal で defaultPages/Foo を探す。
+ = do let pagePath = "defaultPages" </> encodePageName name
+
+ 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)
+ 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
+ parsePage -< (name, lastMod, tree)
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
-parsePage
- = proc (name, tree)
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
+parsePage
+ = proc (name, lastMod, tree)
+ -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
+ case redirect of
+ Nothing -> parseEntity -< (name, lastMod, tree)
+ Just dest -> returnA -< (Redirection {
+ redirName = name
+ , redirDest = dest
+ , redirRevision = Nothing
+ , redirLastMod = lastMod
+ })
+
+
+parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
+parseEntity
+ = proc (name, lastMod, tree)
-> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
>>> arr read) -< tree
- isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText)
- >>> defaultTo "no"
+ lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
+ fileName <- maybeA (getXPathTreesInDoc "/page/@filename/text()" >>> getText) -< tree
+
+ isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText)
- >>> defaultTo "no"
+ isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isLocked <- (maybeA (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText)
- >>> defaultTo "no"
+ isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
- isBoring <- (maybeA (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText)
- >>> defaultTo "no"
+ isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "no"
>>> parseYesOrNo) -< tree
summary <- (maybeA (getXPathTreesInDoc "/page/summary/text()"
&&&
getAttrValue0 "page")) -< tree
- textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree
- binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree
+ textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
+ binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
- let content = case (textData, binaryData) of
- (Just text, _ ) -> L8.pack text
- (_ , Just binary) -> L8.pack $ B64.decode binary
+ let (isBinary, content)
+ = case (textData, binaryData) of
+ (Just text, Nothing ) -> (False, L.pack $ encode text )
+ (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
+ _ -> error "one of textData or binaryData is required"
- returnA -< Page {
+ returnA -< Entity {
pageName = name
, pageType = mimeType
+ , pageLanguage = lang
+ , pageFileName = fileName
, pageIsTheme = isTheme
, pageIsFeed = isFeed
, pageIsLocked = isLocked
, pageIsBoring = isBoring
- , pageRevision = Nothing
+ , pageIsBinary = isBinary
+ , pageRevision = 0
+ , pageLastMod = lastMod
, pageSummary = summary
- , pageOtherLang = otherLang
+ , pageOtherLang = M.fromList otherLang
, pageContent = content
}
\ No newline at end of file
projects / Rakka.git / blobdiff