diff --git a/HsSVN.cabal b/HsSVN.cabal --- a/HsSVN.cabal +++ b/HsSVN.cabal @@ -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 -Maintainer: - PHO -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 +Maintainer: PHO +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 diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,3 @@ +Changes from 0.1 to 0.2 +----------------------- +* HsSVN now requires GHC 6.8.1 diff --git a/Subversion.hs b/Subversion.hs new file mode 100644 --- /dev/null +++ b/Subversion.hs @@ -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 diff --git a/Subversion/Config.hs b/Subversion/Config.hs new file mode 100644 --- /dev/null +++ b/Subversion/Config.hs @@ -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 diff --git a/Subversion/Error.hs b/Subversion/Error.hs new file mode 100644 --- /dev/null +++ b/Subversion/Error.hs @@ -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) diff --git a/Subversion/FileSystem.hs b/Subversion/FileSystem.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem.hs @@ -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 diff --git a/Subversion/FileSystem/DirEntry.hs b/Subversion/FileSystem/DirEntry.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem/DirEntry.hs @@ -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 + } diff --git a/Subversion/FileSystem/DirEntry.hsc b/Subversion/FileSystem/DirEntry.hsc --- a/Subversion/FileSystem/DirEntry.hsc +++ b/Subversion/FileSystem/DirEntry.hsc @@ -27,7 +27,7 @@ instance HashValue DirEntry where - marshal ent + marshal _ = fail "marshalling DirEntry is not supported" unmarshal finalizer entPtr diff --git a/Subversion/FileSystem/PathChange.hs b/Subversion/FileSystem/PathChange.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem/PathChange.hs @@ -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 + } diff --git a/Subversion/FileSystem/PathChange.hsc b/Subversion/FileSystem/PathChange.hsc --- a/Subversion/FileSystem/PathChange.hsc +++ b/Subversion/FileSystem/PathChange.hsc @@ -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 diff --git a/Subversion/FileSystem/Revision.hs b/Subversion/FileSystem/Revision.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem/Revision.hs @@ -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) diff --git a/Subversion/FileSystem/Revision.hsc b/Subversion/FileSystem/Revision.hsc --- a/Subversion/FileSystem/Revision.hsc +++ b/Subversion/FileSystem/Revision.hsc @@ -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') diff --git a/Subversion/FileSystem/Root.hs b/Subversion/FileSystem/Root.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem/Root.hs @@ -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 diff --git a/Subversion/FileSystem/Root.hsc b/Subversion/FileSystem/Root.hsc --- a/Subversion/FileSystem/Root.hsc +++ b/Subversion/FileSystem/Root.hsc @@ -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 diff --git a/Subversion/FileSystem/Transaction.hs b/Subversion/FileSystem/Transaction.hs new file mode 100644 --- /dev/null +++ b/Subversion/FileSystem/Transaction.hs @@ -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 diff --git a/Subversion/FileSystem/Transaction.hsc b/Subversion/FileSystem/Transaction.hsc --- a/Subversion/FileSystem/Transaction.hsc +++ b/Subversion/FileSystem/Transaction.hsc @@ -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 diff --git a/Subversion/Hash.hs b/Subversion/Hash.hs new file mode 100644 --- /dev/null +++ b/Subversion/Hash.hs @@ -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) diff --git a/Subversion/Pool.hs b/Subversion/Pool.hs new file mode 100644 --- /dev/null +++ b/Subversion/Pool.hs @@ -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 diff --git a/Subversion/Repository.hs b/Subversion/Repository.hs new file mode 100644 --- /dev/null +++ b/Subversion/Repository.hs @@ -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 diff --git a/Subversion/Stream.hs b/Subversion/Stream.hs new file mode 100644 --- /dev/null +++ b/Subversion/Stream.hs @@ -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 diff --git a/Subversion/Stream.hsc b/Subversion/Stream.hsc --- a/Subversion/Stream.hsc +++ b/Subversion/Stream.hsc @@ -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 () diff --git a/Subversion/String.hs b/Subversion/String.hs new file mode 100644 --- /dev/null +++ b/Subversion/String.hs @@ -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 diff --git a/Subversion/String.hsc b/Subversion/String.hsc --- a/Subversion/String.hsc +++ b/Subversion/String.hsc @@ -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 diff --git a/Subversion/Types.hs b/Subversion/Types.hs new file mode 100644 --- /dev/null +++ b/Subversion/Types.hs @@ -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)) diff --git a/Subversion/Types.hsc b/Subversion/Types.hsc --- a/Subversion/Types.hsc +++ b/Subversion/Types.hsc @@ -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 { diff --git a/configure b/configure --- a/configure +++ b/configure @@ -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 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 diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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 #