module Rakka.Storage.Repos
( findAllPagesInRevision
+ , getDirContentsInRevision
, findChangedPagesAtRevision
, loadPageInRepository
, putPageIntoRepository
+ , deletePageFromRepository
+ , loadAttachmentInRepository
+ , putAttachmentIntoRepository
)
where
import Codec.Binary.UTF8.String
-import Control.Exception
import Control.Monad
import Data.List
import qualified Data.Map as M
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
import Rakka.W3CDateTime
-import Subversion.Error
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
= "/pages" </> encodePageName name <.> "page"
+mkDirPath :: PageName -> FilePath
+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
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
decodePath = decodePageName . makeRelative root . dropExtension
+getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
+getDirContentsInRevision repos dir rev
+ = do fs <- getRepositoryFS repos
+ rev' <- case rev of
+ Nothing -> getYoungestRev fs
+ Just r -> return r
+ withRevision fs rev'
+ $ do exists <- isDirectory path
+ if exists then
+ return . S.fromList =<< getDir'
+ else
+ return S.empty
+ where
+ path :: FilePath
+ path = mkDirPath dir
+
+ getDir' :: Rev [PageName]
+ getDir' = liftM (map entToName) (getDirEntries path)
+
+ entToName :: DirEntry -> PageName
+ entToName = (dir </>) . decodePageName . dropExtension . entName
+
+
findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
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
Just r -> return r
withRevision fs rev'
$ do exists <- isFile path
- case exists of
- True
- -> return . Just =<< loadPage'
- False
- -> return Nothing
+ if exists then
+ 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
+ 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 :: Rev Page
- loadPageEntity
+ 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
, entityType = mimeType
, entityLanguage = fmap chomp (lookup "rakka:lang" props)
- , entityFileName = fmap chomp (lookup "rakka:fileName" props)
, entityIsTheme = any ((== "rakka:isTheme") . fst) props
, entityIsFeed = any ((== "rakka:isFeed") . fst) props
, entityIsLocked = any ((== "rakka:isLocked") . fst) props
- , entityIsBoring = any ((== "rakka:isBoring") . fst) props
, entityIsBinary = case mimeType of
MIMEType "text" _ _
-> any ((== "rakka:isBinary") . fst) props
-> 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 <- liftM isJust (getNodeProp path "rakka:isLocked")
return Redirection {
redirName = name
, redirDest = dest
+ , redirIsLocked = isLocked
, redirRevision = pageRev
, redirLastMod = zonedTimeToUTC lastMod
, redirUpdateInfo = undefined
}
-putPageIntoRepository :: Repository -> Page -> IO StatusCode
-putPageIntoRepository repos page
- = 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
+putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
+putPageIntoRepository repos userID page
+ = do let name = pageName page
+ author = fromMaybe "[Rakka]" userID
+ case pageUpdateInfo page of
+ Just ui
+ -> do let oldRev = uiOldRevision ui
+ denied <- case uiOldName ui of
+ Nothing -> checkDenial oldRev name
+ Just oldName -> checkDenial oldRev oldName
+ if denied then
+ return Forbidden
+ else
+ do rev <- if oldRev == 0 then
+ getRepositoryFS repos >>= getYoungestRev
+ else
+ return oldRev
+ ret <- doReposTxn
+ repos
+ rev
+ author
+ (Just "Automatic commit by Rakka for page update")
+ $ do
+ case uiOldName ui of
+ Nothing -> return ()
+ 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
+ Right _ -> return Created
+ Nothing
+ -> do fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ ret <- doReposTxn
+ repos
+ rev
+ author
+ (Just "Automatic commit by Rakka for page creation")
+ $ do createPage name
+ updatePage name
+ case ret of
+ Left _ -> return Conflict
+ Right _ -> return Created
where
- renamePage :: PageName -> PageName -> Txn ()
- renamePage oldName newName
- = fail "FIXME: renamePage: not implemented yet"
+ checkDenial :: RevNum -> PageName -> IO Bool
+ checkDenial rev name
+ = do fs <- getRepositoryFS repos
+ withRevision fs rev
+ $ 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
+ = do let oldPath = mkPagePath oldName
+ newPath = mkPagePath newName
+ createParentDirectories newPath
+ copyEntry oldRev oldPath newPath
+ 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
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
= do let path = mkPagePath name
setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
setNodeProp path "rakka:lang" Nothing
- setNodeProp path "rakka:fileName" Nothing
setNodeProp path "rakka:isTheme" Nothing
setNodeProp path "rakka:isFeed" Nothing
- setNodeProp path "rakka:isLocked" Nothing
- setNodeProp path "rakka:isBoring" Nothing
+ setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
setNodeProp path "rakka:isBinary" Nothing
setNodeProp path "rakka:summary" Nothing
setNodeProp path "rakka:otherLang" Nothing
= do let path = mkPagePath name
setNodeProp path "svn:mime-type" ((Just . show . entityType) page)
setNodeProp path "rakka:lang" (entityLanguage page)
- setNodeProp path "rakka:fileName" (entityFileName page)
setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page)
setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page)
setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page)
- setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring 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
encodeFlag False = Nothing
-filterSvnError :: IO a -> IO a
-filterSvnError f = catchDyn f rethrow
+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 -> Maybe String -> PageName -> IO StatusCode
+deletePageFromRepository repos userID name
+ = do let pagePath = mkPagePath name
+ attachmentPath = mkAttachmentDirPath name
+ fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ status <- withRevision fs rev
+ $ do exists <- isFile pagePath
+ if exists then
+ do prop <- getNodeProp pagePath "rakka:isLocked"
+ return $ case prop of
+ Just _
+ -> if isNothing userID then
+ -- 施錠されてゐるので匿名では駄目
+ Forbidden
+ else
+ NoContent
+ Nothing
+ -> NoContent
+ else
+ return NotFound
+ when (status == NoContent)
+ $ do doReposTxn repos
+ rev
+ "[Rakka]"
+ (Just "Automatic commit by Rakka for page deleting")
+ $ do deleteEntry pagePath
+ deleteEmptyParentDirectories pagePath
+
+ attachmentExists <- isDirectory attachmentPath
+ when attachmentExists
+ $ do deleteEntry attachmentPath
+ deleteEmptyParentDirectories attachmentPath
+ return ()
+ return status
+
+
+deleteEmptyParentDirectories :: FilePath -> Txn ()
+deleteEmptyParentDirectories path
+ = do let parentPath = takeDirectory path
+ contents <- getDirEntries parentPath
+ when (null contents)
+ $ do deleteEntry parentPath
+ 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
- rethrow :: SvnError -> IO a
- rethrow err
- = let code = svnErrCode err
- msg = svnErrMsg err
- in
- fail $ "SvnError: " ++ (show code) ++ ": " ++ msg
+ path :: FilePath
+ path = mkAttachmentPath pName aName
+
+ loadAttachment' :: Rev a
+ loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
+
+
+putAttachmentIntoRepository :: Attachment a =>
+ Repository
+ -> Maybe String
+ -> Maybe RevNum
+ -> PageName
+ -> String
+ -> a
+ -> IO StatusCode
+putAttachmentIntoRepository repos userID oldRev pName aName attachment
+ = 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
projects / Rakka.git / blobdiff