where
import Codec.Binary.UTF8.String
-import Control.Exception
import Control.Monad
import Data.List
import qualified Data.Map as M
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
withRevision fs rev'
$ do exists <- isFile path
if exists then
- return . Just =<< loadPage'
+ return . Just =<< loadPage' fs
else
return Nothing
where
path :: FilePath
path = mkPagePath name
- loadPage' :: Rev Page
- loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
- case mType of
- Just (MIMEType "application" "x-rakka-redirection" _)
- -> loadPageRedirect
- _
- -> loadPageEntity
-
- loadPageEntity :: Rev Page
- loadPageEntity
+ loadPage' :: FileSystem -> Rev Page
+ loadPage' fs
+ = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
+ case mType of
+ Just (MIMEType "application" "x-rakka-redirection" _)
+ -> loadPageRedirect fs
+ _
+ -> loadPageEntity fs
+
+ loadPageEntity :: FileSystem -> Rev Page
+ loadPageEntity fs
= do props <- getNodePropList path
hist <- getNodeHistory True path
content <- getFileContentsLBS path
$ fromMaybe "text/x-rakka"
$ fmap chomp (lookup "svn:mime-type" props)
- lastMod <- getRevisionProp "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ lastMod <- unsafeIOToFS $
+ liftM (fromJust . parseW3CDateTime . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
return Entity {
entityName = name
-> True
, entityRevision = pageRev
, entityLastMod = zonedTimeToUTC lastMod
- , entitySummary = lookup "rakka:summary" props
+ , entitySummary = fmap decodeString (lookup "rakka:summary" props)
, entityOtherLang = fromMaybe M.empty
$ fmap
- (M.fromList . fromJust . deserializeStringPairs)
+ (M.fromList . fromJust . deserializeStringPairs . decodeString)
(lookup "rakka:otherLang" props)
, entityContent = content
, entityUpdateInfo = undefined
}
- loadPageRedirect :: Rev Page
- loadPageRedirect
+ loadPageRedirect :: FileSystem -> Rev Page
+ loadPageRedirect fs
= do hist <- getNodeHistory True path
content <- getFileContents path
let pageRev = fst $ head hist
dest = chomp $ decodeString content
- lastMod <- getRevisionProp "svn:date"
- >>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ lastMod <- unsafeIOToFS $
+ liftM (fromJust . parseW3CDateTime . chomp . fromJust)
+ (getRevisionProp' fs pageRev "svn:date")
- isLocked <- getRevisionProp "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
if denied then
return Forbidden
else
- do ret <- doReposTxn
+ do rev <- if oldRev == 0 then
+ getRepositoryFS repos >>= getYoungestRev
+ else
+ return oldRev
+ ret <- doReposTxn
repos
- (uiOldRevision ui)
+ rev
author
(Just "Automatic commit by Rakka for page update")
- $ do case uiOldName ui of
+ $ do
+ case uiOldName ui of
Nothing -> return ()
- Just oldName -> movePage (uiOldRevision ui) oldName name
- >>
- moveAttachments (uiOldRevision ui) oldName name
+ Just oldName -> do exists <- isFile (mkPagePath oldName)
+ when exists
+ $ do movePage (uiOldRevision ui) oldName name
+ moveAttachments (uiOldRevision ui) oldName name
+ exists <- isFile (mkPagePath name)
+ unless exists
+ $ createPage name
updatePage name
case ret of
Left _ -> return Conflict
checkDenial rev name
= do fs <- getRepositoryFS repos
withRevision fs rev
- $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
- case prop of
- Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
- Nothing -> return False
+ $ do exists <- isFile (mkPagePath name)
+ if exists then
+ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
+ case prop of
+ Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
+ Nothing -> return False
+ else
+ return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの…
movePage :: RevNum -> PageName -> PageName -> Txn ()
movePage oldRev oldName newName
setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page)
- setNodeProp path "rakka:summary" (entitySummary page)
+ setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page)
setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
in
if M.null otherLang then
Nothing
else
- Just (serializeStringPairs $ M.toList otherLang))
+ Just (encodeString $ serializeStringPairs $ M.toList otherLang))
applyTextLBS path Nothing (entityContent page)
encodeFlag :: Bool -> Maybe String
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
path = mkAttachmentPath pName aName
loadAttachment' :: Rev a
- loadAttachment' = getFileContents path >>= return . deserializeFromString
+ 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
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
projects / Rakka.git / blobdiff