improvements of page locking

[Rakka.git] / Rakka / Storage / Repos.hs

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index 8e717ed27ee7008ec764ebd3f0637c51071d00d6..e1f4b8e24049cab6d564666974328d948f1f4bf4 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -131,7 +131,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,43 +158,68 @@ 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 (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
+      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
+      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
@@ -224,8 +248,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
@@ -239,7 +262,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
@@ -266,23 +288,36 @@ createParentDirectories path
            DirNode  -> return ()
 
 
-deletePageFromRepository :: Repository -> PageName -> IO StatusCode
-deletePageFromRepository repos name
+deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
+deletePageFromRepository repos userID 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
+         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 ()