, findChangedPagesAtRevision
, loadPageInRepository
, putPageIntoRepository
+ , deletePageFromRepository
)
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.Types
+import Subversion.Error
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
import Subversion.FileSystem.Root
import Subversion.FileSystem.Transaction
import Subversion.Repository
+import Subversion.Types
import System.FilePath.Posix
mkPagePath :: PageName -> FilePath
mkPagePath name
- = "pages" </> encodePageName name <.> "page"
+ = "/pages" </> encodePageName name <.> "page"
findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
path = mkPagePath name
loadPage' :: Rev Page
- loadPage' = do redirect <- getNodeProp path "rakka:redirect"
- case redirect of
- Nothing
- -> loadPageEntity
- Just _
+ 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
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
}
loadPageRedirect :: Rev Page
- loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented"
+ loadPageRedirect
+ = 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
+
+ return Redirection {
+ redirName = name
+ , redirDest = dest
+ , redirRevision = pageRev
+ , redirLastMod = zonedTimeToUTC lastMod
+ , redirUpdateInfo = undefined
+ }
putPageIntoRepository :: Repository -> Page -> IO StatusCode
putPageIntoRepository repos page
- = do let Just ui = pageUpdateInfo page
- name = pageName page
- ret <- doReposTxn
- repos
- (uiOldRevision ui)
- "[Rakka]"
- (Just "Automatic commit by Rakka for page updating")
- $ do case uiOldName ui of
- Nothing -> return ()
- Just oldName -> renamePage oldName name
- createPageIfNeeded name
- updatePage name
+ = 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 (uiOldRevision ui) 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
+ Left _ -> return Conflict
+ Right _ -> return Created
where
- renamePage :: PageName -> PageName -> Txn ()
- renamePage oldName newName
- = fail "FIXME: renamePage: not implemented yet"
+ renamePage :: RevNum -> PageName -> PageName -> Txn ()
+ renamePage oldRev oldName newName
+ = do let oldPath = mkPagePath oldName
+ newPath = mkPagePath newName
+ createParentDirectories newPath
+ copyEntry oldRev oldPath newPath
+ deleteEntry oldPath
+ deleteEmptyParentDirectories oldPath
- createPageIfNeeded :: PageName -> Txn ()
- createPageIfNeeded name
+ createPage :: PageName -> Txn ()
+ createPage name
= do let path = mkPagePath name
- kind <- checkPath path
- case kind of
- NoNode -> do createParentDirectories path
- makeFile path
- FileNode -> return ()
- DirNode -> fail ("createPageIfNeeded: already exists a directory: " ++ path)
-
- createParentDirectories :: FilePath -> Txn ()
- createParentDirectories path
- = do let parentPath = takeDirectory path
- kind <- checkPath parentPath
- case kind of
- NoNode -> createParentDirectories parentPath
- FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
- DirNode -> return ()
+ createParentDirectories path
+ makeFile path
updatePage :: PageName -> Txn ()
updatePage name
updatePageRedirect :: PageName -> Txn ()
updatePageRedirect name
- = fail "FIXME: updatePageRedirect: not implemented yet"
+ = do let path = mkPagePath name
+ setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection")
+ setNodeProp path "rakka:lang" Nothing
+ setNodeProp path "rakka:isTheme" Nothing
+ setNodeProp path "rakka:isFeed" Nothing
+ setNodeProp path "rakka:isLocked" Nothing
+ setNodeProp path "rakka:isBinary" Nothing
+ setNodeProp path "rakka:summary" Nothing
+ setNodeProp path "rakka:otherLang" Nothing
+ applyText path Nothing (encodeString (redirDest page) ++ "\n")
updatePageEntity :: PageName -> Txn ()
updatePageEntity name
= 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:otherLang" (let otherLang = entityOtherLang page
applyTextLBS path Nothing (entityContent page)
encodeFlag :: Bool -> Maybe String
- encodeFlag True = Just "*\n"
+ encodeFlag True = Just "*"
encodeFlag False = Nothing
+
+
+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 -> PageName -> IO StatusCode
+deletePageFromRepository repos name
+ = filterSvnError $
+ do let path = mkPagePath name
+ fs <- getRepositoryFS repos
+ rev <- getYoungestRev fs
+ exists <- withRevision fs rev $ isFile path
+ if exists then
+ do doReposTxn repos
+ rev
+ "[Rakka]"
+ (Just "Automatic commit by Rakka for page deleting")
+ $ do deleteEntry path
+ deleteEmptyParentDirectories path
+ return NoContent
+ else
+ return NotFound
+
+
+deleteEmptyParentDirectories :: FilePath -> Txn ()
+deleteEmptyParentDirectories path
+ = do let parentPath = takeDirectory path
+ contents <- getDirEntries parentPath
+ when (null contents)
+ $ do deleteEntry parentPath
+ deleteEmptyParentDirectories parentPath
+
+
+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