X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=76889d7e0ad5fac702041a17b4bb787fe8a491a5;hb=e85b652169f502cffe1f6f7f927d8990e9c11499;hp=576e5b740d5210af8db52ddaf1d845031d661d83;hpb=044a917ed3908780479b759ac772e1545616c7fc;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 576e5b7..76889d7 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,9 +1,12 @@ module Rakka.Storage.Repos ( findAllPagesInRevision + , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository , deletePageFromRepository + , loadAttachmentInRepository + , putAttachmentIntoRepository ) where @@ -17,6 +20,7 @@ import Data.Set (Set) import qualified Data.Set as S hiding (Set) import Data.Time import Network.HTTP.Lucu hiding (redirect) +import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig import Rakka.Utils @@ -37,6 +41,21 @@ mkPagePath name = "/pages" encodePageName name <.> "page" +mkDirPath :: PageName -> FilePath +mkDirPath dir + = "/pages" encodePageName dir + + +mkAttachmentPath :: PageName -> String -> FilePath +mkAttachmentPath pName aName + = "/attachments" encodePageName pName <.> "page" aName + + +mkAttachmentDirPath :: PageName -> FilePath +mkAttachmentDirPath pName + = "/attachments" encodePageName pName <.> "page" + + findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos @@ -68,6 +87,29 @@ findAllPagesInRevision repos rev decodePath = decodePageName . makeRelative root . dropExtension +getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName) +getDirContentsInRevision repos dir rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isDirectory path + if exists then + return . S.fromList =<< getDir' + else + return S.empty + where + path :: FilePath + path = mkDirPath dir + + getDir' :: Rev [PageName] + getDir' = getDirEntries path >>= return . map entToName + + entToName :: DirEntry -> PageName + entToName = (dir ) . decodePageName . dropExtension . entName + + findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos @@ -93,11 +135,10 @@ loadPageInRepository repos name rev Just r -> return r withRevision fs rev' $ do exists <- isFile path - case exists of - True - -> return . Just =<< loadPage' - False - -> return Nothing + if exists then + return . Just =<< loadPage' + else + return Nothing where path :: FilePath path = mkPagePath name @@ -131,7 +172,6 @@ loadPageInRepository repos name rev , 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 @@ -159,46 +199,87 @@ loadPageInRepository repos name rev lastMod <- getRevisionProp "svn:date" >>= return . fromJust . parseW3CDateTime . chomp . fromJust + isLocked <- getRevisionProp "rakka:isLocked" + >>= return . isJust + return Redirection { redirName = name , redirDest = dest + , redirIsLocked = isLocked , redirRevision = pageRev , redirLastMod = zonedTimeToUTC lastMod , redirUpdateInfo = undefined } -putPageIntoRepository :: Repository -> Page -> IO StatusCode -putPageIntoRepository repos page +putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode +putPageIntoRepository repos userID 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 + do let name = pageName page + author = fromMaybe "[Rakka]" userID + case pageUpdateInfo page of + Just ui + -> do let oldRev = uiOldRevision ui + denied <- case uiOldName ui of + Nothing -> checkDenial oldRev name + Just oldName -> checkDenial oldRev oldName + if denied then + return Forbidden + else + do ret <- doReposTxn + repos + (uiOldRevision ui) + author + (Just "Automatic commit by Rakka for page update") + $ do case uiOldName ui of + Nothing -> return () + Just oldName -> movePage (uiOldRevision ui) oldName name + >> + moveAttachments (uiOldRevision ui) oldName name + updatePage name + case ret of + Left _ -> return Conflict + Right _ -> return Created + Nothing + -> do fs <- getRepositoryFS repos + rev <- getYoungestRev fs + ret <- doReposTxn + repos + rev + author + (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" + checkDenial :: RevNum -> PageName -> IO Bool + checkDenial rev name + = do fs <- getRepositoryFS repos + withRevision fs rev + $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked" + case prop of + Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 + Nothing -> return False + + movePage :: RevNum -> PageName -> PageName -> Txn () + movePage oldRev oldName newName + = do let oldPath = mkPagePath oldName + newPath = mkPagePath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + + moveAttachments :: RevNum -> PageName -> PageName -> Txn () + moveAttachments oldRev oldName newName + = do let oldPath = mkAttachmentDirPath oldName + newPath = mkAttachmentDirPath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath createPage :: PageName -> Txn () createPage name @@ -206,16 +287,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 @@ -229,8 +300,7 @@ putPageIntoRepository repos page 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:isLocked" (encodeFlag $ redirIsLocked page) setNodeProp path "rakka:isBinary" Nothing setNodeProp path "rakka:summary" Nothing setNodeProp path "rakka:otherLang" Nothing @@ -244,7 +314,6 @@ putPageIntoRepository repos 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 @@ -260,31 +329,118 @@ putPageIntoRepository repos page encodeFlag False = Nothing -deletePageFromRepository :: Repository -> PageName -> IO StatusCode -deletePageFromRepository repos name +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 -> Maybe String -> PageName -> IO StatusCode +deletePageFromRepository repos userID name = filterSvnError $ - do let path = mkPagePath name + do let pagePath = mkPagePath name + attachmentPath = mkAttachmentDirPath 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 + status <- withRevision fs rev + $ do exists <- isFile pagePath + if exists then + do prop <- getNodeProp pagePath "rakka:isLocked" + return $ case prop of + Just _ + -> if isNothing userID then + -- 施錠されてゐるので匿名では駄目 + Forbidden + else + NoContent + Nothing + -> NoContent + else + return NotFound + when (status == NoContent) + $ do doReposTxn repos + rev + "[Rakka]" + (Just "Automatic commit by Rakka for page deleting") + $ do deleteEntry pagePath + deleteEmptyParentDirectories pagePath + + attachmentExists <- isDirectory attachmentPath + when attachmentExists + $ do deleteEntry attachmentPath + deleteEmptyParentDirectories attachmentPath + return () + return status + + +deleteEmptyParentDirectories :: FilePath -> Txn () +deleteEmptyParentDirectories path + = do let parentPath = takeDirectory path + contents <- getDirEntries parentPath + when (null contents) + $ do deleteEntry parentPath + deleteEmptyParentDirectories parentPath + + +loadAttachmentInRepository :: forall a. Attachment a => + Repository + -> PageName + -> String + -> Maybe RevNum + -> IO (Maybe a) +loadAttachmentInRepository repos pName aName rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isFile path + if exists then + return . Just =<< loadAttachment' + else + return Nothing where - deleteEmptyParentDirectories :: FilePath -> Txn () - deleteEmptyParentDirectories path - = do let parentPath = takeDirectory path - contents <- getDirEntries parentPath - when (null contents) - $ do deleteEntry parentPath - deleteEmptyParentDirectories parentPath + path :: FilePath + path = mkAttachmentPath pName aName + + loadAttachment' :: Rev a + loadAttachment' = getFileContents path >>= return . deserializeFromString + + +putAttachmentIntoRepository :: Attachment a => + Repository + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> IO StatusCode +putAttachmentIntoRepository repos userID oldRev pName aName attachment + = filterSvnError $ + do let author = fromMaybe "[Rakka]" userID + path = mkAttachmentPath pName aName + fs <- getRepositoryFS repos + oldRev' <- case oldRev of + Nothing -> getYoungestRev fs + Just r -> return r + ret <- doReposTxn + repos + oldRev' + author + (Just "Automatic commit by Rakka for putting attachment") + $ do exists <- isFile path + unless exists + $ do createParentDirectories path + makeFile path + applyText path Nothing (serializeToString attachment) + case ret of + Left _ -> return Conflict + Right _ -> return NoContent filterSvnError :: IO a -> IO a