HsSVN 0.2 → 0.3
raw patch · 9 files changed
+356/−496 lines, 9 filesdep +stm
Dependencies added: stm
Files
- HsSVN.cabal +9/−6
- NEWS +13/−0
- Subversion/FileSystem/Revision.hs +0/−219
- Subversion/FileSystem/Revision.hsc +49/−18
- Subversion/Repository.hs +0/−239
- Subversion/Repository.hsc +76/−1
- Subversion/Stream.hsc +105/−12
- Subversion/Stream/Pipe.hs +98/−0
- examples/HelloWorld.hs +6/−1
HsSVN.cabal view
@@ -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 <phonohawk at ps dot sakura dot ne dot jp>-Maintainer: PHO <phonohawk at ps dot sakura dot ne dot jp>+Author: PHO <pho at cielonegro dot org>+Maintainer: PHO <pho at cielonegro dot org> 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:
NEWS view
@@ -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
− Subversion/FileSystem/Revision.hs
@@ -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)
Subversion/FileSystem/Revision.hsc view
@@ -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 ->
− Subversion/Repository.hs
@@ -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
Subversion/Repository.hsc view
@@ -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
Subversion/Stream.hsc view
@@ -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)
+ Subversion/Stream/Pipe.hs view
@@ -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
examples/HelloWorld.hs view
@@ -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"