X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=8e717ed27ee7008ec764ebd3f0637c51071d00d6;hb=5311fe068286b30d52063ef97cc00f09f65a47f1;hp=0b53568b4290e9b0d433d71a291fbf1fec9b35d1;hpb=743f4a87fd557832ce67d6eb51749582820577c4;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 0b53568..8e717ed 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -3,9 +3,11 @@ module Rakka.Storage.Repos , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository + , deletePageFromRepository ) where +import Codec.Binary.UTF8.String import Control.Exception import Control.Monad import Data.List @@ -101,12 +103,12 @@ loadPageInRepository repos name rev 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 @@ -126,7 +128,6 @@ loadPageInRepository repos name rev 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 @@ -148,7 +149,23 @@ loadPageInRepository repos name rev } 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 @@ -164,24 +181,29 @@ putPageIntoRepository repos page (Just "Automatic commit by Rakka for page update") $ do case uiOldName ui of Nothing -> return () - Just oldName -> renamePage oldName name + 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 + 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" + 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 @@ -189,16 +211,6 @@ putPageIntoRepository repos page 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 @@ -207,14 +219,23 @@ putPageIntoRepository repos page updatePageRedirect :: PageName -> Txn () updatePageRedirect name - = fail "FIXME: updatePageRedirect: not implemented yet" + = 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:fileName" (entityFileName page) setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page) setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page) setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page) @@ -230,10 +251,49 @@ putPageIntoRepository repos page applyTextLBS path Nothing (entityContent page) encodeFlag :: Bool -> Maybe String - encodeFlag True = Just "*\n" + 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