implemented page moving

darcs-hash:20080107143611-62b54-fb97a031f4320e41bc1268d21b492693ce4b558e.gz

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 9883b576f9be232abb5a715735c5c9109c004d6a..c1d72119e348c1f7ca02dadd980cd1e440912f1c 100644 (file)
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -376,9 +376,9 @@ parseEntity
 parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
 parseUpdateInfo 
     = proc tree
-    -> do uInfo   <- getXPathTreesInDoc "/*/updateInfo" -< tree
+    -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
           oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
-          oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo
+          oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
           returnA -< UpdateInfo {
                         uiOldRevision = oldRev
                       , uiOldName     = oldName

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index 576e5b740d5210af8db52ddaf1d845031d661d83..8e717ed27ee7008ec764ebd3f0637c51071d00d6 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -181,7 +181,7 @@ 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
@@ -196,9 +196,14 @@ putPageIntoRepository repos page
            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 +211,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
@@ -260,6 +255,17 @@ 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 $
@@ -277,14 +283,15 @@ deletePageFromRepository repos name
                 return NoContent
            else
              return NotFound
-    where
-      deleteEmptyParentDirectories :: FilePath -> Txn ()
-      deleteEmptyParentDirectories path
-          = do let parentPath = takeDirectory path
-               contents <- getDirEntries parentPath
-               when (null contents)
-                        $ do deleteEntry parentPath
-                             deleteEmptyParentDirectories parentPath
+
+
+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