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 f8ac5ddcea7e9a3c587a5477a5c2c6762b936487..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
 
@@ -127,11 +128,9 @@ 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
-                          , entityIsBoring   = any ((== "rakka:isBoring") . fst) props
                           , entityIsBinary   = case mimeType of
                                                  MIMEType "text" _ _
                                                      -> any ((== "rakka:isBinary") . fst) props
@@ -181,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
@@ -206,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
@@ -227,11 +221,9 @@ putPageIntoRepository repos page
           = do let path = mkPagePath name
                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
                setNodeProp path "rakka:lang"      Nothing
-               setNodeProp path "rakka:fileName"  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
@@ -242,11 +234,9 @@ putPageIntoRepository repos page
           = 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)
-               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
@@ -262,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