module Rakka.Storage.Repos
( findAllPagesInRevision
+ , getDirContentsInRevision
, findChangedPagesAtRevision
, loadPageInRepository
, putPageIntoRepository
, deletePageFromRepository
+ , loadAttachmentInRepository
+ , putAttachmentIntoRepository
)
where
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
= "/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
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' = getDirEntries path >>= return . map entToName
+
+ entToName :: DirEntry -> PageName
+ entToName = (dir </>) . decodePageName . dropExtension . entName
+
+
findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
findChangedPagesAtRevision repos rev
= do fs <- getRepositoryFS repos
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'
+ else
+ return Nothing
where
path :: FilePath
path = mkPagePath name
lastMod <- getRevisionProp "svn:date"
>>= return . fromJust . parseW3CDateTime . chomp . fromJust
+ isLocked <- getRevisionProp "rakka:isLocked"
+ >>= return . isJust
+
return Redirection {
redirName = name
, redirDest = dest
+ , redirIsLocked = isLocked
, redirRevision = pageRev
, redirLastMod = zonedTimeToUTC lastMod
, redirUpdateInfo = undefined
(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
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
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
setNodeProp path "rakka:lang" Nothing
setNodeProp path "rakka:isTheme" Nothing
setNodeProp path "rakka:isFeed" Nothing
- setNodeProp path "rakka:isLocked" Nothing
+ setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page)
setNodeProp path "rakka:isBinary" Nothing
setNodeProp path "rakka:summary" Nothing
setNodeProp path "rakka:otherLang" Nothing
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
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
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
projects / Rakka.git / blobdiff