X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=e6f51a55a284dbc8737b3274a00a5acf4501c08f;hp=b5648cf49b64c6c69b7d8cf2ba8b5b06b8313092;hb=49b4f4696b29862524792bcc610dd09aa93c187c;hpb=98e508613bb7a50a1f65998ce87f065df957b736 diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index b5648cf..e6f51a5 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -1,31 +1,24 @@ module Rakka.Storage.DefaultPage ( findAllDefaultPages + , getDefaultDirContents , loadDefaultPage ) where -import qualified Codec.Binary.Base64 as B64 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList -import qualified Data.ByteString.Lazy as L -import Data.Encoding -import Data.Encoding.UTF8 -import qualified Data.Map as M 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.FilePath -import System.FilePath.Find 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 @@ -48,14 +41,45 @@ findAllDefaultPages findAllIn dirPath = find always (fileType ==? RegularFile) dirPath >>= - return . S.fromList . map (decodePageName . makeRelative 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 - -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ - -- ば Cabal で defaultPages/Foo を探す。 - = do let pagePath = "defaultPages/" ++ encodePageName pageName +loadDefaultPage name + -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無 + -- ければ Cabal で defaultPages/Foo.xml を探す。 + = do let pagePath = "defaultPages" encodePageName name <.> "xml" localDirExists <- doesLocalDirExist if localDirExists then @@ -67,7 +91,7 @@ loadDefaultPage pageName tryLoad fpath = do exists <- doesFileExist fpath if exists then - return . Just =<< loadPageFile pageName fpath + return . Just =<< loadPageFile name fpath else return Nothing @@ -90,71 +114,19 @@ loadPageFileA , (a_check_namespaces , v_1) , (a_remove_whitespace, v_1) ] -< fpath - lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath - parsePage -< (name, lastMod, 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 - - lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree - - isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isLocked <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no" - >>> parseYesOrNo) -< tree - isBoring <- (withDefault (getXPathTreesInDoc "/page/@isBoring/text()" >>> getText) "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/text()" >>> getText) -< tree - binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree - - let (isBinary, content) - = case (textData, binaryData) of - (Just text, _ ) -> (False, encodeLazy UTF8 text ) - (_ , Just binary) -> (True , L.pack $ B64.decode binary) - - returnA -< Entity { - pageName = name - , pageType = mimeType - , pageLanguage = lang - , pageIsTheme = isTheme - , pageIsFeed = isFeed - , pageIsLocked = isLocked - , pageIsBoring = isBoring - , pageIsBinary = isBinary - , pageRevision = 0 - , pageLastMod = lastMod - , pageSummary = summary - , pageOtherLang = M.fromList otherLang - , pageContent = content - } \ No newline at end of file + 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 + }