HsSVN-0.4.2: Subversion/Repository.hsc
{- -*- haskell -*- -}
-- |An interface to repository, which is built on top of the
-- filesystem.
#include "HsSVN.h"
module Subversion.Repository
( Repository
, openRepository
, createRepository
, deleteRepository
, getRepositoryFS
, doReposTxn
, dumpRepository
)
where
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Data.Maybe
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import GHC.ForeignPtr as GF
import Subversion.Config
import Subversion.FileSystem
import Subversion.FileSystem.Transaction
import Subversion.Hash
import Subversion.Error
import Subversion.Pool
import Subversion.Stream
import Subversion.Stream.Pipe
import Subversion.Types
-- |@'Repository'@ is an opaque object representing a Subversion
-- repository.
newtype Repository = Repository (ForeignPtr SVN_REPOS_T)
data SVN_REPOS_T
type CancelFunc = Ptr () -> IO (Ptr SVN_ERROR_T)
foreign import ccall unsafe "svn_repos_open"
_open :: Ptr (Ptr SVN_REPOS_T) -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)
foreign import ccall unsafe "svn_repos_create"
_create :: Ptr (Ptr SVN_REPOS_T) -> CString -> Ptr CChar -> Ptr CChar -> Ptr APR_HASH_T -> Ptr APR_HASH_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)
foreign import ccall unsafe "svn_repos_delete"
_delete :: CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)
foreign import ccall unsafe "svn_repos_fs"
_fs :: Ptr SVN_REPOS_T -> IO (Ptr SVN_FS_T)
foreign import ccall unsafe "svn_repos_fs_begin_txn_for_commit"
_fs_begin_txn_for_commit :: Ptr (Ptr SVN_FS_TXN_T) -> Ptr SVN_REPOS_T -> SVN_REVNUM_T -> CString -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)
foreign import ccall unsafe "svn_repos_fs_commit_txn"
_fs_commit_txn :: Ptr CString -> Ptr SVN_REPOS_T -> Ptr SVN_REVNUM_T -> Ptr SVN_FS_TXN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)
foreign import ccall safe "svn_repos_dump_fs2"
_dump_fs2 :: Ptr SVN_REPOS_T -- repos
-> Ptr SVN_STREAM_T -- dumpstream
-> Ptr SVN_STREAM_T -- feedback_stream
-> SVN_REVNUM_T -- start_rev
-> SVN_REVNUM_T -- end_rev
-> SVN_BOOLEAN_T -- incremental
-> SVN_BOOLEAN_T -- use_deltas
-> FunPtr CancelFunc -- cancel_func
-> Ptr () -- cancel_baton
-> Ptr APR_POOL_T -- pool
-> IO (Ptr SVN_ERROR_T)
wrapRepos :: IO () -> Ptr SVN_REPOS_T -> IO Repository
wrapRepos finalizer reposPtr
= do repos <- newForeignPtr_ reposPtr
GF.addForeignPtrConcFinalizer repos finalizer
return $ Repository repos
withReposPtr :: Repository -> (Ptr SVN_REPOS_T -> IO a) -> IO a
withReposPtr (Repository repos) = withForeignPtr repos
touchRepos :: Repository -> IO ()
touchRepos (Repository repos) = touchForeignPtr repos
-- |@'openRepository' fpath@ opens a Subversion repository at @fpath@.
--
-- It acquires a shared lock on the repository, and the lock will be
-- removed by the garbage collector. If an exclusive lock is present,
-- this blocks until it's gone.
openRepository :: FilePath -> IO Repository
openRepository path
= do pool <- newPool
alloca $ \ reposPtrPtr ->
withCString path $ \ pathPtr ->
withPoolPtr pool $ \ poolPtr ->
do svnErr $ _open reposPtrPtr pathPtr poolPtr
wrapRepos (touchPool pool) =<< peek reposPtrPtr
-- |@'createRepository'@ creates a new Subversion repository, building
-- the necessary directory structure, creating filesystem, and so on.
createRepository
:: FilePath -- ^ Where to create the repository.
-> [(String, Config)] -- ^ A list of @(categoryName, config)@
-- tuples which represents a client
-- configuration. It may be an empty list.
-> [(String, String)] -- ^ This list is passed to the
-- filesystem. See
-- 'Subversion.FileSystem.createFileSystem'.
-> IO Repository
createRepository path configPairs fsConfigPairs
= do pool <- newPool
alloca $ \ reposPtrPtr ->
withCString path $ \ pathPtr ->
withPoolPtr pool $ \ poolPtr ->
do config <- pairsToHash configPairs
fsConfig <- pairsToHash fsConfigPairs
svnErr (_create
reposPtrPtr
pathPtr
nullPtr
nullPtr
(unsafeHashToPtr config)
(unsafeHashToPtr fsConfig)
poolPtr)
repos <- wrapRepos (touchPool pool) =<< peek reposPtrPtr
-- We want config and fsConfig to be alive until the repos dies.
GF.addForeignPtrConcFinalizer
(case repos of Repository x -> x)
(touchHash config >> touchHash fsConfig)
return repos
-- |@'deleteRepository' fpath@ destroys the Subversion repository at
-- @fpath@.
deleteRepository :: FilePath -> IO ()
deleteRepository path
= do pool <- newPool
withCString path $ \ pathPtr ->
withPoolPtr pool $ \ poolPtr ->
svnErr $ _delete pathPtr poolPtr
-- |@'getRepositoryFS' repos@ returns the filesystem associated with
-- repository @repos@.
getRepositoryFS :: Repository -> IO FileSystem
getRepositoryFS repos
= withReposPtr repos $ \ reposPtr ->
-- svn_fs_t* depends on svn_repos_t*.
_fs reposPtr >>= wrapFS (touchRepos repos)
beginTxn :: Repository -> RevNum -> String -> Maybe String -> IO Transaction
beginTxn repos revNum author logMsg
= do pool <- newPool
alloca $ \ txnPtrPtr ->
withReposPtr repos $ \ reposPtr ->
withCString author $ \ authorPtr ->
withCString' logMsg $ \ logMsgPtr ->
withPoolPtr pool $ \ poolPtr ->
svnErr (_fs_begin_txn_for_commit
txnPtrPtr
reposPtr
(fromIntegral revNum)
authorPtr
logMsgPtr
poolPtr)
>> peek txnPtrPtr
>>= wrapTxn
-- txn depends on both pool and repos.
(touchPool pool >> touchRepos repos)
where
withCString' :: Maybe String -> (CString -> IO a) -> IO a
withCString' Nothing f = f nullPtr
withCString' (Just str) f = withCString str f
commitTxn :: Repository -> Transaction -> IO (Either FilePath RevNum)
commitTxn repos txn
= do pool <- newPool
alloca $ \ conflictPathPtrPtr ->
withReposPtr repos $ \ reposPtr ->
alloca $ \ newRevPtr ->
withTxnPtr txn $ \ txnPtr ->
withPoolPtr pool $ \ poolPtr ->
do err <- wrapSvnError =<< _fs_commit_txn
conflictPathPtrPtr
reposPtr
newRevPtr
txnPtr
poolPtr
case err of
Nothing
-> liftM (Right . fromIntegral) (peek newRevPtr)
Just e
-> if svnErrCode e == FsConflict then
return . Left =<< peekCString =<< peek conflictPathPtrPtr
else
throwIO e
-- |@'doReposTxn'@ tries to do the transaction. If it succeeds
-- 'doReposTxn' automatically commits it, but if it throws an
-- exception 'doReposTxn' automatically cancels it and rethrow the
-- exception.
--
-- Because conflicts tend to occur more frequently than other errors,
-- they aren't reported as an exception.
doReposTxn
:: Repository -- ^ The repository.
-> RevNum -- ^ An existing revision number which the
-- transaction bases on.
-> String -- ^ The author name to be recorded as a
-- transaction property.
-> Maybe String -- ^ The log message to be recorded as a
-- transaction property. This value may be
-- 'Prelude.Nothing' if the message is not yet
-- available. The caller will need to attach one
-- to the transaction at a later time.
-> Txn () -- ^ The transaction to be done.
-> IO (Either FilePath RevNum) -- ^ The result is whether
-- @'Prelude.Left' conflictPath@
-- (if it conflicted) or
-- @'Prelude.Right' newRevNum@ (if
-- it didn't).
doReposTxn repos revNum author logMsg c
= do txn <- beginTxn repos revNum author logMsg
handle (cleanUp txn) (tryTxn txn)
where
cleanUp :: Transaction -> SomeException -> IO a
cleanUp txn exn
= abortTxn txn
>>
throwIO exn
tryTxn :: Transaction -> IO (Either FilePath Int)
tryTxn txn
= do runTxn c txn
-- Good. We've got no exceptions during the computation
-- of Txn (). Now let us commit the transaction.
commitTxn repos txn
-- |Lazily dump the contents of the filesystem within already-open
-- repository. Note that this action requires -threaded RTS.
dumpRepository :: Repository -- ^ The repository.
-> Maybe RevNum -- ^ @'Prelude.Nothing'@ to start
-- dumping at revision 0, or
-- @'Prelude.Just' x@ to begin at
-- revision @x@.
-> Maybe RevNum -- ^ @'Prelude.Nothing'@ to dump
-- through the HEAD revision, or
-- @'Prelude.Just' x@ to dump up
-- through revision @x@.
-> Bool -- ^ If this is @'Prelude.True'@, the
-- first revision dumped will be a diff
-- against the previous revision
-- (usually it looks like a full dump
-- of the tree).
-> Bool -- ^ If this is @'Prelude.True'@,
-- output only node properties which
-- have changed relative to the
-- previous contents, and output text
-- contents as svndiff data against the
-- previous contents. Regardless of how
-- this flag is set, the first revision
-- of a non-incremental dump will be
-- done with full plain text. A dump
-- with this flag set cannot be loaded
-- by Subversion 1.0.x.
-> IO Lazy.ByteString
dumpRepository repos startRev endRev incremental useDeltas
= do pool <- newPool
pipe <- newPipe
_ <- forkIO $
do withReposPtr repos $ \ reposPtr ->
withStreamPtr pipe $ \ pipePtr ->
withPoolPtr pool $ \ poolPtr ->
svnErr $ _dump_fs2 reposPtr
pipePtr
nullPtr
(fromMaybe invalidRevNum $ fmap fromIntegral startRev)
(fromMaybe invalidRevNum $ fmap fromIntegral endRev)
(marshalBool incremental)
(marshalBool useDeltas)
nullFunPtr
nullPtr
poolPtr
sClose pipe
sReadLBS pipe
where
invalidRevNum :: SVN_REVNUM_T
invalidRevNum = #const SVN_INVALID_REVNUM