we can now create new pages

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

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index 81ab87611b68a51422aabb22e60fb7ea5fe30e83..0b53568b4290e9b0d433d71a291fbf1fec9b35d1 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -6,6 +6,7 @@ module Rakka.Storage.Repos
     )
     where
 
+import           Control.Exception
 import           Control.Monad
 import           Data.List
 import qualified Data.Map as M
@@ -18,19 +19,20 @@ import           Rakka.Page
 import           Rakka.SystemConfig
 import           Rakka.Utils
 import           Rakka.W3CDateTime
-import           Subversion.Types
+import           Subversion.Error
 import           Subversion.FileSystem
 import           Subversion.FileSystem.DirEntry
 import           Subversion.FileSystem.Revision
 import           Subversion.FileSystem.Root
 import           Subversion.FileSystem.Transaction
 import           Subversion.Repository
+import           Subversion.Types
 import           System.FilePath.Posix
 
 
 mkPagePath :: PageName -> FilePath
 mkPagePath name
-    = "pages" </> encodePageName name <.> "page"
+    = "/pages" </> encodePageName name <.> "page"
 
 
 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
@@ -151,44 +153,49 @@ loadPageInRepository repos name rev
 
 putPageIntoRepository :: Repository -> Page -> IO StatusCode
 putPageIntoRepository repos page
-    = do let Just ui = pageUpdateInfo page
-             name    = pageName page
-         ret <- doReposTxn
-                repos
-                (uiOldRevision ui)
-                "[Rakka]"
-                (Just "Automatic commit by Rakka for page updating")
-                $ do case uiOldName ui of
-                       Nothing      -> return ()
-                       Just oldName -> renamePage oldName name
-                     createPageIfNeeded name
-                     updatePage name
+    = 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
+           Left  _ -> return Conflict
+           Right _ -> return Created
     where
       renamePage :: PageName -> PageName -> Txn ()
       renamePage oldName newName
           = fail "FIXME: renamePage: not implemented yet"
 
-      createPageIfNeeded :: PageName -> Txn ()
-      createPageIfNeeded name
+      createPage :: PageName -> Txn ()
+      createPage name
           = do let path = mkPagePath name
-               kind <- checkPath path
-               case kind of
-                 NoNode   -> do createParentDirectories path
-                                makeFile path
-                 FileNode -> return ()
-                 DirNode  -> fail ("createPageIfNeeded: already exists a directory: " ++ path)
+               createParentDirectories path
+               makeFile path
 
       createParentDirectories :: FilePath -> Txn ()
       createParentDirectories path
           = do let parentPath = takeDirectory path
                kind <- checkPath parentPath
                case kind of
-                 NoNode   -> createParentDirectories parentPath
+                 NoNode   -> do createParentDirectories parentPath
+                                makeDirectory parentPath
                  FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
                  DirNode  -> return ()
 
@@ -225,3 +232,14 @@ putPageIntoRepository repos page
       encodeFlag :: Bool -> Maybe String
       encodeFlag True  = Just "*\n"
       encodeFlag False = Nothing
+
+
+filterSvnError :: IO a -> IO a
+filterSvnError f = catchDyn f rethrow
+    where
+      rethrow :: SvnError -> IO a
+      rethrow err
+          = let code = svnErrCode err
+                msg  = svnErrMsg  err
+            in
+              fail $ "SvnError: " ++ (show code) ++ ": " ++ msg