module Rakka.Storage.DefaultPage
- ( loadDefaultPage
+ ( findAllDefaultPages
+ , 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 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
+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.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
- -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。
- = do let pagePath = "defaultPages/" ++ encodePageName pageName
- isInDataDir <- doesFileExist pagePath
- if isInDataDir then
- return . Just =<< loadPageFile pageName 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 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
, (a_check_namespaces , v_1)
, (a_remove_whitespace, v_1)
] -< fpath
- lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
+ lastMod <- arrIO (\ x -> getFileStatus x
+ >>=
+ return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
+ -< fpath
parsePage -< (name, lastMod, tree)
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
parsePage
= proc (name, lastMod, tree)
-> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
})
-parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+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"
let (isBinary, content)
= case (textData, binaryData) of
- (Just text, _ ) -> (False, encodeLazy UTF8 text )
- (_ , Just binary) -> (True , L.pack $ B64.decode binary)
+ (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 = Nothing
+ , pageRevision = 0
, pageLastMod = lastMod
, pageSummary = summary
- , pageOtherLang = otherLang
+ , pageOtherLang = M.fromList otherLang
, pageContent = content
}
\ No newline at end of file