implemented things related to attachment

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

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index 01f64c7a581889321f03f26c47170cff343164b1..76889d7e0ad5fac702041a17b4bb787fe8a491a5 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -5,6 +5,8 @@ module Rakka.Storage.Repos
     , loadPageInRepository
     , putPageIntoRepository
     , deletePageFromRepository
+    , loadAttachmentInRepository
+    , putAttachmentIntoRepository
     )
     where
 
@@ -18,6 +20,7 @@ import           Data.Set (Set)
 import qualified Data.Set as S hiding (Set)
 import           Data.Time
 import           Network.HTTP.Lucu hiding (redirect)
+import           Rakka.Attachment
 import           Rakka.Page
 import           Rakka.SystemConfig
 import           Rakka.Utils
@@ -43,6 +46,16 @@ mkDirPath dir
     = "/pages" </> encodePageName dir
 
 
+mkAttachmentPath :: PageName -> String -> FilePath
+mkAttachmentPath pName aName
+    = "/attachments" </> encodePageName pName <.> "page" </> aName
+
+
+mkAttachmentDirPath :: PageName -> FilePath
+mkAttachmentDirPath pName
+    = "/attachments" </> encodePageName pName <.> "page"
+
+
 findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
 findAllPagesInRevision repos rev
     = do fs <- getRepositoryFS repos
@@ -220,7 +233,9 @@ putPageIntoRepository repos userID page
                                    (Just "Automatic commit by Rakka for page update")
                                    $ do case uiOldName ui of
                                           Nothing      -> return ()
-                                          Just oldName -> renamePage (uiOldRevision ui) oldName name
+                                          Just oldName -> movePage (uiOldRevision ui) oldName name
+                                                          >>
+                                                          moveAttachments (uiOldRevision ui) oldName name
                                         updatePage name
                             case ret of
                               Left  _ -> return Conflict
@@ -248,8 +263,8 @@ putPageIntoRepository repos userID page
                           Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
                           Nothing -> return False
 
-      renamePage :: RevNum -> PageName -> PageName -> Txn ()
-      renamePage oldRev oldName newName
+      movePage :: RevNum -> PageName -> PageName -> Txn ()
+      movePage oldRev oldName newName
           = do let oldPath = mkPagePath oldName
                    newPath = mkPagePath newName
                createParentDirectories newPath
@@ -257,6 +272,15 @@ putPageIntoRepository repos userID page
                deleteEntry oldPath
                deleteEmptyParentDirectories oldPath
 
+      moveAttachments :: RevNum -> PageName -> PageName -> Txn ()
+      moveAttachments oldRev oldName newName
+          = do let oldPath = mkAttachmentDirPath oldName
+                   newPath = mkAttachmentDirPath newName
+               createParentDirectories newPath
+               copyEntry oldRev oldPath newPath
+               deleteEntry oldPath
+               deleteEmptyParentDirectories oldPath
+
       createPage :: PageName -> Txn ()
       createPage name
           = do let path = mkPagePath name
@@ -319,13 +343,14 @@ createParentDirectories path
 deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
 deletePageFromRepository repos userID name
     = filterSvnError $
-      do let path = mkPagePath name
+      do let pagePath       = mkPagePath name
+             attachmentPath = mkAttachmentDirPath name
          fs     <- getRepositoryFS repos
          rev    <- getYoungestRev fs
          status <- withRevision fs rev
-                   $ do exists <- isFile path
+                   $ do exists <- isFile pagePath
                         if exists then
-                            do prop <- getNodeProp path "rakka:isLocked"
+                            do prop <- getNodeProp pagePath "rakka:isLocked"
                                return $ case prop of
                                           Just _
                                               -> if isNothing userID then
@@ -342,8 +367,13 @@ deletePageFromRepository repos userID name
                              rev
                              "[Rakka]"
                              (Just "Automatic commit by Rakka for page deleting")
-                             $ do deleteEntry path
-                                  deleteEmptyParentDirectories path
+                             $ do deleteEntry pagePath
+                                  deleteEmptyParentDirectories pagePath
+
+                                  attachmentExists <- isDirectory attachmentPath
+                                  when attachmentExists
+                                      $ do deleteEntry attachmentPath
+                                           deleteEmptyParentDirectories attachmentPath
                   return ()
          return status
 
@@ -357,6 +387,62 @@ deleteEmptyParentDirectories path
                        deleteEmptyParentDirectories parentPath
 
 
+loadAttachmentInRepository :: forall a. Attachment a =>
+                              Repository
+                           -> PageName
+                           -> String
+                           -> Maybe RevNum
+                           -> IO (Maybe a)
+loadAttachmentInRepository repos pName aName rev
+    = do fs   <- getRepositoryFS repos
+         rev' <- case rev of
+                   Nothing -> getYoungestRev fs
+                   Just r  -> return r
+         withRevision fs rev'
+             $ do exists <- isFile path
+                  if exists then
+                      return . Just =<< loadAttachment'
+                    else
+                      return Nothing
+    where
+      path :: FilePath
+      path = mkAttachmentPath pName aName
+
+      loadAttachment' :: Rev a
+      loadAttachment' = getFileContents path >>= return . deserializeFromString
+
+
+putAttachmentIntoRepository :: Attachment a =>
+                               Repository
+                            -> Maybe String
+                            -> Maybe RevNum
+                            -> PageName
+                            -> String
+                            -> a
+                            -> IO StatusCode
+putAttachmentIntoRepository repos userID oldRev pName aName attachment
+    = filterSvnError $
+      do let author = fromMaybe "[Rakka]" userID
+             path   = mkAttachmentPath pName aName
+         fs      <- getRepositoryFS repos
+         oldRev' <- case oldRev of
+                      Nothing -> getYoungestRev fs
+                      Just r  -> return r
+         ret <- doReposTxn
+                repos
+                oldRev'
+                author
+                (Just "Automatic commit by Rakka for putting attachment")
+                $ do exists <- isFile path
+                     unless exists
+                         $ do createParentDirectories path
+                              makeFile path
+                     applyText path Nothing (serializeToString attachment)
+         case ret of
+           Left  _ -> return Conflict
+           Right _ -> return NoContent
+
+
 filterSvnError :: IO a -> IO a
 filterSvnError f = catchDyn f rethrow
     where