HsSVN-0.2: Subversion/FileSystem/Revision.hs
{-# 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)