X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FDefaultPage.hs;h=f9b73f0ca9ee8083360462145bd598a93b4f27c1;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=8e79a6dbc9470062677d8a2a1a64e2d8e9aa930c;hpb=e2fd35989e9765281523fd4ce05dcd0199bdbbad;p=Rakka.git diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 8e79a6d..f9b73f0 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -1,62 +1,89 @@ +{-# LANGUAGE + Arrows + , DoAndIfThenElse + , UnicodeSyntax + #-} module Rakka.Storage.DefaultPage ( findAllDefaultPages + , getDefaultDirContents , loadDefaultPage ) where - -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 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.Arrow.XmlNodeSet -import Text.XML.HXT.DOM.TypeDefs -import Text.XML.HXT.DOM.XmlKeywords - - -doesLocalDirExist :: IO Bool +import Control.Applicative +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Monad.Unicode +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import Paths_Rakka +import Prelude.Unicode +import Rakka.Page +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.XmlState + +doesLocalDirExist ∷ IO Bool doesLocalDirExist = doesDirectoryExist "defaultPages" - -findAllDefaultPages :: IO (Set PageName) +findAllDefaultPages ∷ IO (Set PageName) findAllDefaultPages + -- If ./defaultPages exists, find pages in it. Otherwise find + -- defaultPages using Cabal's Paths_Rakka. + = do localDirExists ← doesLocalDirExist + if localDirExists then + findAllIn "defaultPages" + else + -- FIXME: This usage of getDataFileName is undocumented. + findAllIn =≪ getDataFileName "defaultPages" + where + findAllIn ∷ FilePath → IO (Set PageName) + findAllIn dirPath + = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>)) + <$> + find always (fileType ==? RegularFile) dirPath + +getDefaultDirContents :: PageName -> IO (Set PageName) +getDefaultDirContents dir -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で -- defaultPages を探す。 = do localDirExists <- doesLocalDirExist if localDirExists then - findAllIn "defaultPages" + getDir' "defaultPages" else -- FIXME: この getDataFileName の使ひ方は undocumented - findAllIn =<< getDataFileName "defaultPages" + getDir' =<< getDataFileName "defaultPages" where - findAllIn :: FilePath -> IO (Set PageName) - findAllIn dirPath - = find always (fileType ==? RegularFile) dirPath - >>= - return . S.fromList . map (decodePageName . makeRelative dirPath) + 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 = T.pack ∘ (T.unpack dir ) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension + + f :: FilePath -> Bool + f "." = False + f ".." = False + f _ = True loadDefaultPage :: PageName -> IO (Maybe Page) loadDefaultPage name - -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ - -- ば Cabal で defaultPages/Foo を探す。 - = do let pagePath = "defaultPages" encodePageName name + -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無 + -- ければ Cabal で defaultPages/Foo.xml を探す。 + = do let pagePath = "defaultPages" encodePageName name <.> "xml" localDirExists <- doesLocalDirExist if localDirExists then @@ -83,85 +110,25 @@ loadPageFile name path ) return page - -loadPageFileA :: IOStateArrow s (PageName, FilePath) Page +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 - lastMod <- arrIO (\ x -> getFileStatus x - >>= - return . posixSecondsToUTCTime . fromRational . toRational . modificationTime) - -< fpath - parsePage -< (name, lastMod, 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 - - 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 <- (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, Nothing ) -> (False, L.pack $ encode text ) - (Nothing , Just binary) -> (True , L.pack $ B64.decode binary) - _ -> error "one of textData or binaryData is required" - - returnA -< Entity { - pageName = name - , pageType = mimeType - , pageLanguage = lang - , pageFileName = fileName - , 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 + = proc (name, fpath) → + do tree ← readFromDocument [ withValidate no + , withCheckNamespaces yes + , withRemoveWS yes + ] ⤙ fpath + lastMod ← arrIO ( \x → getFileStatus x + ≫= + pure ∘ 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 + }