HsSVN 0.1 → 0.2
raw patch · 27 files changed
+2590/−86 lines, 27 filesdep +bytestring
Dependencies added: bytestring
Files
- HsSVN.cabal +45/−51
- NEWS +3/−0
- Subversion.hs +50/−0
- Subversion/Config.hs +35/−0
- Subversion/Error.hs +151/−0
- Subversion/FileSystem.hs +271/−0
- Subversion/FileSystem/DirEntry.hs +50/−0
- Subversion/FileSystem/DirEntry.hsc +1/−1
- Subversion/FileSystem/PathChange.hs +74/−0
- Subversion/FileSystem/PathChange.hsc +2/−1
- Subversion/FileSystem/Revision.hs +219/−0
- Subversion/FileSystem/Revision.hsc +2/−2
- Subversion/FileSystem/Root.hs +339/−0
- Subversion/FileSystem/Root.hsc +5/−5
- Subversion/FileSystem/Transaction.hs +343/−0
- Subversion/FileSystem/Transaction.hsc +5/−5
- Subversion/Hash.hs +253/−0
- Subversion/Pool.hs +40/−0
- Subversion/Repository.hs +239/−0
- Subversion/Stream.hs +169/−0
- Subversion/Stream.hsc +15/−12
- Subversion/String.hs +76/−0
- Subversion/String.hsc +8/−7
- Subversion/Types.hs +130/−0
- Subversion/Types.hsc +2/−0
- configure +55/−2
- configure.ac +8/−0
HsSVN.cabal view
@@ -1,62 +1,56 @@-Name: - HsSVN-Synopsis: - (Part of) Subversion binding for Haskell+Name: HsSVN+Synopsis: (Part of) Subversion binding for Haskell Description: 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.1-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>-Stability:- experimental-Homepage: - http://ccm.sherry.jp/HsSVN/-Category: - System-Tested-With: - GHC == 6.6.1-Build-Depends:- base, mtl-Exposed-Modules:- Subversion- Subversion.Config- Subversion.FileSystem- Subversion.FileSystem.DirEntry- Subversion.FileSystem.PathChange- Subversion.FileSystem.Revision- Subversion.FileSystem.Root- Subversion.FileSystem.Transaction- Subversion.Error- Subversion.Repository- Subversion.Types-Other-Modules:- Subversion.Hash- Subversion.Pool- Subversion.Stream- Subversion.String-Extensions:- ForeignFunctionInterface, EmptyDataDecls-GHC-Options: - -fwarn-unused-imports -O3-C-Sources:- cbits/HsSVN.c-Include-Dirs:- cbits-Install-Includes:- HsSVN.h+Version: 0.2+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>+Stability: experimental+Homepage: http://ccm.sherry.jp/HsSVN/+Category: System+Tested-With: GHC == 6.8.1+Cabal-Version: >= 1.2+ Extra-Source-Files: HsSVN.buildinfo.in+ NEWS cbits/HsSVN.h configure configure.ac examples/Makefile examples/HelloWorld.hs++Library+ Build-Depends:+ base, bytestring, mtl+ Exposed-Modules:+ Subversion+ Subversion.Config+ Subversion.FileSystem+ Subversion.FileSystem.DirEntry+ Subversion.FileSystem.PathChange+ Subversion.FileSystem.Revision+ Subversion.FileSystem.Root+ Subversion.FileSystem.Transaction+ Subversion.Error+ Subversion.Repository+ Subversion.Types+ Other-Modules:+ Subversion.Hash+ Subversion.Pool+ Subversion.Stream+ Subversion.String+ Extensions:+ EmptyDataDecls, ForeignFunctionInterface, TypeSynonymInstances+ GHC-Options: + -Wall -XDeriveDataTypeable+ C-Sources:+ cbits/HsSVN.c+ Include-Dirs:+ cbits+ Install-Includes:+ HsSVN.h
+ NEWS view
@@ -0,0 +1,3 @@+Changes from 0.1 to 0.2+-----------------------+* HsSVN now requires GHC 6.8.1
+ Subversion.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion.hsc" #-}++-- |HsSVN is a (part of) Subversion binding for Haskell. Currently it+-- can do most things related to the Subversion FS but others are left+-- uncoverd.+--+-- If you find out any features you want aren't supported, you must+-- write your own patch (or take over the HsSVN project). Happy+-- hacking.+++{-# LINE 12 "Subversion.hsc" #-}++module Subversion+ ( withSubversion+ )+ where++import Control.Exception+import Subversion.Error+++foreign import ccall "HsSVN_initialize"+ _initialize :: IO Int+++-- |Computation of @'withSubversion' action@ initializes the+-- Subversion library and computes @action@. Every applications that+-- use HsSVN must wrap any operations related to Subversion with+-- 'withSubversion', or they will crash.+withSubversion :: IO a -> IO a+withSubversion f+ = do ret <- _initialize+ case ret of+ 0 -> catchDyn f rethrowSvnError+ _ -> fail "Subversion: failed to initialize APR."+++rethrowSvnError :: SvnError -> IO a+rethrowSvnError err+ = let code = svnErrCode err+ msg = svnErrMsg err+ in+ fail $ "withSubversion: caught an SvnError: " ++ (show code) ++ ": " ++ msg
+ Subversion/Config.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# LINE 1 "Subversion/Config.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/Config.hsc" #-}++-- |An interface to client configuration files (svn_config.h).+--+-- As you see, this module is totally incomplete. If you need this,+-- you must write a patch.++module Subversion.Config+ ( Config+ )+ where++import GHC.ForeignPtr as GF+import Subversion.Hash++-- |@'Config'@ represents an opaque structure describing a set of+-- configuration options. There is currently no way to neither create+-- nor inspect this object.+newtype Config = Config (ForeignPtr SVN_CONFIG_T)+data SVN_CONFIG_T+++instance HashValue Config where+ marshal (Config config)+ = return $ castForeignPtr config++ unmarshal finalizer configPtr+ = do config <- newForeignPtr_ configPtr+ GF.addForeignPtrConcFinalizer config finalizer+ return $ Config $ castForeignPtr config
+ Subversion/Error.hs view
@@ -0,0 +1,151 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/Error.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/Error.hsc" #-}++-- #prune++-- |Common exception handling for Subversion. The C API of the+-- Subversion returns an error as a function result, but in HsSVN+-- errors are thrown as a DynException.+++{-# LINE 10 "Subversion/Error.hsc" #-}++module Subversion.Error+ ( SvnError+ , SVN_ERROR_T -- private++ , wrapSvnError -- private++ , svnErrCode+ , svnErrMsg++ , svnErr -- private++ , throwSvnErr++ , SvnErrCode(..)+ )+ where++import Control.Exception+import Data.Dynamic+import Foreign+import Foreign.C.String+import Foreign.C.Types+import Subversion.Types++-- |@'SvnError'@ represents a Subversion error.+newtype SvnError+ = SvnError (ForeignPtr SVN_ERROR_T)+ deriving (Typeable)++data SVN_ERROR_T+++foreign import ccall "svn_err_best_message"+ _best_message :: Ptr SVN_ERROR_T -> Ptr CChar -> APR_SIZE_T -> IO (Ptr CChar)++foreign import ccall "&svn_error_clear"+ _clear :: FunPtr (Ptr SVN_ERROR_T -> IO ())+++maxErrMsgLen :: Int+maxErrMsgLen = 255+++withSvnErrorPtr :: SvnError -> (Ptr SVN_ERROR_T -> IO a) -> IO a+withSvnErrorPtr (SvnError err) = withForeignPtr err++-- |@'svnErrCode' err@ returns a 'SvnErrCode' for an error object.+svnErrCode :: SvnError -> SvnErrCode+svnErrCode err+ = unsafePerformIO $+ withSvnErrorPtr err $ \ errPtr -> + do num <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) errPtr+{-# LINE 63 "Subversion/Error.hsc" #-}+ return $ statusToErrCode num++-- |@'svnErrMsg' err@ returns an error message for an error object.+svnErrMsg :: SvnError -> String+svnErrMsg err+ = unsafePerformIO $+ withSvnErrorPtr err $ \ errPtr ->+ allocaArray maxErrMsgLen $ \ bufPtr ->+ _best_message errPtr bufPtr (fromIntegral maxErrMsgLen)+ >>= peekCString+++wrapSvnError :: Ptr SVN_ERROR_T -> IO (Maybe SvnError)+wrapSvnError errPtr+ | errPtr == nullPtr+ = return Nothing+ | otherwise+ = newForeignPtr _clear errPtr >>= return . Just . SvnError+++svnErr :: IO (Ptr SVN_ERROR_T) -> IO ()+svnErr f+ = do err <- wrapSvnError =<< f+ case err of+ Nothing -> return ()+ Just e -> throwSvnErr e++-- |@'throwSvnErr' err@ throws an 'SvnError' object in an IO+-- monad. You usually don't need to use this directly.+throwSvnErr :: SvnError -> IO a+throwSvnErr = throwIO . DynException . toDyn++-- |@'SvnErrCode'@ represents a Subversion error code. As you see, not+-- all errors are translated to Haskell constructors yet. Uncovered+-- error codes are temporarily represented as @'UnknownError' num@.+data SvnErrCode+ = AprEEXIST -- ^ APR EEXIST error: typically it means+ -- something you tried to create was already+ -- there.+ | AprENOENT -- ^ APR ENOENT error: typically it means+ -- something you tried to use wasn't there.+ | DirNotEmpty -- ^ The directory needs to be empty but it's not.+ | ReposLocked -- ^ The repository was locked, perhaps for db+ -- recovery.+ | FsAlreadyExists -- ^ The item already existed in filesystem.+ | FsConflict -- ^ Merge conflict has occured during commit.+ | FsNoSuchRevision -- ^ It was an invalid filesystem revision+ -- number.+ | FsNotDirectory -- ^ It was not a filesystem directory entry.+ | FsNotFile -- ^ It was not a filesystem file entry.+ | FsNotFound -- ^ It wasn't there in filesystem.+ | UnknownError !Int -- ^ Any other errors than above. You+ -- shouldn't rely on the absence of+ -- appropriate 'SvnErrCode' constructors+ -- because they may be added in the future+ -- version of HsSVN. If that happens to you,+ -- your code stops working.+ deriving (Show, Eq, Typeable)++statusToErrCode :: APR_STATUS_T -> SvnErrCode+statusToErrCode (17) = AprEEXIST+{-# LINE 124 "Subversion/Error.hsc" #-}+statusToErrCode (2) = AprENOENT+{-# LINE 125 "Subversion/Error.hsc" #-}+statusToErrCode (200011) = DirNotEmpty+{-# LINE 126 "Subversion/Error.hsc" #-}+statusToErrCode (165000) = ReposLocked+{-# LINE 127 "Subversion/Error.hsc" #-}+statusToErrCode (160020) = FsAlreadyExists+{-# LINE 128 "Subversion/Error.hsc" #-}+statusToErrCode (160024) = FsConflict+{-# LINE 129 "Subversion/Error.hsc" #-}+statusToErrCode (160006) = FsNoSuchRevision+{-# LINE 130 "Subversion/Error.hsc" #-}+statusToErrCode (160016) = FsNotDirectory+{-# LINE 131 "Subversion/Error.hsc" #-}+statusToErrCode (160017) = FsNotFile+{-# LINE 132 "Subversion/Error.hsc" #-}+statusToErrCode (160013) = FsNotFound+{-# LINE 133 "Subversion/Error.hsc" #-}+statusToErrCode n = UnknownError (fromIntegral n)
+ Subversion/FileSystem.hs view
@@ -0,0 +1,271 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/FileSystem.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/FileSystem.hsc" #-}++-- #prune++-- |An interface to the Subversion filesystem.+++{-# LINE 8 "Subversion/FileSystem.hsc" #-}++module Subversion.FileSystem+ ( -- * Type+ FileSystem+ , SVN_FS_T -- private++ , wrapFS -- private+ , withFSPtr -- private+ , touchFS -- private++ -- * Information of the libsvn_fs itself+ , fsVersion++ -- * Filesystem creation, opening and destruction+ , createFileSystem+ , fsConfigFSType+ , fsTypeBDB+ , fsTypeFSFS++ , openFileSystem+ , deleteFileSystem+ , hotCopyFileSystem++ -- * Accessors+ , getFileSystemType+ , getFileSystemPath++ , getYoungestRev+ )+ where++import Control.Monad+import Foreign.C.String+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable+import GHC.ForeignPtr as GF+import Subversion.Error+import Subversion.Hash+import Subversion.Pool+import Subversion.Types++-- |@'FileSystem'@ is an opaque object representing a Subversion+-- filesystem.+newtype FileSystem = FileSystem (ForeignPtr SVN_FS_T)+data SVN_FS_T++foreign import ccall "svn_fs_version"+ _version :: IO (Ptr SVN_VERSION_T)++foreign import ccall "svn_fs_create"+ _create :: Ptr (Ptr SVN_FS_T) -> CString -> Ptr APR_HASH_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_open"+ _open :: Ptr (Ptr SVN_FS_T) -> CString -> Ptr APR_HASH_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_delete_fs"+ _delete_fs :: CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_hotcopy"+ _hotcopy :: CString -> CString -> SVN_BOOLEAN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_type"+ _type :: Ptr CString -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_path"+ _path :: Ptr SVN_FS_T -> Ptr APR_POOL_T -> IO CString++foreign import ccall "svn_fs_youngest_rev"+ _youngest_rev :: Ptr SVN_REVNUM_T -> Ptr SVN_FS_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)+++wrapFS :: IO () -> Ptr SVN_FS_T -> IO FileSystem+wrapFS finalizer fsPtr+ = do fs <- newForeignPtr_ fsPtr+ GF.addForeignPtrConcFinalizer fs finalizer+ return $ FileSystem fs+++withFSPtr :: FileSystem -> (Ptr SVN_FS_T -> IO a) -> IO a+withFSPtr (FileSystem fs) = withForeignPtr fs+++touchFS :: FileSystem -> IO ()+touchFS (FileSystem fs) = touchForeignPtr fs++-- |@fsVersion@ returns a version information of the libsvn_fs.+fsVersion :: IO Version+fsVersion = _version >>= peekVersion+++-- |@'fsConfigFSType'@ is a config key to specify the filesystem+-- back-end.+fsConfigFSType :: String+fsConfigFSType = ("fs-type")+{-# LINE 104 "Subversion/FileSystem.hsc" #-}++-- |@'fsTypeBDB'@ is a config value representing the Berkeley-DB+-- back-end.+fsTypeBDB :: String+fsTypeBDB = ("bdb")+{-# LINE 109 "Subversion/FileSystem.hsc" #-}++-- |@'fsTypeFSFS'@ is a config value representing the+-- Native-filesystem back-end.+fsTypeFSFS :: String+fsTypeFSFS = ("fsfs")+{-# LINE 114 "Subversion/FileSystem.hsc" #-}++-- |@'createFileSystem'@ creates a new, empty Subversion+-- filesystem. Note that creating a raw filesystem is different from+-- creating a repository. If you want a new repository, use+-- 'Subversion.Repository.createRepository' instead.+createFileSystem+ :: FilePath -- ^ Where to create the filesystem. The+ -- path most not currently exist, but its+ -- parent must exist.+ -> [(String, String)] -- ^ A list of @(key, value)@ tuples which+ -- modifies the behavior of the+ -- filesystem. The interpretation of it is+ -- specific to the filesystem back-end.+ -- + -- If the list contains a value for+ -- 'fsConfigFSType', that value determines+ -- the filesystem type for the new+ -- filesystem. Currently defined values+ -- are:+ --+ -- ['fsTypeBDB'] Berkeley-DB implementation+ --+ -- ['fsTypeFSFS'] Native-filesystem+ -- implementation+ --+ -- If the list does not contain a value+ -- for 'fsConfigFSType' then the default+ -- filesystem type will be used. This will+ -- typically be BDB for version 1.1 and+ -- FSFS for later versions, though the+ -- caller should not rely upon any+ -- particular default if they wish to+ -- ensure that a filesystem of specific+ -- type is created.+ -> IO FileSystem -- ^ The new filesystem.+createFileSystem path configPairs+ = do pool <- newPool+ alloca $ \ fsPtrPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do config <- pairsToHash configPairs+ svnErr $ _create fsPtrPtr pathPtr (unsafeHashToPtr config) poolPtr++ fs <- wrapFS (touchPool pool) =<< peek fsPtrPtr++ -- config には fs が死ぬまでは生きてゐて慾しい。+ GF.addForeignPtrConcFinalizer (case fs of FileSystem x -> x)+ $ touchHash config++ return fs++-- |@'openFileSystem'@ opens a Subversion filesystem. Note that you+-- probably don't want to use this directly. Take a look at+-- 'Subversion.Repository.openRepository' instead.+openFileSystem+ :: FilePath -- ^ Where the filesystem located on.+ -> [(String, String)] -- ^ A list of @(key, value)@ tuples which+ -- modifies the behavior of the+ -- filesystem. The interpretation of it is+ -- specific to the filesystem back-end.+ -> IO FileSystem+openFileSystem path configPairs+ = do pool <- newPool+ alloca $ \ fsPtrPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do config <- pairsToHash configPairs+ svnErr $ _open fsPtrPtr pathPtr (unsafeHashToPtr config) poolPtr++ fs <- wrapFS (touchPool pool) =<< peek fsPtrPtr++ -- config には fs が死ぬまでは生きてゐて慾しい。+ GF.addForeignPtrConcFinalizer (case fs of FileSystem x -> x)+ $ touchHash config++ return fs++-- |@'deleteFileSystem'@ deletes a Subversion filesystem. Note that+-- you probably don't want to use this directly. Take a look at+-- 'Subversion.Repository.deleteRepository' instead.+deleteFileSystem :: FilePath -> IO ()+deleteFileSystem path+ = do pool <- newPool+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _delete_fs pathPtr poolPtr++-- |@'hotCopyFileSystem'@ copies a possibly live Subversion filesystem+-- from one location to another.+hotCopyFileSystem :: FilePath -- ^ Source+ -> FilePath -- ^ Destination+ -> Bool -- ^ If this is true,+ -- @'hotCopyFileSystem'@ performs+ -- cleanup on the source filesystem as+ -- part of the copy opeation;+ -- currently, this means deleting+ -- copied, unused logfiles for a+ -- Berkeley DB source filesystem.+ -> IO ()+hotCopyFileSystem src dest clean+ = do pool <- newPool+ withCString src $ \ srcPath ->+ withCString dest $ \ destPath ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _hotcopy srcPath destPath (marshalBool clean) poolPtr++-- |@'getFileSystemPath' fsPath@ returns a string identifying the+-- back-end type of the Subversion filesystem located on @fsPath@. The+-- string should be equal to one of the @fsType*@ defined constants,+-- unless the filesystem is a new back-end type added in a later+-- version of Subversion.+--+-- In general, the type should make no difference in the filesystem's+-- semantics, but there are a few situations (such as backups) where+-- it might matter.+getFileSystemType :: FilePath -> IO String+getFileSystemType path+ = do pool <- newPool+ alloca $ \ typePtrPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _type typePtrPtr pathPtr poolPtr+ t <- peekCString =<< peek typePtrPtr+ return t++-- |@'getFileSystemPath' fs@ returns the path to @fs@'s+-- repository. Note that this is what was passed to 'createFileSystem'+-- or 'openFileSystem'; might be absolute, might not.+getFileSystemPath :: FileSystem -> IO FilePath+getFileSystemPath fs+ = do pool <- newPool+ withFSPtr fs $ \ fsPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do path <- peekCString =<< _path fsPtr poolPtr+ touchPool pool+ return path++-- |@'getYoungestRev' fs@ returns the number of the youngest revision+-- in filesystem @fs@. The oldest revision in any filesystem is+-- numbered zero.+getYoungestRev :: FileSystem -> IO RevNum+getYoungestRev fs+ = do pool <- newPool+ alloca $ \ revNumPtr ->+ withFSPtr fs $ \ fsPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _youngest_rev revNumPtr fsPtr poolPtr+ return . fromIntegral =<< peek revNumPtr
+ Subversion/FileSystem/DirEntry.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/FileSystem/DirEntry.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/FileSystem/DirEntry.hsc" #-}++-- |This module only defines the 'DirEntry' type.+++{-# LINE 6 "Subversion/FileSystem/DirEntry.hsc" #-}++module Subversion.FileSystem.DirEntry+ ( DirEntry(..)+ )+ where++import Foreign.C.String+import Foreign.Storable+import Subversion.Hash+import Subversion.Types++-- |The type of a Subversion directory entry.+--+-- Note that @svn_fs_dirent_t.id@ is currently unavailable in this+-- binding. Add one if you really need it.+data DirEntry+ = DirEntry {+ entName :: String -- ^ The name of this directory entry.+ , entKind :: NodeKind -- ^ The node kind.+ }+ deriving (Show, Eq)+++instance HashValue DirEntry where+ marshal ent+ = fail "marshalling DirEntry is not supported"++ unmarshal finalizer entPtr+ = do namePtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) entPtr+{-# LINE 35 "Subversion/FileSystem/DirEntry.hsc" #-}+ name <- peekCString namePtr+ kind <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) entPtr+{-# LINE 37 "Subversion/FileSystem/DirEntry.hsc" #-}+ finalizer+ return DirEntry {+ entName = name+ , entKind = unmarshalNodeKind kind+ }
Subversion/FileSystem/DirEntry.hsc view
@@ -27,7 +27,7 @@ instance HashValue DirEntry where- marshal ent+ marshal _ = fail "marshalling DirEntry is not supported" unmarshal finalizer entPtr
+ Subversion/FileSystem/PathChange.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/FileSystem/PathChange.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/FileSystem/PathChange.hsc" #-}++-- |This module only defines two types; 'PathChange' and 'ChangeKind'.+++{-# LINE 6 "Subversion/FileSystem/PathChange.hsc" #-}++module Subversion.FileSystem.PathChange+ ( PathChange(..)+ , ChangeKind(..)+ )+ where++import Data.Word+import Foreign.Storable+import Subversion.Hash+import Subversion.Types++-- |@'PathChange'@ describes a change in a revision occured on a path.+-- +-- Note that @svn_fs_path_change_t.node_rev_id@ is currently+-- unavailable in this binding. Add one if you really need it.+data PathChange = PathChange {+ pcChangeKind :: ChangeKind -- ^ Kind of change.+ , pcTextMod :: Bool -- ^ Were there text modifications?+ , pcPropMod :: Bool -- ^ Were there property modifications?+ } deriving (Show, Eq)+++type SVN_FS_PATH_CHANGE_KIND_T = Word32+{-# LINE 30 "Subversion/FileSystem/PathChange.hsc" #-}++-- |The kind of change that occured on the path.+data ChangeKind = ModifiedPath -- ^ defalut value+ | AddedPath -- ^ path added in txn+ | DeletedPath -- ^ path removed in txn+ | ReplacedPath -- ^ path removed and re-added in txn+ deriving (Show, Eq)+++unmarshalChangeKind :: SVN_FS_PATH_CHANGE_KIND_T -> ChangeKind+unmarshalChangeKind (0) = ModifiedPath+{-# LINE 41 "Subversion/FileSystem/PathChange.hsc" #-}+unmarshalChangeKind (1) = AddedPath+{-# LINE 42 "Subversion/FileSystem/PathChange.hsc" #-}+unmarshalChangeKind (2) = DeletedPath+{-# LINE 43 "Subversion/FileSystem/PathChange.hsc" #-}+unmarshalChangeKind (3) = ReplacedPath+{-# LINE 44 "Subversion/FileSystem/PathChange.hsc" #-}+++instance HashValue PathChange where+ marshal pc+ = fail "marshalling PathChange is not supported"++ unmarshal finalizer pcPtr+ = do kind <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) pcPtr+{-# LINE 52 "Subversion/FileSystem/PathChange.hsc" #-}+ textMod <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) pcPtr+{-# LINE 53 "Subversion/FileSystem/PathChange.hsc" #-}+ propMod <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) pcPtr+{-# LINE 54 "Subversion/FileSystem/PathChange.hsc" #-}+ finalizer+ return PathChange {+ pcChangeKind = unmarshalChangeKind kind+ , pcTextMod = unmarshalBool textMod+ , pcPropMod = unmarshalBool propMod+ }
Subversion/FileSystem/PathChange.hsc view
@@ -41,10 +41,11 @@ unmarshalChangeKind (#const svn_fs_path_change_add ) = AddedPath unmarshalChangeKind (#const svn_fs_path_change_delete ) = DeletedPath unmarshalChangeKind (#const svn_fs_path_change_replace) = ReplacedPath+unmarshalChangeKind _ = undefined instance HashValue PathChange where- marshal pc+ marshal _ = fail "marshalling PathChange is not supported" unmarshal finalizer pcPtr
+ Subversion/FileSystem/Revision.hs view
@@ -0,0 +1,219 @@+{-# 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
@@ -210,5 +210,5 @@ withPoolPtr pool $ \ poolPtr -> do svnErr $ _history_location pathPtrPtr revNumPtr histPtr poolPtr revNum <- return . fromIntegral =<< peek revNumPtr- path <- peekCString =<< peek pathPtrPtr- return (revNum, path)+ path' <- peekCString =<< peek pathPtrPtr+ return (revNum, path')
+ Subversion/FileSystem/Root.hs view
@@ -0,0 +1,339 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/FileSystem/Root.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/FileSystem/Root.hsc" #-}++-- #prune++-- |An interface to functions that work on both existing revisions and+-- ongoing transactions in a filesystem.+++{-# LINE 9 "Subversion/FileSystem/Root.hsc" #-}++module Subversion.FileSystem.Root+ ( -- * Class+ MonadFS(..)++ , FileSystemRoot -- private+ , SVN_FS_ROOT_T -- private++ , wrapFSRoot -- private+ , withFSRootPtr -- private++ , getRootFS -- private++ -- * Getting file content and others+ , getFileLength+ , getFileMD5++ , getFileContents+ , getFileContentsLBS++ -- * Getting node type+ , checkPath+ , isDirectory+ , isFile++ -- * Getting node property+ , getNodeProp+ , getNodePropList++ -- * Getting nodes in directory+ , getDirEntries++ -- * Getting change list+ , getPathsChanged+ )+ where++import Control.Monad+import Data.ByteString.Base+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Word+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import GHC.ForeignPtr as GF+import Subversion.FileSystem+import Subversion.FileSystem.DirEntry+import Subversion.FileSystem.PathChange+import Subversion.Error+import Subversion.Hash+import Subversion.Pool+import Subversion.Stream+import Subversion.String+import Subversion.Types+++{- class MonadFS ------------------------------------------------------------- -}++-- |@'MonadFS' m@ is a monad which holds internally either an existing+-- revision or ongoing transaction.+class Monad m => MonadFS m where+ -- private+ getRoot :: m FileSystemRoot++ -- |@'unsafeIOToFS'@ runs an IO monad in 'MonadFS'.+ -- + -- This is unsafe if the monad is a transaction monad. When a+ -- transaction fails before getting commited, all transactional+ -- operations are cancelled at once. But if you had launched+ -- missiles with 'unsafeIOToFS' during the transaction, your+ -- missiles can never go back. So you must use this carefully.+ unsafeIOToFS :: IO a -> m a++ -- |@'isTransaction'@ returns True iff the monad is a transaction+ -- monad.+ isTransaction :: m Bool+++{- functions and types ------------------------------------------------------- -}++newtype FileSystemRoot = FileSystemRoot (ForeignPtr SVN_FS_ROOT_T)+data SVN_FS_ROOT_T+++foreign import ccall unsafe "svn_fs_root_fs"+ _root_fs :: Ptr SVN_FS_ROOT_T -> IO (Ptr SVN_FS_T)++foreign import ccall unsafe "svn_fs_file_length"+ _file_length :: Ptr SVN_FILESIZE_T -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_file_md5_checksum"+ _file_md5_checksum :: Ptr CUChar -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_file_contents"+ _file_contents :: Ptr (Ptr SVN_STREAM_T) -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_node_proplist"+ _node_proplist :: Ptr (Ptr APR_HASH_T) -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_node_prop"+ _node_prop :: Ptr (Ptr SVN_STRING_T) -> Ptr SVN_FS_ROOT_T -> CString -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_dir_entries"+ _dir_entries :: Ptr (Ptr APR_HASH_T) -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_paths_changed"+ _paths_changed :: Ptr (Ptr APR_HASH_T) -> Ptr SVN_FS_ROOT_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_check_path"+ _check_path :: Ptr SVN_NODE_KIND_T -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_is_dir"+ _is_dir :: Ptr SVN_BOOLEAN_T -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_is_file"+ _is_file :: Ptr SVN_BOOLEAN_T -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)+++wrapFSRoot :: IO () -> Ptr SVN_FS_ROOT_T -> IO FileSystemRoot+wrapFSRoot finalizer rootPtr+ = do root <- newForeignPtr_ rootPtr+ GF.addForeignPtrConcFinalizer root finalizer+ return $ FileSystemRoot root+++withFSRootPtr :: FileSystemRoot -> (Ptr SVN_FS_ROOT_T -> IO a) -> IO a+withFSRootPtr (FileSystemRoot root) = withForeignPtr root+++touchFSRoot :: FileSystemRoot -> IO ()+touchFSRoot (FileSystemRoot root) = touchForeignPtr root+++getRootFS :: FileSystemRoot -> IO FileSystem+getRootFS root+ = withFSRootPtr root $ \ rootPtr ->+ -- 實際には root が生きてゐる限り fs は死なないのだが、念の爲。+ wrapFS (touchFSRoot root) =<< _root_fs rootPtr++-- |@'getFileLength' path@ returns the length of file @path@.+getFileLength :: MonadFS m => FilePath -> m Integer+getFileLength path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ lenPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _file_length lenPtr rootPtr pathPtr poolPtr+ return . toInteger =<< peek lenPtr++-- |@'getFileMD5' path@ returns the MD5 checksum of file @path@. If+-- the filesystem does not have a prerecorded checksum for @path@, it+-- doesn't calculate a checksum dynamically, just puts all 0's into+-- the resulting digest. (By convention, the all-zero checksum is+-- considered to match any checksum.)+getFileMD5 :: MonadFS m => FilePath -> m [Word8]+getFileMD5 path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ allocaArray md5Len $ \ bufPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _file_md5_checksum bufPtr rootPtr pathPtr poolPtr+ return . map fromIntegral =<< peekArray md5Len bufPtr+ where+ md5Len = (16)+{-# LINE 182 "Subversion/FileSystem/Root.hsc" #-}+++-- |@'getFileContents' path@ returns the content of file @path@.+--+-- If this is a non-transactional monad (that is, a monad whose+-- 'isTransaction' returns 'Prelude.False'), it reads the content+-- /lazilly/. But if this is a transactional monad, 'getFileContents'+-- does the operation /strictly/: I mean it loads the entire file onto+-- the memory! This is because @svn_fs_file_contents()@ in the+-- libsvn_fs doesn't guarantee, when we are in a transaction, that we+-- can progressively read a file which is suddenly modified in the+-- same transaction during the progressive reading.+--+-- I think 'getFileContents' might have to return+-- @['Data.Word.Word8']@ instead of 'Prelude.String' because every+-- files in filesystem should be considered binary. Yes,+-- 'Prelude.readFile' also returns 'Prelude.String' but this is an+-- immature part of Haskell. I wish someday the GHC gets more clear+-- distinction between binary data and an Unicode string, then I+-- change the form of 'getFileContents' alike.+getFileContents :: MonadFS m => FilePath -> m String+getFileContents path+ = liftM L8.unpack $ getFileContentsLBS path+++-- |@'getFileContentsLBS'@ does the same thing as 'getFileContents'+-- but returns 'Data.ByteString.Base.LazyByteString' instead.+getFileContentsLBS :: MonadFS m => FilePath -> m LazyByteString+getFileContentsLBS path+ = do root <- getRoot+ isTxn <- isTransaction+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ ioPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ (svnErr $ _file_contents ioPtrPtr rootPtr pathPtr poolPtr)+ >> peek ioPtrPtr+ >>= wrapStream (touchPool pool)+ >>= (if isTxn then+ sStrictReadLBS+ else+ sReadLBS)++-- |@'getNodePropList' path@ returns the property list of @path@ in a+-- revision or transaction.+getNodePropList :: MonadFS m => FilePath -> m [(String, String)]+getNodePropList path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ hashPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _node_proplist hashPtrPtr rootPtr pathPtr poolPtr+ hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr+ mapHash' (\ (n, v)+ -> peekSvnString v+ >>=+ return . ((,) n) . B8.unpack) hash++-- |@'getNodeProp' path propName@ returns the value of the property+-- named @propName@ of @path@ in a revision or transaction.+getNodeProp :: MonadFS m => FilePath -> String -> m (Maybe String)+getNodeProp path name+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ valPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withCString name $ \ namePtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _node_prop valPtrPtr rootPtr pathPtr namePtr poolPtr+ prop <- peekSvnString' =<< peek valPtrPtr+ -- prop は pool の中から讀み取られるので、それが濟+ -- むまで pool が死んでは困る。+ touchPool pool+ return $ fmap B8.unpack prop++-- |@'getDirEntries' path@ returns a list containing the entries of+-- the directory at @path@ in a revision or transaction.+getDirEntries :: MonadFS m => FilePath -> m [DirEntry]+getDirEntries path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ hashPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _dir_entries hashPtrPtr rootPtr pathPtr poolPtr+ peek hashPtrPtr+ >>= wrapHash (touchFSRoot root >> touchPool pool)+ >>= hashToValues++-- |@'getPathsChanged'@ returns a list containing descriptions of the+-- paths changed under a revision or transaction.+getPathsChanged :: MonadFS m => m [(FilePath, PathChange)]+getPathsChanged+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ hashPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _paths_changed hashPtrPtr rootPtr poolPtr+ peek hashPtrPtr+ >>= wrapHash (touchFSRoot root >> touchPool pool)+ >>= hashToPairs++-- |@'checkPath' path@ returns a 'Subversion.Types.NodeKind' for+-- @path@. Unlike most other actions, 'checkPath' doesn't throw an+-- error even if the @path@ doesn't point to an existent node: in that+-- case it just returns 'Subversion.Types.NoNode'.+checkPath :: MonadFS m => FilePath -> m NodeKind+checkPath path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ kindPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _check_path kindPtr rootPtr pathPtr poolPtr+ return . unmarshalNodeKind =<< peek kindPtr++-- |@'isDirectory' path@ returns 'Prelude.True' iff the @path@ points+-- to a directory in a revision or transaction. It returns+-- 'Prelude.False' for inexistent path.+isDirectory :: MonadFS m => FilePath -> m Bool+isDirectory path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ boolPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _is_dir boolPtr rootPtr pathPtr poolPtr+ return . unmarshalBool =<< peek boolPtr++-- |@'isFile' path@ returns 'Prelude.True' iff the @path@ points to a+-- file in a revision or transaction. It returns 'Prelude.False' for+-- inexistent path.+isFile :: MonadFS m => FilePath -> m Bool+isFile path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ boolPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _is_file boolPtr rootPtr pathPtr poolPtr+ return . unmarshalBool =<< peek boolPtr
Subversion/FileSystem/Root.hsc view
@@ -44,9 +44,9 @@ where import Control.Monad-import Data.ByteString.Base-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Word import Foreign.C.String import Foreign.C.Types@@ -205,8 +205,8 @@ -- |@'getFileContentsLBS'@ does the same thing as 'getFileContents'--- but returns 'Data.ByteString.Base.LazyByteString' instead.-getFileContentsLBS :: MonadFS m => FilePath -> m LazyByteString+-- but returns 'Data.ByteString.Lazy.ByteString' instead.+getFileContentsLBS :: MonadFS m => FilePath -> m Lazy.ByteString getFileContentsLBS path = do root <- getRoot isTxn <- isTransaction
+ Subversion/FileSystem/Transaction.hs view
@@ -0,0 +1,343 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# LINE 1 "Subversion/FileSystem/Transaction.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/FileSystem/Transaction.hsc" #-}++-- #prune++-- |An interface to functions that work on a filesystem transaction.++module Subversion.FileSystem.Transaction+ ( -- * Type + Txn++ , Transaction -- private+ , SVN_FS_TXN_T -- private++ , wrapTxn -- private+ , withTxnPtr -- private+ , runTxn -- private++ , abortTxn -- private+ , getTransactionRoot -- private++ -- * Accessing transaction property+ , getTxnProp+ , getTxnPropList+ , setTxnProp++ -- * Changing content of file+ , applyText+ , applyTextLBS++ -- * Changing node property+ , setNodeProp++ -- * Creating, deleting and copying entry+ , makeFile+ , makeDirectory++ , deleteEntry++ , copyEntry+ )+ where++import Control.Monad.Reader+import Control.Monad+import Data.ByteString.Base+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Foreign.C.String+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable+import GHC.ForeignPtr as GF+import Subversion.Error+import Subversion.FileSystem.Revision+import Subversion.FileSystem.Root+import Subversion.Hash+import Subversion.Pool+import Subversion.Stream+import Subversion.String+import Subversion.Types++{- Monad Txn ----------------------------------------------------------------- -}++data TxnContext = TxnContext {+ ctxTxn :: Transaction+ , ctxRoot :: FileSystemRoot+ }++-- |@'Txn' a@ is a FS monad which reads and updates data in filesystem+-- and finally returns @a@. See 'Subversion.FileSystem.Root.MonadFS'.+newtype Txn a = Txn { unTxn :: ReaderT TxnContext IO a }++instance Functor Txn where+ fmap f c = Txn (fmap f (unTxn c))++instance Monad Txn where+ c >>= f = Txn (unTxn c >>= unTxn . f)+ return = Txn . return+ fail = Txn . fail++instance MonadFS Txn where+ getRoot = Txn (ask >>= return . ctxRoot)+ unsafeIOToFS a = Txn (liftIO a)+ isTransaction = Txn (return True)+++getTxn :: Txn Transaction+getTxn = Txn (ask >>= return . ctxTxn)+++{- functions and types ------------------------------------------------------- -}++newtype Transaction = Transaction (ForeignPtr SVN_FS_TXN_T)+data SVN_FS_TXN_T+++foreign import ccall "svn_fs_abort_txn"+ _abort_txn :: Ptr SVN_FS_TXN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall "svn_fs_txn_root"+ _txn_root :: Ptr (Ptr SVN_FS_ROOT_T) -> Ptr SVN_FS_TXN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_txn_prop"+ _txn_prop :: Ptr (Ptr SVN_STRING_T) -> Ptr SVN_FS_TXN_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_txn_proplist"+ _txn_proplist :: Ptr (Ptr APR_HASH_T) -> Ptr SVN_FS_TXN_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_change_txn_prop"+ _change_txn_prop :: Ptr SVN_FS_TXN_T -> CString -> Ptr SVN_STRING_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_change_node_prop"+ _change_node_prop :: Ptr SVN_FS_ROOT_T -> CString -> CString -> Ptr SVN_STRING_T -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_apply_text"+ _apply_text :: Ptr (Ptr SVN_STREAM_T) -> Ptr SVN_FS_ROOT_T -> CString -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_make_file"+ _make_file :: Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_make_dir"+ _make_dir :: Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_delete"+ _delete :: Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "svn_fs_copy"+ _copy :: Ptr SVN_FS_ROOT_T -> CString -> Ptr SVN_FS_ROOT_T -> CString -> Ptr APR_POOL_T -> IO (Ptr SVN_ERROR_T)+++wrapTxn :: IO () -> Ptr SVN_FS_TXN_T -> IO Transaction+wrapTxn finalizer txnPtr+ = do txn <- newForeignPtr_ txnPtr+ GF.addForeignPtrConcFinalizer txn finalizer+ return $ Transaction txn+++touchTxn :: Transaction -> IO ()+touchTxn (Transaction txn) = touchForeignPtr txn+++withTxnPtr :: Transaction -> (Ptr SVN_FS_TXN_T -> IO a) -> IO a+withTxnPtr (Transaction txn) = withForeignPtr txn+++runTxn :: Txn a -> Transaction -> IO a+runTxn c txn+ = do root <- getTransactionRoot txn++ -- We've got the txn root so we can run the Txn monad.+ let ctx = TxnContext {+ ctxTxn = txn+ , ctxRoot = root+ }++ runReaderT (unTxn c) ctx+++abortTxn :: Transaction -> IO ()+abortTxn txn+ = do pool <- newPool+ withTxnPtr txn $ \ txnPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _abort_txn txnPtr poolPtr+++getTransactionRoot :: Transaction -> IO FileSystemRoot+getTransactionRoot txn+ = do pool <- newPool+ alloca $ \ rootPtrPtr ->+ withTxnPtr txn $ \ txnPtr ->+ withPoolPtr pool $ \ poolPtr ->+ (svnErr $ _txn_root rootPtrPtr txnPtr poolPtr)+ >> peek rootPtrPtr+ >>= (wrapFSRoot $+ -- root は pool にも txn にも依存する。+ touchPool pool >> touchTxn txn)++-- |@'getTxnProp' propName@ returns the value of the property named+-- @propName@ on the transaction.+getTxnProp :: String -> Txn (Maybe String)+getTxnProp name+ = do txn <- getTxn+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ valPtrPtr ->+ withTxnPtr txn $ \ txnPtr ->+ withCString name $ \ namePtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _txn_prop valPtrPtr txnPtr namePtr poolPtr+ prop <- peekSvnString' =<< peek valPtrPtr+ -- prop は pool の中から讀み取られるので、それが濟+ -- むまでは pool が死んでは困る。+ touchPool pool+ return $ fmap B8.unpack prop++-- |@'getTxnPropList'@ returns the entire property list on the+-- transaction.+getTxnPropList :: Txn [(String, String)]+getTxnPropList + = do txn <- getTxn+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ hashPtrPtr ->+ withTxnPtr txn $ \ txnPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _txn_proplist hashPtrPtr txnPtr poolPtr+ hash <- wrapHash (touchPool pool) =<< peek hashPtrPtr+ mapHash' (\ (n, v)+ -> peekSvnString v+ >>=+ return . ((,) n) . B8.unpack) hash++-- |@'setTxnProp' propName propValue@ changes, adds or deletes a+-- property on the transaction.+setTxnProp :: String -> Maybe String -> Txn ()+setTxnProp name valStr+ = do txn <- getTxn+ pool <- unsafeIOToFS newPool+ let value = fmap B8.pack valStr+ unsafeIOToFS $ withTxnPtr txn $ \ txnPtr ->+ withCString name $ \ namePtr ->+ withSvnString' value $ \ valuePtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _change_txn_prop txnPtr namePtr valuePtr poolPtr++-- |@'setNodeProp' fpath propName propValue@ changes, adds or deletes+-- a property named @propName@ on file @fpath@.+setNodeProp :: FilePath -> String -> Maybe String -> Txn ()+setNodeProp path name valStr+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ let value = fmap B8.pack valStr+ unsafeIOToFS $ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withCString name $ \ namePtr ->+ withSvnString' value $ \ valuePtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _change_node_prop rootPtr pathPtr namePtr valuePtr poolPtr+++-- |@'applyText'@ replaces the content of file.+applyText+ :: FilePath -- ^ The file to be replaced. If it does not exist+ -- in the transaction, 'applyText' throws an+ -- error. That is, you can't use this action to+ -- create new files; use 'makeFile' to create an+ -- empty file first.+ -> Maybe String -- ^ The hex MD5 digest for the new content. It is+ -- ignored if 'Prelude.Nothing', but if not+ -- 'Prelude.Nothing', it must match the checksum+ -- of the content; if it doesn't, 'applyText'+ -- throws an error.+ -> String -- ^ The new content. + --+ -- This argument is currently a 'Prelude.String'+ -- but someday it may be changed to+ -- @['Data.Word.Word8']@ or something alike. See+ -- 'Subversion.FileSystem.Root.getFileContents'.+ -> Txn ()+applyText path resultMD5 contents+ = applyTextLBS path resultMD5 (L8.pack contents)++-- |@'applyTextLBS'@ does the same thing as 'applyText' but takes+-- 'Data.ByteString.Base.LazyByteString' instead.+applyTextLBS :: FilePath -> Maybe String -> LazyByteString -> Txn ()+applyTextLBS path resultMD5 contents+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ alloca $ \ ioPtrPtr ->+ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withCString' resultMD5 $ \ resultMD5Ptr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _apply_text ioPtrPtr rootPtr pathPtr resultMD5Ptr poolPtr+ io <- wrapStream (touchPool pool) =<< peek ioPtrPtr+ sWriteLBS io contents+ sClose io+ where+ withCString' :: Maybe String -> (CString -> IO a) -> IO a+ withCString' Nothing f = f nullPtr+ withCString' (Just str) f = withCString str f++-- |@'makeFile' fpath@ creates a new file named @fpath@. The initial+-- content of file is the empty string, and it has no properties.+makeFile :: FilePath -> Txn ()+makeFile path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _make_file rootPtr pathPtr poolPtr++-- |@'makeDirectory' fpath@ creates a new directory named @fpath@. The+-- new directory has no entries, and no properties.+makeDirectory :: FilePath -> Txn ()+makeDirectory path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _make_dir rootPtr pathPtr poolPtr++-- |@'deleteEntry' fpath@ delete the node named @fpath@ in the+-- transaction. If the node being deleted is a directory, its contents+-- will be deleted recursively.+--+-- If the @fpath@ is missing from the transaction, 'deleteEntry'+-- throws an error.+--+-- Attempting to remove the root directory also results in an error,+-- even if the directory is empty.+deleteEntry :: FilePath -> Txn ()+deleteEntry path+ = do root <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ withFSRootPtr root $ \ rootPtr ->+ withCString path $ \ pathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _delete rootPtr pathPtr poolPtr++-- |@'copyEntry' fromRevNum fromPath toPath@ creates a copy of file+-- @fromPath@ in a revision @fromRevNum@ named @toPath@ in the+-- transaction.+copyEntry :: RevNum -> FilePath -> FilePath -> Txn ()+copyEntry fromRevNum fromPath toPath+ = do toRoot <- getRoot+ fs <- unsafeIOToFS $ getRootFS toRoot+ unsafeIOToFS $ withRevision fs fromRevNum+ $ do fromRoot <- getRoot+ pool <- unsafeIOToFS newPool+ unsafeIOToFS $ withFSRootPtr fromRoot $ \ fromRootPtr ->+ withCString fromPath $ \ fromPathPtr ->+ withFSRootPtr toRoot $ \ toRootPtr ->+ withCString toPath $ \ toPathPtr ->+ withPoolPtr pool $ \ poolPtr ->+ svnErr $ _copy fromRootPtr fromPathPtr toRootPtr toPathPtr poolPtr
Subversion/FileSystem/Transaction.hsc view
@@ -42,9 +42,9 @@ import Control.Monad.Reader import Control.Monad-import Data.ByteString.Base-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Foreign.C.String import Foreign.ForeignPtr import Foreign.Ptr@@ -261,8 +261,8 @@ = applyTextLBS path resultMD5 (L8.pack contents) -- |@'applyTextLBS'@ does the same thing as 'applyText' but takes--- 'Data.ByteString.Base.LazyByteString' instead.-applyTextLBS :: FilePath -> Maybe String -> LazyByteString -> Txn ()+-- 'Data.ByteString.Lazy.ByteString' instead.+applyTextLBS :: FilePath -> Maybe String -> Lazy.ByteString -> Txn () applyTextLBS path resultMD5 contents = do root <- getRoot pool <- unsafeIOToFS newPool
+ Subversion/Hash.hs view
@@ -0,0 +1,253 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/Hash.hsc" #-}++{-# LINE 2 "Subversion/Hash.hsc" #-}++module Subversion.Hash+ ( Hash+ , HashValue(..)+ , APR_HASH_T++ , withHashPtr+ , unsafeHashToPtr+ , touchHash+ , wrapHash++ , new+ , update+ , delete+ , lookup++ , pairsToHash+ , hashToPairs++ , hashToValues++ , mapHash+ , mapHash'+ )+ where++import Control.Monad+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils hiding (new)+import Foreign.Ptr+import Foreign.Storable+import qualified GHC.ForeignPtr as GF+import Prelude hiding (lookup)+import Subversion.Pool+import Subversion.Types+import System.IO.Unsafe+++newtype Hash a = Hash (ForeignPtr APR_HASH_T)+data APR_HASH_T++newtype HashIndex a = HashIndex (ForeignPtr APR_HASH_INDEX_T)+data APR_HASH_INDEX_T+++mallocStringForeignPtr :: String -> IO (ForeignPtr CChar)+mallocStringForeignPtr str+ = withCStringLen str $ \ (strPtr, len) ->+ do strFPtr <- mallocForeignPtrBytes $ len + 1+ copyBytes (unsafeForeignPtrToPtr strFPtr) strPtr len+ pokeByteOff (unsafeForeignPtrToPtr strFPtr) len '\0'+ return strFPtr+++class HashValue a where+ marshal :: a -> IO (ForeignPtr ())+ unmarshal :: IO () -> Ptr () -> IO a++instance HashValue String where+ marshal str+ = mallocStringForeignPtr str >>= return . castForeignPtr++ unmarshal finalizer strPtr+ = do str <- peekCString (castPtr strPtr)+ finalizer+ return str+++foreign import ccall unsafe "apr_hash_make"+ _make :: Ptr APR_POOL_T -> IO (Ptr APR_HASH_T)++foreign import ccall unsafe "apr_hash_set"+ _set :: Ptr APR_HASH_T -> Ptr () -> APR_SSIZE_T -> Ptr () -> IO ()++foreign import ccall unsafe "apr_hash_get"+ _get :: Ptr APR_HASH_T -> Ptr () -> APR_SSIZE_T -> IO (Ptr ())++foreign import ccall unsafe "apr_hash_first"+ _first :: Ptr APR_POOL_T -> Ptr APR_HASH_T -> IO (Ptr APR_HASH_INDEX_T)++foreign import ccall unsafe "apr_hash_this"+ _this :: Ptr APR_HASH_INDEX_T -> Ptr (Ptr ()) -> Ptr APR_SSIZE_T -> Ptr (Ptr ()) -> IO ()++foreign import ccall unsafe "apr_hash_next"+ _next :: Ptr APR_HASH_INDEX_T -> IO (Ptr APR_HASH_INDEX_T)+++wrapHash :: IO () -> Ptr APR_HASH_T -> IO (Hash a)+wrapHash finalizer hashPtr+ = do hash <- newForeignPtr_ hashPtr+ GF.addForeignPtrConcFinalizer hash finalizer+ return $ Hash hash+++withHashPtr :: Hash a -> (Ptr APR_HASH_T -> IO b) -> IO b+withHashPtr (Hash hash) = withForeignPtr hash+++unsafeHashToPtr :: Hash a -> Ptr APR_HASH_T+unsafeHashToPtr (Hash hash) = unsafeForeignPtrToPtr hash+++touchHash :: Hash a -> IO ()+touchHash (Hash hash) = touchForeignPtr hash+++wrapHashIdx :: IO () -> Ptr APR_HASH_INDEX_T -> IO (HashIndex a)+wrapHashIdx finalizer idxPtr+ = do idx <- newForeignPtr_ idxPtr+ GF.addForeignPtrConcFinalizer idx finalizer+ return $ HashIndex idx+++withHashIdxPtr :: HashIndex a -> (Ptr APR_HASH_INDEX_T -> IO b) -> IO b+withHashIdxPtr (HashIndex idx) = withForeignPtr idx+++touchHashIdx :: HashIndex a -> IO ()+touchHashIdx (HashIndex idx) = touchForeignPtr idx+++new :: HashValue a => IO (Hash a)+new = do pool <- newPool+ withPoolPtr pool $ \ poolPtr ->+ _make poolPtr >>= wrapHash (touchPool pool)++-- 一旦 Hash に入れた値は、Hash 自体が解放されるまでは解放されなくなる+-- 事に注意。それがまずいのであれば、Hash 自体に Map (Ptr ())+-- (ForeignPtr ()) を持たせて、その Map を同時に管理しなければならない。+-- 面倒だ。+update :: HashValue a => Hash a -> String -> a -> IO ()+update (Hash hash) key value+ = withForeignPtr hash $ \ hashPtr ->+ do keyFPtr <- mallocStringForeignPtr key+ valueFPtr <- marshal value+ _set hashPtr+ (castPtr $ unsafeForeignPtrToPtr keyFPtr)+ (-1)+{-# LINE 143 "Subversion/Hash.hsc" #-}+ (unsafeForeignPtrToPtr valueFPtr)+ -- hash よりも key 及び value が先に解放されては困る。+ GF.addForeignPtrConcFinalizer hash+ $ do touchForeignPtr keyFPtr+ touchForeignPtr valueFPtr+++delete :: Hash a -> String -> IO ()+delete hash key+ = withHashPtr hash $ \ hashPtr ->+ withCStringLen key $ \ (keyPtr, keyLen) ->+ _set hashPtr (castPtr keyPtr) (fromIntegral keyLen) nullPtr+++lookup :: HashValue a => Hash a -> String -> IO (Maybe a)+lookup hash key+ = withHashPtr hash $ \ hashPtr ->+ withCStringLen key $ \ (keyPtr, keyLen) ->+ do valuePtr <- _get hashPtr (castPtr keyPtr) (fromIntegral keyLen)+ if valuePtr == nullPtr then+ return Nothing+ else+ -- valuePtr は hash の解放と同時に解放され得るのだが、+ -- unmarshal する前にそれが起きては困る。+ unmarshal (touchHash hash) valuePtr+ >>= return . Just+++getFirst :: Hash a -> IO (Maybe (HashIndex a))+getFirst hash+ = do pool <- newPool+ withPoolPtr pool $ \ poolPtr ->+ withHashPtr hash $ \ hashPtr ->+ do idxPtr <- _first poolPtr hashPtr+ if idxPtr == nullPtr then+ return Nothing+ else+ liftM Just $ wrapHashIdx (touchPool pool) idxPtr+++getThis :: HashValue a => HashIndex a -> IO (String, a)+getThis idx+ = do (key, valPtr) <- getThis' idx+ val <- unmarshal (touchHashIdx idx) (castPtr valPtr)+ return (key, val)+++getThis' :: HashIndex a -> IO (String, Ptr a)+getThis' idx+ = withHashIdxPtr idx $ \ idxPtr ->+ alloca $ \ keyPtrPtr ->+ alloca $ \ keyLenPtr ->+ alloca $ \ valPtrPtr ->+ do _this idxPtr keyPtrPtr keyLenPtr valPtrPtr+ keyPtr <- liftM castPtr (peek keyPtrPtr)+ keyLen <- liftM fromIntegral (peek keyLenPtr)+ key <- peekCStringLen (keyPtr, keyLen)+ valPtr <- peek valPtrPtr+ return (key, castPtr valPtr)+++getNext :: HashIndex a -> IO (Maybe (HashIndex a))+getNext idx+ = withHashIdxPtr idx $ \ idxPtr ->+ do idxPtr' <- _next idxPtr+ if idxPtr' == nullPtr then+ return Nothing+ else+ liftM Just $ wrapHashIdx (touchHashIdx idx) idxPtr'+ ++pairsToHash :: HashValue a => [(String, a)] -> IO (Hash a)+pairsToHash xs+ = do hash <- new+ mapM_ (uncurry $ update hash) xs+ return hash+++hashToPairs :: HashValue a => Hash a -> IO [(String, a)]+hashToPairs = mapHash (return . id)+++hashToValues :: HashValue a => Hash a -> IO [a]+hashToValues = mapHash (return . snd)+++mapHash :: HashValue a => ((String, a) -> IO b) -> Hash a -> IO [b]+mapHash f hash = getFirst hash >>= loop+ where+ loop Nothing = return []+ loop (Just idx) = do x <- f =<< getThis idx+ xs <- unsafeInterleaveIO $+ (getNext idx >>= loop)+ return (x:xs)+++mapHash' :: ((String, Ptr a) -> IO b) -> Hash a -> IO [b]+mapHash' f hash = getFirst hash >>= loop+ where+ loop Nothing = return []+ loop (Just idx) = do x <- f =<< getThis' idx+ xs <- unsafeInterleaveIO $+ (getNext idx >>= loop)+ return (x:xs)
+ Subversion/Pool.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# LINE 1 "Subversion/Pool.hsc" #-}+module Subversion.Pool+{-# LINE 2 "Subversion/Pool.hsc" #-}+ ( Pool+ , APR_POOL_T+ , newPool+ , withPoolPtr+ , touchPool+ )+ where++import Foreign hiding (Pool, newPool)+++newtype Pool = Pool (ForeignPtr APR_POOL_T)+data APR_POOL_T+++foreign import ccall unsafe "HsSVN_svn_pool_create"+ _create :: Ptr APR_POOL_T -> IO (Ptr APR_POOL_T)++foreign import ccall unsafe "&HsSVN_svn_pool_destroy"+ _destroy :: FunPtr (Ptr APR_POOL_T -> IO ())+++newPool :: IO Pool+newPool = _create nullPtr+ >>= newForeignPtr _destroy+ >>= return . Pool+++withPoolPtr :: Pool -> (Ptr APR_POOL_T -> IO a) -> IO a+withPoolPtr (Pool pool) = withForeignPtr pool+++touchPool :: Pool -> IO ()+touchPool (Pool pool) = touchForeignPtr pool
+ Subversion/Repository.hs view
@@ -0,0 +1,239 @@+{-# 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/Stream.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# LINE 1 "Subversion/Stream.hsc" #-}+module Subversion.Stream+{-# LINE 2 "Subversion/Stream.hsc" #-}+ ( Stream+ , SVN_STREAM_T++ , wrapStream+ , withStreamPtr++ , getEmptyStream+ , getStreamForStdOut++ , sRead+ , sReadBS+ , sReadLBS++ , sStrictRead+ , sStrictReadLBS++ , sWrite+ , sWriteBS+ , sWriteLBS++ , sClose+ )+ where++import Control.Monad+import Data.ByteString.Base+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable+import GHC.ForeignPtr as GF+import Subversion.Error+import Subversion.Pool+import Subversion.Types+import System.IO.Unsafe+++newtype Stream = Stream (ForeignPtr SVN_STREAM_T)+data SVN_STREAM_T+++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"+ _read :: Ptr SVN_STREAM_T -> Ptr CChar -> Ptr APR_SIZE_T -> IO (Ptr SVN_ERROR_T)++foreign import ccall unsafe "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"+ _close :: Ptr SVN_STREAM_T -> IO (Ptr SVN_ERROR_T)+++wrapStream :: IO () -> Ptr SVN_STREAM_T -> IO Stream+wrapStream finalizer ioPtr+ = do io <- newForeignPtr_ ioPtr+ GF.addForeignPtrConcFinalizer io finalizer+ return $ Stream io+++withStreamPtr :: Stream -> (Ptr SVN_STREAM_T -> IO a) -> IO a+withStreamPtr (Stream io) = withForeignPtr io+++getEmptyStream :: IO Stream+getEmptyStream + = do pool <- newPool+ withPoolPtr pool $ \ poolPtr ->+ wrapStream (touchPool pool) =<< _empty poolPtr+++getStreamForStdOut :: IO Stream+getStreamForStdOut+ = do pool <- newPool+ alloca $ \ ioPtrPtr ->+ withPoolPtr pool $ \ poolPtr ->+ do svnErr $ _for_stdout ioPtrPtr poolPtr+ wrapStream (touchPool pool) =<< peek ioPtrPtr+++sRead :: Stream -> IO String+sRead io+ = liftM L8.unpack $ sReadLBS io+++sStrictRead :: Stream -> IO String+sStrictRead io+ = liftM L8.unpack $ sStrictReadLBS io+++sReadBS :: Stream -> Int -> IO ByteString+sReadBS io maxLen+ = withStreamPtr io $ \ ioPtr ->+ createAndTrim maxLen $ \ bufPtr ->+ alloca $ \ bufLenPtr ->+ do poke bufLenPtr (fromIntegral maxLen)+ svnErr $ _read ioPtr (castPtr bufPtr) bufLenPtr+ liftM fromIntegral $ peek bufLenPtr+++sReadLBS :: Stream -> IO LazyByteString+sReadLBS io = lazyRead >>= return . LPS+ where+ chunkSize = 32 * 1024++ lazyRead = unsafeInterleaveIO loop++ loop = do bs <- sReadBS io chunkSize+ if B8.null bs then+ -- reached EOF+ return []+ else+ do bss <- lazyRead+ return (bs:bss)+++sStrictReadLBS :: Stream -> IO LazyByteString+sStrictReadLBS io = strictRead >>= return . LPS+ 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)++++sWrite :: Stream -> String -> IO ()+sWrite io str+ = sWriteLBS io (L8.pack str)+++sWriteBS :: Stream -> ByteString -> IO ()+sWriteBS io str+ = withStreamPtr io $ \ ioPtr ->+ unsafeUseAsCStringLen str $ \ (strPtr, strLen) ->+ alloca $ \ strLenPtr ->+ do poke strLenPtr (fromIntegral strLen)+ svnErr $ _write ioPtr strPtr strLenPtr+++sWriteLBS :: Stream -> LazyByteString -> IO ()+sWriteLBS io (LPS chunks)+ = mapM_ (sWriteBS io) chunks+++sClose :: Stream -> IO ()+sClose io+ = withStreamPtr io $ \ ioPtr ->+ svnErr $ _close ioPtr
Subversion/Stream.hsc view
@@ -24,9 +24,12 @@ where import Control.Monad-import Data.ByteString.Base-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.ByteString.Char8 as B8 hiding (ByteString)+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)+import Data.ByteString.Internal hiding (ByteString)+import Data.ByteString.Unsafe import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr@@ -96,7 +99,7 @@ = liftM L8.unpack $ sStrictReadLBS io -sReadBS :: Stream -> Int -> IO ByteString+sReadBS :: Stream -> Int -> IO Strict.ByteString sReadBS io maxLen = withStreamPtr io $ \ ioPtr -> createAndTrim maxLen $ \ bufPtr ->@@ -106,8 +109,8 @@ liftM fromIntegral $ peek bufLenPtr -sReadLBS :: Stream -> IO LazyByteString-sReadLBS io = lazyRead >>= return . LPS+sReadLBS :: Stream -> IO Lazy.ByteString+sReadLBS io = lazyRead >>= return . L8.fromChunks where chunkSize = 32 * 1024 @@ -122,8 +125,8 @@ return (bs:bss) -sStrictReadLBS :: Stream -> IO LazyByteString-sStrictReadLBS io = strictRead >>= return . LPS+sStrictReadLBS :: Stream -> IO Lazy.ByteString+sStrictReadLBS io = strictRead >>= return . L8.fromChunks where chunkSize = 32 * 1024 @@ -144,7 +147,7 @@ = sWriteLBS io (L8.pack str) -sWriteBS :: Stream -> ByteString -> IO ()+sWriteBS :: Stream -> Strict.ByteString -> IO () sWriteBS io str = withStreamPtr io $ \ ioPtr -> unsafeUseAsCStringLen str $ \ (strPtr, strLen) ->@@ -153,9 +156,9 @@ svnErr $ _write ioPtr strPtr strLenPtr -sWriteLBS :: Stream -> LazyByteString -> IO ()-sWriteLBS io (LPS chunks)- = mapM_ (sWriteBS io) chunks+sWriteLBS :: Stream -> Lazy.ByteString -> IO ()+sWriteLBS io chunks+ = mapM_ (sWriteBS io) (L8.toChunks chunks) sClose :: Stream -> IO ()
+ Subversion/String.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/String.hsc" #-}++{-# LINE 2 "Subversion/String.hsc" #-}++module Subversion.String+ ( SVN_STRING_T+ , withSvnString+ , withSvnString'+ , peekSvnString+ , peekSvnString'+ )+ where++import Data.ByteString.Base+import qualified Data.ByteString.Char8 as B8+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Subversion.Types++data SVN_STRING_T+++pokeData :: Ptr SVN_STRING_T -> Ptr CChar -> IO ()+pokeData = ((\hsc_ptr -> pokeByteOff hsc_ptr 0))+{-# LINE 25 "Subversion/String.hsc" #-}++peekData :: Ptr SVN_STRING_T -> IO (Ptr CChar)+peekData = ((\hsc_ptr -> peekByteOff hsc_ptr 0))+{-# LINE 28 "Subversion/String.hsc" #-}++pokeLen :: Ptr SVN_STRING_T -> APR_SIZE_T -> IO ()+pokeLen = ((\hsc_ptr -> pokeByteOff hsc_ptr 4))+{-# LINE 31 "Subversion/String.hsc" #-}++peekLen :: Ptr SVN_STRING_T -> IO APR_SIZE_T+peekLen = ((\hsc_ptr -> peekByteOff hsc_ptr 4))+{-# LINE 34 "Subversion/String.hsc" #-}+++withSvnString :: ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a+withSvnString bs f+ = unsafeUseAsCStringLen bs $ \ (bsBuf, bsLen) ->+ allocaBytes ((8)) $ \ obj ->+{-# LINE 40 "Subversion/String.hsc" #-}+ do pokeData obj bsBuf+ pokeLen obj (fromIntegral bsLen)+ f obj+++withSvnString' :: Maybe ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a+withSvnString' Nothing f = f nullPtr+withSvnString' (Just bs) f = withSvnString bs f+++peekSvnString :: Ptr SVN_STRING_T -> IO ByteString+peekSvnString obj+ | obj == nullPtr+ = fail "peekSvnString: got a null pointer"+ | otherwise+ = do buf <- peekData obj+ len <- peekLen obj+ B8.copyCStringLen (buf, fromIntegral len)+++peekSvnString' :: Ptr SVN_STRING_T -> IO (Maybe ByteString)+peekSvnString' obj+ | obj == nullPtr+ = return Nothing+ | otherwise+ = peekSvnString obj >>= return . Just
Subversion/String.hsc view
@@ -9,8 +9,9 @@ ) where -import Data.ByteString.Base-import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.ByteString.Char8 as B8 hiding (ByteString)+import Data.ByteString.Unsafe import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Ptr@@ -33,7 +34,7 @@ peekLen = (#peek svn_string_t, len) -withSvnString :: ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a+withSvnString :: Strict.ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a withSvnString bs f = unsafeUseAsCStringLen bs $ \ (bsBuf, bsLen) -> allocaBytes (#size svn_string_t) $ \ obj ->@@ -42,22 +43,22 @@ f obj -withSvnString' :: Maybe ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a+withSvnString' :: Maybe Strict.ByteString -> (Ptr SVN_STRING_T -> IO a) -> IO a withSvnString' Nothing f = f nullPtr withSvnString' (Just bs) f = withSvnString bs f -peekSvnString :: Ptr SVN_STRING_T -> IO ByteString+peekSvnString :: Ptr SVN_STRING_T -> IO Strict.ByteString peekSvnString obj | obj == nullPtr = fail "peekSvnString: got a null pointer" | otherwise = do buf <- peekData obj len <- peekLen obj- B8.copyCStringLen (buf, fromIntegral len)+ B8.packCStringLen (buf, fromIntegral len) -peekSvnString' :: Ptr SVN_STRING_T -> IO (Maybe ByteString)+peekSvnString' :: Ptr SVN_STRING_T -> IO (Maybe Strict.ByteString) peekSvnString' obj | obj == nullPtr = return Nothing
+ Subversion/Types.hs view
@@ -0,0 +1,130 @@+{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}+{-# OPTIONS_GHC -optc-DDARWIN #-}+{-# OPTIONS_GHC -optc-DSIGPROCMASK_SETS_THREAD_MASK #-}+{-# INCLUDE "HsSVN.h" #-}+{-# LINE 1 "Subversion/Types.hsc" #-}+{- -*- haskell -*- -}+{-# LINE 2 "Subversion/Types.hsc" #-}++-- #prune++-- |Some type definitions for Subversion.+++{-# LINE 8 "Subversion/Types.hsc" #-}++module Subversion.Types+ ( RevNum++ , APR_SIZE_T+ , APR_SSIZE_T+ , APR_STATUS_T++ , SVN_BOOLEAN_T+ , SVN_FILESIZE_T+ , SVN_NODE_KIND_T+ , SVN_REVNUM_T+ , SVN_VERSION_T++ , marshalBool+ , unmarshalBool++ , NodeKind(..) -- public+ , unmarshalNodeKind++ , Version(..) -- public+ , peekVersion+ )+ where++import Data.Int+import Data.Word+import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable++-- |@'RevNum'@ represents a revision number.+type RevNum = Int++type APR_SIZE_T = Word32+{-# LINE 43 "Subversion/Types.hsc" #-}+type APR_SSIZE_T = Int32+{-# LINE 44 "Subversion/Types.hsc" #-}+type APR_STATUS_T = Int32+{-# LINE 45 "Subversion/Types.hsc" #-}++type SVN_BOOLEAN_T = Int32+{-# LINE 47 "Subversion/Types.hsc" #-}+type SVN_FILESIZE_T = Int64+{-# LINE 48 "Subversion/Types.hsc" #-}+type SVN_NODE_KIND_T = Word32+{-# LINE 49 "Subversion/Types.hsc" #-}+type SVN_REVNUM_T = Int32+{-# LINE 50 "Subversion/Types.hsc" #-}+data SVN_VERSION_T+++marshalBool :: Bool -> SVN_BOOLEAN_T+marshalBool True = (1)+{-# LINE 55 "Subversion/Types.hsc" #-}+marshalBool False = (0)+{-# LINE 56 "Subversion/Types.hsc" #-}++unmarshalBool :: SVN_BOOLEAN_T -> Bool+unmarshalBool (1) = True+{-# LINE 59 "Subversion/Types.hsc" #-}+unmarshalBool (0) = False+{-# LINE 60 "Subversion/Types.hsc" #-}++-- |@'NodeKind'@ represents a type of node in Subversion filesystem.+data NodeKind+ = NoNode -- ^ The node is absent.+ | FileNode -- ^ The node is a file.+ | DirNode -- ^ The node is a directory.+ deriving (Show, Eq)++unmarshalNodeKind :: SVN_NODE_KIND_T -> NodeKind+unmarshalNodeKind (0) = NoNode+{-# LINE 70 "Subversion/Types.hsc" #-}+unmarshalNodeKind (1) = FileNode+{-# LINE 71 "Subversion/Types.hsc" #-}+unmarshalNodeKind (2) = DirNode+{-# LINE 72 "Subversion/Types.hsc" #-}++-- |@'Version'@ is version.+data Version = Version {+ verMajor :: Int -- ^ Major version number.+ , verMinor :: Int -- ^ Minor version number.+ , verPatch :: Int -- ^ Patch number.+ , verTag :: String -- ^ The version tag.+ } deriving (Show, Eq)+++peekVersion :: Ptr SVN_VERSION_T -> IO Version+peekVersion obj+ = do major <- peekVerMajor obj+ minor <- peekVerMinor obj+ patch <- peekVerPatch obj+ tag <- peekVerTag obj >>= peekCString+ return Version {+ verMajor = major+ , verMinor = minor+ , verPatch = patch+ , verTag = tag+ }+++peekVerMajor :: Ptr SVN_VERSION_T -> IO Int+peekVerMajor = ((\hsc_ptr -> peekByteOff hsc_ptr 0))+{-# LINE 98 "Subversion/Types.hsc" #-}++peekVerMinor :: Ptr SVN_VERSION_T -> IO Int+peekVerMinor = ((\hsc_ptr -> peekByteOff hsc_ptr 4))+{-# LINE 101 "Subversion/Types.hsc" #-}++peekVerPatch :: Ptr SVN_VERSION_T -> IO Int+peekVerPatch = ((\hsc_ptr -> peekByteOff hsc_ptr 8))+{-# LINE 104 "Subversion/Types.hsc" #-}++peekVerTag :: Ptr SVN_VERSION_T -> IO CString+peekVerTag = ((\hsc_ptr -> peekByteOff hsc_ptr 12))
Subversion/Types.hsc view
@@ -57,6 +57,7 @@ unmarshalBool :: SVN_BOOLEAN_T -> Bool unmarshalBool (#const TRUE ) = True unmarshalBool (#const FALSE) = False+unmarshalBool _ = undefined -- |@'NodeKind'@ represents a type of node in Subversion filesystem. data NodeKind@@ -69,6 +70,7 @@ unmarshalNodeKind (#const svn_node_none) = NoNode unmarshalNodeKind (#const svn_node_file) = FileNode unmarshalNodeKind (#const svn_node_dir ) = DirNode+unmarshalNodeKind _ = undefined -- |@'Version'@ is version. data Version = Version {
configure view
@@ -651,6 +651,7 @@ GREP EGREP APR_CONFIG+APU_CONFIG LIBOBJS LTLIBOBJS' ac_subst_files=''@@ -664,7 +665,8 @@ LDFLAGS CPPFLAGS CPP-APR_CONFIG'+APR_CONFIG+APU_CONFIG' # Initialize some variables set by options.@@ -1243,6 +1245,7 @@ you have headers in a nonstandard directory <include dir> CPP C preprocessor APR_CONFIG apr-config to use+ APU_CONFIG apu-config to use Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations.@@ -3693,6 +3696,55 @@ SVN_CFLAGS=`$APR_CONFIG --includes --cppflags`" $SVN_CFLAGS" SVN_LIBS=`$APR_CONFIG --link-ld --libs`" $SVN_LIBS"+++for ac_prog in apu-config+do+ # Extract the first word of "$ac_prog", so it can be a program name with args.+set dummy $ac_prog; ac_word=$2+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_APU_CONFIG+set}" = set; then+ echo $ECHO_N "(cached) $ECHO_C" >&6+else+ if test -n "$APU_CONFIG"; then+ ac_cv_prog_APU_CONFIG="$APU_CONFIG" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_APU_CONFIG="$ac_prog"+ echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+done+IFS=$as_save_IFS++fi+fi+APU_CONFIG=$ac_cv_prog_APU_CONFIG+if test -n "$APU_CONFIG"; then+ { echo "$as_me:$LINENO: result: $APU_CONFIG" >&5+echo "${ECHO_T}$APU_CONFIG" >&6; }+else+ { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi+++ test -n "$APU_CONFIG" && break+done+test -n "$APU_CONFIG" || APU_CONFIG="{ { echo "$as_me:$LINENO: error: apu-config is required. Hint: APU_CONFIG" >&5+echo "$as_me: error: apu-config is required. Hint: APU_CONFIG" >&2;}+ { (exit 1); exit 1; }; }"++SVN_CFLAGS=`$APU_CONFIG --includes`" $SVN_CFLAGS"+SVN_LIBS=`$APU_CONFIG --link-ld --libs`" $SVN_LIBS" # # Done the ugly checks #@@ -4366,11 +4418,12 @@ GREP!$GREP$ac_delim EGREP!$EGREP$ac_delim APR_CONFIG!$APR_CONFIG$ac_delim+APU_CONFIG!$APU_CONFIG$ac_delim LIBOBJS!$LIBOBJS$ac_delim LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 54; then+ if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 55; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
configure.ac view
@@ -36,6 +36,14 @@ [AC_MSG_ERROR([apr-config is required. Hint: APR_CONFIG])]) SVN_CFLAGS=`$APR_CONFIG --includes --cppflags`" $SVN_CFLAGS" SVN_LIBS=`$APR_CONFIG --link-ld --libs`" $SVN_LIBS"++AC_ARG_VAR([APU_CONFIG], [apu-config to use])+AC_CHECK_PROGS(+ [APU_CONFIG],+ [apu-config],+ [AC_MSG_ERROR([apu-config is required. Hint: APU_CONFIG])])+SVN_CFLAGS=`$APU_CONFIG --includes`" $SVN_CFLAGS"+SVN_LIBS=`$APU_CONFIG --link-ld --libs`" $SVN_LIBS" # # Done the ugly checks #