, findChangedPagesAtRevision
, loadPageInRepository
, putPageIntoRepository
+ , deletePageFromRepository
)
where
, 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
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 -> renamePage (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
+
+ 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
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
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
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
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 -> Maybe String -> PageName -> IO StatusCode
+deletePageFromRepository repos userID name
+ = filterSvnError $
+ do let path = mkPagePath name
+ fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ status <- withRevision fs rev
+ $ do exists <- isFile path
+ if exists then
+ do prop <- getNodeProp path "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 path
+ deleteEmptyParentDirectories path
+ return ()
+ return status
+
+
+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
projects / Rakka.git / blobdiff