module Rakka.Storage.Repos
- ( loadPageInRepository
+ ( findAllPagesInRevision
+ , findChangedPagesAtRevision
+ , loadPageInRepository
+ , putPageIntoRepository
)
where
+import Control.Exception
+import Control.Monad
+import Data.List
import qualified Data.Map as M
import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as S hiding (Set)
import Data.Time
import Network.HTTP.Lucu hiding (redirect)
import Rakka.Page
import Rakka.SystemConfig
import Rakka.Utils
import Rakka.W3CDateTime
-import Subversion.Types
+import Subversion.Error
import Subversion.FileSystem
+import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
import Subversion.FileSystem.Root
+import Subversion.FileSystem.Transaction
import Subversion.Repository
+import Subversion.Types
import System.FilePath.Posix
+mkPagePath :: PageName -> FilePath
+mkPagePath name
+ = "/pages" </> encodePageName name <.> "page"
+
+
+findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
+findAllPagesInRevision repos rev
+ = do fs <- getRepositoryFS repos
+ withRevision fs rev
+ $ do exists <- isDirectory root
+ if exists then
+ traverse root
+ else
+ return S.empty
+ where
+ root :: FilePath
+ root = "/pages"
+
+ traverse :: FilePath -> Rev (Set PageName)
+ traverse dir
+ = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
+
+ traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
+ traverse' dir entry
+ = let path = dir </> entName entry
+ in
+ do kind <- checkPath path
+ case kind of
+ NoNode -> return S.empty
+ FileNode -> return $ S.singleton (decodePath path)
+ DirNode -> traverse path
+
+ decodePath :: FilePath -> PageName
+ decodePath = decodePageName . makeRelative root . dropExtension
+
+
+findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
+findChangedPagesAtRevision repos rev
+ = do fs <- getRepositoryFS repos
+ withRevision fs rev
+ $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
+ where
+ accumulatePages :: Set PageName -> FilePath -> Set PageName
+ accumulatePages s path
+ | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
+ = let encoded = makeRelative "/pages" $ dropExtension path
+ name = decodePageName encoded
+ in
+ S.insert name s
+ | otherwise
+ = s
+
+
loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
loadPageInRepository repos name rev
= do fs <- getRepositoryFS repos
-> return Nothing
where
path :: FilePath
- path = "pages" </> encodePageName name
+ path = mkPagePath name
loadPage' :: Rev Page
loadPage' = do redirect <- getNodeProp path "rakka:redirect"
>>= return . fromJust . parseW3CDateTime . chomp . fromJust
return Entity {
- pageName = name
- , pageType = mimeType
- , pageLanguage = fmap chomp (lookup "rakka:lang" props)
- , pageFileName = fmap chomp (lookup "rakka:fileName" props)
- , pageIsTheme = any ((== "rakka:isTheme") . fst) props
- , pageIsFeed = any ((== "rakka:isFeed") . fst) props
- , pageIsLocked = any ((== "rakka:isLocked") . fst) props
- , pageIsBoring = any ((== "rakka:isBoring") . fst) props
- , pageIsBinary = case mimeType of
- MIMEType "text" _ _
- -> any ((== "rakka:isBinary") . fst) props
- _
- -> True
- , pageRevision = pageRev
- , pageLastMod = zonedTimeToUTC lastMod
- , pageSummary = lookup "rakka:summary" props
- , pageOtherLang = fromMaybe M.empty
- $ fmap
- (M.fromList . fromJust . deserializeStringPairs)
- (lookup "rakka:otherLang" props)
- , pageContent = content
+ entityName = name
+ , entityType = mimeType
+ , entityLanguage = fmap chomp (lookup "rakka:lang" props)
+ , entityFileName = fmap chomp (lookup "rakka:fileName" props)
+ , entityIsTheme = any ((== "rakka:isTheme") . fst) props
+ , entityIsFeed = any ((== "rakka:isFeed") . fst) props
+ , entityIsLocked = any ((== "rakka:isLocked") . fst) props
+ , entityIsBoring = any ((== "rakka:isBoring") . fst) props
+ , entityIsBinary = case mimeType of
+ MIMEType "text" _ _
+ -> any ((== "rakka:isBinary") . fst) props
+ _
+ -> True
+ , entityRevision = pageRev
+ , entityLastMod = zonedTimeToUTC lastMod
+ , entitySummary = lookup "rakka:summary" props
+ , entityOtherLang = fromMaybe M.empty
+ $ fmap
+ (M.fromList . fromJust . deserializeStringPairs)
+ (lookup "rakka:otherLang" props)
+ , entityContent = content
+ , entityUpdateInfo = undefined
}
loadPageRedirect :: Rev Page
loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented"
+
+
+putPageIntoRepository :: Repository -> Page -> IO StatusCode
+putPageIntoRepository repos page
+ = filterSvnError $
+ do let name = pageName page
+ ret <- case pageUpdateInfo page of
+ Just ui
+ -> doReposTxn
+ repos
+ (uiOldRevision ui)
+ "[Rakka]"
+ (Just "Automatic commit by Rakka for page update")
+ $ do case uiOldName ui of
+ Nothing -> return ()
+ Just oldName -> renamePage oldName name
+ updatePage name
+ Nothing
+ -> do fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ doReposTxn repos
+ rev
+ "[Rakka]"
+ (Just "Automatic commit by Rakka for page creation")
+ $ do createPage name
+ updatePage name
+ case ret of
+ Left _ -> return Conflict
+ Right _ -> return Created
+ where
+ renamePage :: PageName -> PageName -> Txn ()
+ renamePage oldName newName
+ = fail "FIXME: renamePage: not implemented yet"
+
+ createPage :: PageName -> Txn ()
+ createPage name
+ = do let path = mkPagePath name
+ createParentDirectories path
+ makeFile path
+
+ createParentDirectories :: FilePath -> Txn ()
+ createParentDirectories path
+ = do let parentPath = takeDirectory path
+ kind <- checkPath parentPath
+ case kind of
+ NoNode -> do createParentDirectories parentPath
+ makeDirectory parentPath
+ FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
+ DirNode -> return ()
+
+ updatePage :: PageName -> Txn ()
+ updatePage name
+ | isRedirect page = updatePageRedirect name
+ | isEntity page = updatePageEntity name
+ | otherwise = fail "neither redirection nor page"
+
+ updatePageRedirect :: PageName -> Txn ()
+ updatePageRedirect name
+ = fail "FIXME: updatePageRedirect: not implemented yet"
+
+ updatePageEntity :: PageName -> Txn ()
+ updatePageEntity name
+ = do let path = mkPagePath name
+ setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
+ setNodeProp path "rakka:lang" (entityLanguage page)
+ setNodeProp path "rakka:fileName" (entityFileName page)
+ setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
+ setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
+ setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
+ setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page)
+ setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
+ setNodeProp path "rakka:summary" (entitySummary page)
+ setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
+ in
+ if M.null otherLang then
+ Nothing
+ else
+ Just (serializeStringPairs $ M.toList otherLang))
+ applyTextLBS path Nothing (entityContent page)
+
+ encodeFlag :: Bool -> Maybe String
+ encodeFlag True = Just "*\n"
+ encodeFlag False = Nothing
+
+
+filterSvnError :: IO a -> IO a
+filterSvnError f = catchDyn f rethrow
+ where
+ rethrow :: SvnError -> IO a
+ rethrow err
+ = let code = svnErrCode err
+ msg = svnErrMsg err
+ in
+ fail $ "SvnError: " ++ (show code) ++ ": " ++ msg
projects / Rakka.git / blobdiff