+-- -*- coding: utf-8 -*-
module Rakka.Storage.Repos
( findAllPagesInRevision
, getDirContentsInRevision
, putAttachmentIntoRepository
)
where
-
-import Codec.Binary.UTF8.String
-import Control.Exception
import Control.Monad
import Data.List
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S hiding (Set)
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
import Rakka.Attachment
import Rakka.Page
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
-import Subversion.Error
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
traverse :: FilePath -> Rev (Set PageName)
traverse dir
- = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions
+ = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir))
traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
traverse' dir entry
path = mkDirPath dir
getDir' :: Rev [PageName]
- getDir' = getDirEntries path >>= return . map entToName
+ getDir' = liftM (map entToName) (getDirEntries path)
entToName :: DirEntry -> PageName
entToName = (dir </>) . decodePageName . dropExtension . entName
findChangedPagesAtRevision repos rev
= do fs <- getRepositoryFS repos
withRevision fs rev
- $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
+ $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged
where
accumulatePages :: Set PageName -> FilePath -> Set PageName
accumulatePages s path
$ fmap chomp (lookup "svn:mime-type" props)
lastMod <- unsafeIOToFS $
- getRevisionProp' fs pageRev "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ liftM (fromJust . W3C.parse . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
return Entity {
entityName = name
dest = chomp $ decodeString content
lastMod <- unsafeIOToFS $
- getRevisionProp' fs pageRev "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ liftM (fromJust . W3C.parse . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
- isLocked <- getNodeProp path "rakka:isLocked"
- >>= return . isJust
+ isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
return Redirection {
redirName = name
putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
putPageIntoRepository repos userID page
- = filterSvnError $
- do let name = pageName page
+ = do let name = pageName page
author = fromMaybe "[Rakka]" userID
case pageUpdateInfo page of
Just ui
case uiOldName ui of
Nothing -> return ()
Just oldName -> do exists <- isFile (mkPagePath oldName)
- when (exists)
+ when exists
$ do movePage (uiOldRevision ui) oldName name
moveAttachments (uiOldRevision ui) oldName name
exists <- isFile (mkPagePath name)
- unless (exists)
+ unless exists
$ createPage name
updatePage name
case ret of
deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode
deletePageFromRepository repos userID name
- = filterSvnError $
- do let pagePath = mkPagePath name
+ = do let pagePath = mkPagePath name
attachmentPath = mkAttachmentDirPath name
fs <- getRepositoryFS repos
rev <- getYoungestRev fs
else
return NotFound
when (status == NoContent)
- $ do doReposTxn repos
+ $ ( (doReposTxn repos
rev
"[Rakka]"
(Just "Automatic commit by Rakka for page deleting")
attachmentExists <- isDirectory attachmentPath
when attachmentExists
$ do deleteEntry attachmentPath
- deleteEmptyParentDirectories attachmentPath
- return ()
+ deleteEmptyParentDirectories attachmentPath)
+ >> return () )
return status
path = mkAttachmentPath pName aName
loadAttachment' :: Rev a
- loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString
+ loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
putAttachmentIntoRepository :: Attachment a =>
-> a
-> IO StatusCode
putAttachmentIntoRepository repos userID oldRev pName aName attachment
- = filterSvnError $
- do let author = fromMaybe "[Rakka]" userID
+ = do let author = fromMaybe "[Rakka]" userID
path = mkAttachmentPath pName aName
fs <- getRepositoryFS repos
oldRev' <- case oldRev of
unless exists
$ do createParentDirectories path
makeFile path
- applyText path Nothing (serializeToString attachment)
+ applyText path Nothing (encodeString $ serializeToString attachment)
case ret of
Left _ -> return Conflict
Right _ -> return NoContent
-
-
-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