dropped the concept of boring flag

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

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index c9b913cb303844c1a7ee3ffa78896078120fd28d..0c4e2531eb17e572dbcdd3a50984f97b09e742d3 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -3,6 +3,7 @@ module Rakka.Storage.Repos
     , findChangedPagesAtRevision
     , loadPageInRepository
     , putPageIntoRepository
+    , deletePageFromRepository
     )
     where
 
@@ -130,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
@@ -180,24 +180,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
@@ -205,16 +210,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,7 +224,6 @@ putPageIntoRepository repos page
                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
@@ -243,7 +237,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
@@ -259,6 +252,45 @@ putPageIntoRepository repos 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 -> 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