X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=06b40361908ff39e1f2bf20b028d3a16fa0e8fe6;hb=bf15724655b75bf1b8f0fdabb111c158a91680a8;hp=9cdaf45afed2152cc8b37b7753e985dab48a1461;hpb=03585f9c5773f6c0b59497f4f563909576c402b5;p=Rakka.git diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 9cdaf45..06b4036 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -1,40 +1,67 @@ module Rakka.Storage.DefaultPage - ( loadDefaultPage + ( findAllDefaultPages + , 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.Time +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) + + 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 @@ -55,70 +82,19 @@ loadPageFileA , (a_check_namespaces , v_1) , (a_remove_whitespace, v_1) ] -< fpath - lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath - parsePage -< (name, lastMod, tree) + lastMod <- arrIO (\ x -> getFileStatus x + >>= + return . posixSecondsToUTCTime . fromRational . toRational . modificationTime) + -< fpath + page <- parseXmlizedPage -< (name, tree) - -parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, 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, CalendarTime, 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" - >>> 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 -< Entity { - pageName = name - , pageType = mimeType - , pageIsTheme = isTheme - , pageIsFeed = isFeed - , pageIsLocked = isLocked - , pageIsBoring = isBoring - , pageRevision = Nothing - , pageLastMod = lastMod - , pageSummary = summary - , pageOtherLang = otherLang - , pageContent = content - } \ No newline at end of file + if isEntity page then + returnA -< page { + entityRevision = 0 + , entityLastMod = lastMod + } + else + returnA -< page { + redirRevision = 0 + , redirLastMod = lastMod + }