diff --git a/HsSVN.cabal b/HsSVN.cabal --- a/HsSVN.cabal +++ b/HsSVN.cabal @@ -4,16 +4,17 @@ HsSVN is a (part of) Subversion binding for Haskell. Currently it can do most things related to the Subversion FS but others are left uncovered. -Version: 0.2 +Version: 0.3 License: PublicDomain License-File: COPYING -Author: PHO -Maintainer: PHO +Author: PHO +Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/HsSVN/ Category: System Tested-With: GHC == 6.8.1 Cabal-Version: >= 1.2 +Build-Type: Configure Extra-Source-Files: HsSVN.buildinfo.in @@ -26,7 +27,7 @@ Library Build-Depends: - base, bytestring, mtl + base, bytestring, mtl, stm Exposed-Modules: Subversion Subversion.Config @@ -43,11 +44,13 @@ Subversion.Hash Subversion.Pool Subversion.Stream + Subversion.Stream.Pipe Subversion.String Extensions: - EmptyDataDecls, ForeignFunctionInterface, TypeSynonymInstances + EmptyDataDecls, DeriveDataTypeable, ForeignFunctionInterface, + TypeSynonymInstances GHC-Options: - -Wall -XDeriveDataTypeable + -Wall C-Sources: cbits/HsSVN.c Include-Dirs: diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,16 @@ +Changes from 0.2 to 0.3 +-------------------------------------- +* Subversion.Repository: + - Added new function: dumpRepository + +* Subversion.FileSystem.Revision: + - Added new function: getRevisionNumber + - Renamed function: getRevisionProp ==> getRevisionProp' + - Renamed function: getRevisionPropList ==> getRevisionPropList' + - Added new function: getRevisionProp + - Added new function: getRevisionPropList + + Changes from 0.1 to 0.2 ----------------------- * HsSVN now requires GHC 6.8.1 diff --git a/Subversion/FileSystem/Revision.hs b/Subversion/FileSystem/Revision.hs deleted file mode 100644 --- a/Subversion/FileSystem/Revision.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# OPTIONS_GHC -optc-DDARWIN #-} -{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-} -{-# LINE 1 "Subversion/FileSystem/Revision.hsc" #-} -{- -*- haskell -*- -} -{-# LINE 2 "Subversion/FileSystem/Revision.hsc" #-} - --- |An interface to functions that work on an existing --- (i.e. read-only) revision in a filesystem. - -module Subversion.FileSystem.Revision - ( -- * Type - Rev - - -- * Running the monad - , withRevision - - -- * Accessing revision property - , getRevisionProp - , getRevisionPropList - , setRevisionProp - - -- * Getting node history - , getNodeHistory - ) - where - -import Control.Monad.Reader -import qualified Data.ByteString.Char8 as B8 -import Foreign.C.String -import Foreign.Storable -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Subversion.Error -import Subversion.FileSystem -import Subversion.FileSystem.Root -import Subversion.Hash -import Subversion.Pool -import Subversion.String -import Subversion.Types -import System.IO.Unsafe - - -{- Monad Rev ----------------------------------------------------------------- -} - --- |@'Rev' a@ is a FS monad which reads data from an existing revision --- and finally returns @a@. See 'Subversion.FileSystem.Root.MonadFS'. --- --- Since 'Rev' monad does no transactions, --- 'Subversion.FileSystem.Root.unsafeIOToFS' isn't really unsafe. You --- can do any I\/O actions in the monad if you wish. -newtype Rev a = Rev { unRev :: ReaderT FileSystemRoot IO a } - -instance Functor Rev where - fmap f c = Rev (fmap f (unRev c)) - -instance Monad Rev where - c >>= f = Rev (unRev c >>= unRev . f) - return = Rev . return - fail = Rev . fail - -instance MonadFS Rev where - getRoot = Rev ask - unsafeIOToFS a = Rev (liftIO a) - isTransaction = Rev (return False) - - -{- functions and types ------------------------------------------------------- -} - -data SVN_FS_HISTORY_T - - -foreign import ccall unsafe "svn_fs_revision_root" - _revision_root :: Ptr (Ptr SVN_FS_ROOT_T) -> Ptr SVN_FS_T -> SVN_REVNUM_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_revision_prop" - _revision_prop :: Ptr (Ptr SVN_STRING_T) -> Ptr SVN_FS_T -> SVN_REVNUM_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_revision_proplist" - _revision_proplist :: Ptr (Ptr APR_HASH_T) -> Ptr SVN_FS_T -> SVN_REVNUM_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_change_rev_prop" - _change_rev_prop :: Ptr SVN_FS_T -> SVN_REVNUM_T -> CString -> Ptr SVN_STRING_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_node_history" - _node_history :: Ptr (Ptr SVN_FS_HISTORY_T) -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_history_prev" - _history_prev :: Ptr (Ptr SVN_FS_HISTORY_T) -> Ptr SVN_FS_HISTORY_T -> SVN_BOOLEAN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - -foreign import ccall unsafe "svn_fs_history_location" - _history_location :: Ptr CString -> Ptr SVN_REVNUM_T -> Ptr SVN_FS_HISTORY_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) - - -getRevisionRoot :: FileSystem -> Int -> IO FileSystemRoot -getRevisionRoot fs revNum - = do pool <- newPool - alloca $ \ rootPtrPtr -> - withFSPtr fs $ \ fsPtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _revision_root rootPtrPtr fsPtr (fromIntegral revNum) poolPtr - -- root は pool にも fs にも依存する。 - wrapFSRoot (touchPool pool >> touchFS fs) - =<< peek rootPtrPtr - --- |@'withRevision'@ runs a 'Rev' monad in an IO monad. -withRevision :: FileSystem -> RevNum -> Rev a -> IO a -withRevision fs revNum c - = getRevisionRoot fs revNum - >>= runReaderT (unRev c) - --- |@'getRevisionProp' fs revNum propName@ returns the value of the --- property named @propName@ on revision @revNum@ in the filesystem --- @fs@. -getRevisionProp :: FileSystem -> RevNum -> String -> IO (Maybe String) -getRevisionProp fs revNum name - = do pool <- newPool - alloca $ \ valPtrPtr -> - withFSPtr fs $ \ fsPtr -> - withCString name $ \ namePtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _revision_prop valPtrPtr fsPtr (fromIntegral revNum) namePtr poolPtr - prop <- peekSvnString' =<< peek valPtrPtr - -- prop は pool の中から讀み取られるので、それが濟むま - -- で pool が死んでは困る。 - touchPool pool - return $ fmap B8.unpack prop - --- |@'getRevisionPropList' fs revNum@ returns the entire property list --- of revision @revNum@ in filesystem @fs@. -getRevisionPropList :: FileSystem -> RevNum -> IO [(String, String)] -getRevisionPropList fs revNum - = do pool <- newPool - alloca $ \ hashPtrPtr -> - withFSPtr fs $ \ fsPtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _revision_proplist hashPtrPtr fsPtr (fromIntegral revNum) poolPtr - hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr - mapHash' (\ (n, v) - -> peekSvnString v - >>= - return . ((,) n) . B8.unpack) hash - --- |@'setRevisionProp'@ changes, adds or deletes a property on a --- revision. Note that revision properties are non-historied: you can --- change them after the revision has been comitted. They are not --- protected via transactions. -setRevisionProp :: FileSystem -- ^ The transaction - -> RevNum -- ^ The revision - -> String -- ^ The property name - -> Maybe String -- ^ The property value - -> IO () -setRevisionProp fs revNum name valStr - = do pool <- newPool - let value = fmap B8.pack valStr - withFSPtr fs $ \ fsPtr -> - withCString name $ \ namePtr -> - withSvnString' value $ \ valuePtr -> - withPoolPtr pool $ \ poolPtr -> - svnErr $ _change_rev_prop fsPtr (fromIntegral revNum) namePtr valuePtr poolPtr - --- |@'getNodeHistory'@ /lazily/ reads the change history of given node --- in a filesystem. The most recent change comes first in the --- resulting list. --- --- The revisions returned for a path will be older than or the same --- age as the revision of that path in the target revision of 'Rev' --- monad. That is, if the 'Rev' monad is running on revision @X@, and --- the path was modified in some revisions younger than @X@, those --- revisions younger than @X@ will not be included for the path. -getNodeHistory - :: Bool -- ^ If this is true, stepping - -- backwards in history would cross - -- a copy operation. This is usually - -- the desired behavior. - -> FilePath -- ^ The path to node you want to read - -- history. - -> Rev [(RevNum, FilePath)] -- ^ A list of @(revNum, nodePath)@: - -- the node was modified somehow at - -- revision @revNum@, and at that - -- time the node was located on - -- @nodePath@. -getNodeHistory crossCopies path - = do pool <- unsafeIOToFS $ newPool - root <- getRoot - unsafeIOToFS $ alloca $ \ histPtrPtr -> - withFSRootPtr root $ \ rootPtr -> - withCString path $ \ pathPtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _node_history histPtrPtr rootPtr pathPtr poolPtr - lazyReadHist pool =<< peek histPtrPtr - where - lazyReadHist pool histPtr = unsafeInterleaveIO $ readHist pool histPtr - - readHist :: Pool -> Ptr SVN_FS_HISTORY_T -> IO [(RevNum, FilePath)] - readHist pool histPtr - = alloca $ \ histPtrPtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _history_prev histPtrPtr histPtr (marshalBool crossCopies) poolPtr - got <- peek histPtrPtr - - if got == nullPtr then - -- ヒストリの終端に達した。これ以後、Pool は解放され - -- ても構はない。 - touchPool pool >> return [] - else - do x <- getHistLocation got pool - xs <- lazyReadHist pool got - return (x:xs) - - getHistLocation :: Ptr SVN_FS_HISTORY_T -> Pool -> IO (RevNum, FilePath) - getHistLocation histPtr pool - = alloca $ \ pathPtrPtr -> - alloca $ \ revNumPtr -> - withPoolPtr pool $ \ poolPtr -> - do svnErr $ _history_location pathPtrPtr revNumPtr histPtr poolPtr - revNum <- return . fromIntegral =<< peek revNumPtr - path <- peekCString =<< peek pathPtrPtr - return (revNum, path) diff --git a/Subversion/FileSystem/Revision.hsc b/Subversion/FileSystem/Revision.hsc --- a/Subversion/FileSystem/Revision.hsc +++ b/Subversion/FileSystem/Revision.hsc @@ -10,9 +10,14 @@ -- * Running the monad , withRevision + -- * Getting revision info + , getRevisionNumber + -- * Accessing revision property , getRevisionProp + , getRevisionProp' , getRevisionPropList + , getRevisionPropList' , setRevisionProp -- * Getting node history @@ -68,6 +73,9 @@ foreign import ccall unsafe "svn_fs_revision_root" _revision_root :: Ptr (Ptr SVN_FS_ROOT_T) -> Ptr SVN_FS_T -> SVN_REVNUM_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) +foreign import ccall unsafe "svn_fs_revision_root_revision" + _revision_root_revision :: Ptr SVN_FS_ROOT_T -> IO SVN_REVNUM_T + foreign import ccall unsafe "svn_fs_revision_prop" _revision_prop :: Ptr (Ptr SVN_STRING_T) -> Ptr SVN_FS_T -> SVN_REVNUM_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) @@ -104,11 +112,27 @@ = getRevisionRoot fs revNum >>= runReaderT (unRev c) --- |@'getRevisionProp' fs revNum propName@ returns the value of the --- property named @propName@ on revision @revNum@ in the filesystem --- @fs@. -getRevisionProp :: FileSystem -> RevNum -> String -> IO (Maybe String) -getRevisionProp fs revNum name +-- |Return the revision number. +getRevisionNumber :: Rev RevNum +getRevisionNumber + = do root <- getRoot + unsafeIOToFS $ withFSRootPtr root $ \ rootPtr -> + _revision_root_revision rootPtr + >>= return . fromIntegral + +-- |@'getRevisionProp' propName@ returns the value of the property +-- named @propName@ of the revision. +getRevisionProp :: String -> Rev (Maybe String) +getRevisionProp name + = do root <- getRoot + fs <- unsafeIOToFS $ getRootFS root + revNum <- getRevisionNumber + unsafeIOToFS $ getRevisionProp' fs revNum name + +-- |@'getRevisionProp'' fs revNum propName@ returns the value of the +-- property named @propName@ of revision @revNum@ of filesystem @fs@. +getRevisionProp' :: FileSystem -> RevNum -> String -> IO (Maybe String) +getRevisionProp' fs revNum name = do pool <- newPool alloca $ \ valPtrPtr -> withFSPtr fs $ \ fsPtr -> @@ -121,10 +145,17 @@ touchPool pool return $ fmap B8.unpack prop --- |@'getRevisionPropList' fs revNum@ returns the entire property list --- of revision @revNum@ in filesystem @fs@. -getRevisionPropList :: FileSystem -> RevNum -> IO [(String, String)] -getRevisionPropList fs revNum +-- |Return the entire property list of the revision. +getRevisionPropList :: Rev [(String, String)] +getRevisionPropList + = do root <- getRoot + fs <- unsafeIOToFS $ getRootFS root + revNum <- getRevisionNumber + unsafeIOToFS $ getRevisionPropList' fs revNum + +-- |Return the entire property list of a revision. +getRevisionPropList' :: FileSystem -> RevNum -> IO [(String, String)] +getRevisionPropList' fs revNum = do pool <- newPool alloca $ \ hashPtrPtr -> withFSPtr fs $ \ fsPtr -> @@ -136,10 +167,10 @@ >>= return . ((,) n) . B8.unpack) hash --- |@'setRevisionProp'@ changes, adds or deletes a property on a --- revision. Note that revision properties are non-historied: you can --- change them after the revision has been comitted. They are not --- protected via transactions. +-- |Change, add or delete a property on a revision. Note that revision +-- properties are non-historied: you can change them after the +-- revision has been comitted. They are not protected via +-- transactions. setRevisionProp :: FileSystem -- ^ The transaction -> RevNum -- ^ The revision -> String -- ^ The property name @@ -158,11 +189,11 @@ -- in a filesystem. The most recent change comes first in the -- resulting list. -- --- The revisions returned for a path will be older than or the same --- age as the revision of that path in the target revision of 'Rev' +-- Revisions in the resulting list will be older than or the same age +-- as the revision of that node in the target revision of 'Rev' -- monad. That is, if the 'Rev' monad is running on revision @X@, and --- the path was modified in some revisions younger than @X@, those --- revisions younger than @X@ will not be included for the path. +-- the node was modified in some revisions younger than @X@, those +-- revisions younger than @X@ will not be included in the list. getNodeHistory :: Bool -- ^ If this is true, stepping -- backwards in history would cross @@ -176,7 +207,7 @@ -- time the node was located on -- @nodePath@. getNodeHistory crossCopies path - = do pool <- unsafeIOToFS $ newPool + = do pool <- unsafeIOToFS newPool root <- getRoot unsafeIOToFS $ alloca $ \ histPtrPtr -> withFSRootPtr root $ \ rootPtr -> diff --git a/Subversion/Repository.hs b/Subversion/Repository.hs deleted file mode 100644 --- a/Subversion/Repository.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# OPTIONS_GHC -optc-DDARWIN #-} -{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-} -{-# LINE 1 "Subversion/Repository.hsc" #-} -{- -*- haskell -*- -} -{-# LINE 2 "Subversion/Repository.hsc" #-} - --- |An interface to repository, which is built on top of the --- filesystem. - -module Subversion.Repository - ( Repository - - , openRepository - , createRepository - , deleteRepository - - , getRepositoryFS - - , doReposTxn - ) - where - -import Control.Exception -import Control.Monad -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.Types - --- |@'Repository'@ is an opaque object representing a Subversion --- repository. -newtype Repository = Repository (ForeignPtr SVN_REPOS_T) -data SVN_REPOS_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) - - -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 - - -- config と fsConfig には、repos が死ぬまでは生き - -- てゐて慾しい。 - 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* より先に 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 は pool にも 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 - throwSvnErr 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 -> Exception -> 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 diff --git a/Subversion/Repository.hsc b/Subversion/Repository.hsc --- a/Subversion/Repository.hsc +++ b/Subversion/Repository.hsc @@ -3,6 +3,8 @@ -- |An interface to repository, which is built on top of the -- filesystem. +#include "HsSVN.h" + module Subversion.Repository ( Repository @@ -13,11 +15,15 @@ , 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 @@ -25,13 +31,15 @@ import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Storable -import GHC.ForeignPtr as GF +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 @@ -40,6 +48,9 @@ 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) @@ -58,7 +69,20 @@ 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 @@ -232,3 +256,54 @@ -- 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. +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 diff --git a/Subversion/Stream.hsc b/Subversion/Stream.hsc --- a/Subversion/Stream.hsc +++ b/Subversion/Stream.hsc @@ -2,9 +2,15 @@ ( Stream , SVN_STREAM_T + , ReadAction + , WriteAction + , CloseAction + , StreamActions(..) + , wrapStream , withStreamPtr + , newStream , getEmptyStream , getStreamForStdOut @@ -30,10 +36,12 @@ import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.ByteString.Internal hiding (ByteString) import Data.ByteString.Unsafe +import Foreign.C.String import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Marshal.Alloc +import Foreign.Marshal.Array import Foreign.Storable import GHC.ForeignPtr as GF import Subversion.Error @@ -46,22 +54,61 @@ data SVN_STREAM_T +type ReadAction = Int -> IO Strict.ByteString +type WriteAction = Strict.ByteString -> IO Int +type CloseAction = IO () + + +data StreamActions + = StreamActions { + saRead :: !ReadAction + , saWrite :: !WriteAction + , saClose :: !CloseAction + } + + +type ReadCallback = Ptr () -> CString -> Ptr APR_SIZE_T -> IO (Ptr SVN_ERROR_T) +type WriteCallback = Ptr () -> CString -> Ptr APR_SIZE_T -> IO (Ptr SVN_ERROR_T) +type CloseCallback = Ptr () -> IO (Ptr SVN_ERROR_T) + + +foreign import ccall unsafe "svn_stream_create" + _create :: Ptr () -> Ptr APR_POOL_T -> IO (Ptr SVN_STREAM_T) + +foreign import ccall unsafe "svn_stream_set_read" + _set_read :: Ptr SVN_STREAM_T -> FunPtr ReadCallback -> IO () + +foreign import ccall unsafe "svn_stream_set_write" + _set_write :: Ptr SVN_STREAM_T -> FunPtr WriteCallback -> IO () + +foreign import ccall unsafe "svn_stream_set_close" + _set_close :: Ptr SVN_STREAM_T -> FunPtr CloseCallback -> IO () + foreign import ccall unsafe "svn_stream_empty" _empty :: Ptr APR_POOL_T -> IO (Ptr SVN_STREAM_T) foreign import ccall unsafe "svn_stream_for_stdout" _for_stdout :: Ptr (Ptr SVN_STREAM_T) -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T) -foreign import ccall unsafe "svn_stream_read" +foreign import ccall safe "svn_stream_read" _read :: Ptr SVN_STREAM_T -> Ptr CChar -> Ptr APR_SIZE_T -> IO (Ptr SVN_ERROR_T) -foreign import ccall unsafe "svn_stream_write" +foreign import ccall safe "svn_stream_write" _write :: Ptr SVN_STREAM_T -> Ptr CChar -> Ptr APR_SIZE_T -> IO (Ptr SVN_ERROR_T) -foreign import ccall unsafe "svn_stream_close" +foreign import ccall safe "svn_stream_close" _close :: Ptr SVN_STREAM_T -> IO (Ptr SVN_ERROR_T) +foreign import ccall "wrapper" + mkReadCallback :: ReadCallback -> IO (FunPtr ReadCallback) +foreign import ccall "wrapper" + mkWriteCallback :: WriteCallback -> IO (FunPtr WriteCallback) + +foreign import ccall "wrapper" + mkCloseCallback :: CloseCallback -> IO (FunPtr CloseCallback) + + wrapStream :: IO () -> Ptr SVN_STREAM_T -> IO Stream wrapStream finalizer ioPtr = do io <- newForeignPtr_ ioPtr @@ -73,6 +120,54 @@ withStreamPtr (Stream io) = withForeignPtr io +newStream :: StreamActions -> IO Stream +newStream actions + = do pool <- newPool + withPoolPtr pool $ \ poolPtr -> + do streamPtr <- _create nullPtr poolPtr + + readFnPtr <- mkReadFnPtr (saRead actions) + writeFnPtr <- mkWriteFnPtr (saWrite actions) + closeFnPtr <- mkCloseFnPtr (saClose actions) + + _set_read streamPtr readFnPtr + _set_write streamPtr writeFnPtr + _set_close streamPtr closeFnPtr + + wrapStream (do freeHaskellFunPtr readFnPtr + freeHaskellFunPtr writeFnPtr + freeHaskellFunPtr closeFnPtr + touchPool pool + ) streamPtr + where + mkReadFnPtr :: ReadAction -> IO (FunPtr ReadCallback) + mkReadFnPtr ra + = mkReadCallback $ \ _ bufPtr lenPtr -> + do requestedLen <- liftM fromIntegral (peek lenPtr) + resultStr <- ra requestedLen -- FIXME: 例外を catch すべき + B8.useAsCStringLen resultStr $ \ (resultPtr, resultLen) -> + do when (resultLen > requestedLen) + $ fail "resultLen > requestedLen" -- FIXME + copyArray bufPtr resultPtr resultLen + poke lenPtr (fromIntegral resultLen) + return nullPtr + + mkWriteFnPtr :: WriteAction -> IO (FunPtr WriteCallback) + mkWriteFnPtr wa + = mkWriteCallback $ \ _ bufPtr lenPtr -> + do requestedLen <- liftM fromIntegral (peek lenPtr) + inputStr <- B8.packCStringLen (bufPtr, requestedLen) + writtenLen <- wa inputStr -- FIXME: 例外を catch すべき + poke lenPtr (fromIntegral writtenLen) + return nullPtr + + mkCloseFnPtr :: CloseAction -> IO (FunPtr CloseCallback) + mkCloseFnPtr ca + = mkCloseCallback $ \ _ -> + do ca -- FIXME: 例外を catch すべき + return nullPtr + + getEmptyStream :: IO Stream getEmptyStream = do pool <- newPool @@ -130,15 +225,13 @@ where chunkSize = 32 * 1024 - strictRead = unsafeInterleaveIO loop - - loop = do bs <- sReadBS io chunkSize - if B8.null bs then - -- reached EOF - return [] - else - do bss <- strictRead - return (bs:bss) + strictRead = do bs <- sReadBS io chunkSize + if B8.null bs then + -- reached EOF + return [] + else + do bss <- strictRead + return (bs:bss) diff --git a/Subversion/Stream/Pipe.hs b/Subversion/Stream/Pipe.hs new file mode 100644 --- /dev/null +++ b/Subversion/Stream/Pipe.hs @@ -0,0 +1,98 @@ +module Subversion.Stream.Pipe + ( newPipe + ) + where + +import Control.Concurrent.STM +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Subversion.Stream + + +data Pipe + = Pipe { + pReadRequest :: TVar Int -- 讀込み側が要求し、未だ書込まれてゐないバイト數 + , pWrittenStr :: TVar Lazy.ByteString -- 要求に應へて書込まれ、未だ讀込まれてゐない文字列 + , pIsClosed :: TVar Bool -- パイプが閉ぢられた + } + + +newPipe :: IO Stream +newPipe = do req <- newTVarIO 0 + str <- newTVarIO Lazy.empty + isC <- newTVarIO False + + let pipe = Pipe { + pReadRequest = req + , pWrittenStr = str + , pIsClosed = isC + } + actions = StreamActions { + saRead = mkReadAction pipe + , saWrite = mkWriteAction pipe + , saClose = mkCloseAction pipe + } + + newStream actions + + +mkReadAction :: Pipe -> ReadAction +mkReadAction pipe reqLen + = do nextAction <- tryToRead True + nextAction + where + tryToRead :: Bool -> IO (IO Strict.ByteString) + tryToRead writeRequestIfNeeded + = atomically $ + do str <- readTVar (pWrittenStr pipe) + if Lazy.null str then + -- 書込まれた文字列が無いので、要求されたバイト數を + -- パイプに書いて書込みを待つ。但しパイプが閉ぢられ + -- てゐたら空文字列を返して EOF を示す。 + do isClosed <- readTVar (pIsClosed pipe) + if isClosed then + return (return Strict.empty) + else + -- 要求バイト數を書き込むのは一度だけ。 + if writeRequestIfNeeded then + do writeTVar (pReadRequest pipe) reqLen + return $ do nextAction <- tryToRead False + nextAction + else + retry + else + -- reqLen バイトを上限としてバッファの頭を切り取る。 + do let (readStr, remaining) = Lazy.splitAt (fromIntegral reqLen) str + writeTVar (pWrittenStr pipe) remaining + return (return (Strict.concat (Lazy.toChunks readStr))) + + +mkWriteAction :: Pipe -> WriteAction +mkWriteAction pipe str + = atomically $ + do let inputLen = Strict.length str + isClosed <- readTVar (pIsClosed pipe) + if isClosed then + -- パイプが閉ぢられてゐたら書込まれた文字列を捨てる + -- FIXME: 本當にそれで良いのか？ + return inputLen + else + do requestedBytes <- readTVar (pReadRequest pipe) + writtenStr <- readTVar (pWrittenStr pipe) + let maxBytesToWrite = requestedBytes - (fromIntegral $ Lazy.length writtenStr) + if maxBytesToWrite > 0 then + -- 要求されてゐるので書込む + do let strToWrite = Strict.take maxBytesToWrite str + bytesToWrite = Strict.length strToWrite + writeTVar (pReadRequest pipe) (requestedBytes - bytesToWrite) + writeTVar (pWrittenStr pipe) (writtenStr `Lazy.append` (Lazy.fromChunks [strToWrite])) + return bytesToWrite + else + -- 要求されてゐないので retry + retry + + +mkCloseAction :: Pipe -> CloseAction +mkCloseAction pipe + = atomically $ + writeTVar (pIsClosed pipe) True diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,3 +1,4 @@ +import qualified Data.ByteString.Lazy as Lazy import Subversion import Subversion.Repository import Subversion.FileSystem @@ -26,7 +27,11 @@ content <- withRevision fs newRev $ getFileContents "/hello" putStrLn ("-------------\n" ++ content ++ "\n-------------") - + + + putStrLn "Writing the whole content of repository to `repository.dump'..." + dumpRepository repos Nothing Nothing True True >>= Lazy.writeFile "repository.dump" + putStrLn "Deleting the repository..." deleteRepository "repos"