X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=8e717ed27ee7008ec764ebd3f0637c51071d00d6;hb=5311fe068286b30d52063ef97cc00f09f65a47f1;hp=92fa6b8949c09acf664dcf558aeccb4e8e1d0643;hpb=9ff4eb243ae1545c62a5ab2eaf8dcb2f7c40b20d;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 92fa6b8..8e717ed 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,24 +1,90 @@ module Rakka.Storage.Repos - ( loadPageInRepository + ( findAllPagesInRevision + , findChangedPagesAtRevision + , loadPageInRepository + , putPageIntoRepository + , deletePageFromRepository ) where +import Codec.Binary.UTF8.String +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 @@ -34,15 +100,15 @@ loadPageInRepository repos name rev -> return Nothing where path :: FilePath - path = "pages" encodePageName name + path = mkPagePath name loadPage' :: Rev Page - loadPage' = do redirect <- getNodeProp path "rakka:redirect" - case redirect of - Nothing - -> loadPageEntity - Just _ + loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type") + case mType of + Just (MIMEType "application" "x-rakka-redirection" _) -> loadPageRedirect + _ + -> loadPageEntity loadPageEntity :: Rev Page loadPageEntity @@ -59,28 +125,181 @@ loadPageInRepository repos name rev >>= 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) + , 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" + loadPageRedirect + = do hist <- getNodeHistory True path + content <- getFileContents path + + let pageRev = fst $ head hist + dest = chomp $ decodeString content + + lastMod <- getRevisionProp "svn:date" + >>= return . fromJust . parseW3CDateTime . chomp . fromJust + + return Redirection { + redirName = name + , redirDest = dest + , redirRevision = pageRev + , redirLastMod = zonedTimeToUTC lastMod + , redirUpdateInfo = undefined + } + + +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 (uiOldRevision ui) 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 :: RevNum -> PageName -> PageName -> Txn () + renamePage oldRev oldName newName + = do let oldPath = mkPagePath oldName + newPath = mkPagePath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + + createPage :: PageName -> Txn () + createPage name + = do let path = mkPagePath name + createParentDirectories path + makeFile path + + updatePage :: PageName -> Txn () + updatePage name + | isRedirect page = updatePageRedirect name + | isEntity page = updatePageEntity name + | otherwise = fail "neither redirection nor page" + + updatePageRedirect :: PageName -> Txn () + updatePageRedirect name + = do let path = mkPagePath name + setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection") + setNodeProp path "rakka:lang" Nothing + setNodeProp path "rakka:isTheme" Nothing + setNodeProp path "rakka:isFeed" Nothing + setNodeProp path "rakka:isLocked" Nothing + setNodeProp path "rakka:isBoring" Nothing + setNodeProp path "rakka:isBinary" Nothing + setNodeProp path "rakka:summary" Nothing + setNodeProp path "rakka:otherLang" Nothing + applyText path Nothing (encodeString (redirDest page) ++ "\n") + + 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: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 "*" + encodeFlag False = Nothing + + +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 () + + +deletePageFromRepository :: Repository -> PageName -> IO StatusCode +deletePageFromRepository repos name + = filterSvnError $ + do let path = mkPagePath name + fs <- getRepositoryFS repos + rev <- getYoungestRev fs + exists <- withRevision fs rev $ isFile path + if exists then + do doReposTxn repos + rev + "[Rakka]" + (Just "Automatic commit by Rakka for page deleting") + $ do deleteEntry path + deleteEmptyParentDirectories path + return NoContent + else + return NotFound + + +deleteEmptyParentDirectories :: FilePath -> Txn () +deleteEmptyParentDirectories path + = do let parentPath = takeDirectory path + contents <- getDirEntries parentPath + when (null contents) + $ do deleteEntry parentPath + deleteEmptyParentDirectories parentPath + + +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