module System.Gnome.VFS.Xfer (
XferProgressInfo(..),
XferOptions ( XferFollowLinks
, XferRecursive
, XferSamefs
, XferDeleteItems
, XferEmptyDirectories
, XferNewUniqueDirectory
, XferRemovesource
, XferUseUniqueNames
, XferLinkItems
, XferFollowLinksRecursive
, XferTargetDefaultPerms
),
XferOverwriteMode ( XferOverwriteModeAbort
, XferOverwriteModeReplace
, XferOverwriteModeSkip ),
XferErrorAction(..),
XferOverwriteAction(..),
XferProgressCallback,
XferErrorCallback,
XferOverwriteCallback,
XferDuplicateCallback,
xferURI,
xferURIList,
xferDeleteList
) where
import Control.Monad
import Data.Maybe (fromMaybe)
import System.Glib.FFI
import System.Glib.GList
import System.Glib.UTFString
import System.Gnome.VFS.Marshal
import System.Gnome.VFS.BasicTypes
instance Storable XferProgressInfo where
sizeOf _ = 80
alignment _ = alignment (undefined :: CString)
peek ptr =
do vfsStatus <- liftM cToEnum $ (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) ptr
phase <- liftM cToEnum $ (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
sourceName <- (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr CChar)}) ptr >>= maybePeek peekUTFString
targetName <- (\ptr -> do {peekByteOff ptr 16 ::IO (Ptr CChar)}) ptr >>= maybePeek peekUTFString
fileIndex <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 20 ::IO CULong}) ptr
filesTotal <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 24 ::IO CULong}) ptr
bytesTotal <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 28 ::IO CULLong}) ptr
fileSize <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 36 ::IO CULLong}) ptr
bytesCopied <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 44 ::IO CULLong}) ptr
totalBytesCopied <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 52 ::IO CULLong}) ptr
topLevelItem <- liftM toBool $ (\ptr -> do {peekByteOff ptr 68 ::IO CInt}) ptr
return $ XferProgressInfo vfsStatus
phase
sourceName
targetName
fileIndex
filesTotal
bytesTotal
fileSize
bytesCopied
totalBytesCopied
topLevelItem
poke _ = error "XferProgressInfo.poke not implemented"
type CXferProgressCallback = Ptr ()
-> ((Ptr ()))
-> IO CInt
xferProgressCallbackMarshal :: Maybe XferProgressCallback
-> XferErrorCallback
-> XferOverwriteCallback
-> Maybe XferDuplicateCallback
-> IO (FunPtr CXferProgressCallback)
xferProgressCallbackMarshal progressCallback
errorCallback
overwriteCallback
duplicateCallback =
makeXferProgressCallback cCallback
where cCallback :: CXferProgressCallback
cCallback cInfo cUserData =
do status <- liftM cToEnum $ (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) $ castPtr cInfo
info <- peek $ castPtr cInfo
case status of
XferProgressStatusOk ->
liftM fromBool $ progressCallback' info
XferProgressStatusVfserror ->
liftM cFromEnum $ errorCallback info
XferProgressStatusOverwrite ->
liftM cFromEnum $ overwriteCallback info
XferProgressStatusDuplicate ->
do duplicateCount <- liftM fromIntegral $ (\ptr -> do {peekByteOff ptr 64 ::IO CInt}) cInfo
duplicatePtr <- (\ptr -> do {peekByteOff ptr 60 ::IO (Ptr CChar)}) cInfo
duplicateName <- peekUTFString duplicatePtr
newDuplicateName <- duplicateCallback' info duplicateName duplicateCount
case newDuplicateName of
Just newDuplicateName' ->
do g_free $ castPtr duplicatePtr
newUTFString newDuplicateName' >>=
(\ptr val -> do {pokeByteOff ptr 60 (val::(Ptr CChar))}) cInfo
return 1
Nothing ->
return 0
progressCallback' =
fromMaybe (const $ return True) progressCallback
duplicateCallback' =
fromMaybe (\_ name _ -> return Nothing) duplicateCallback
foreign import ccall safe "wrapper"
makeXferProgressCallback :: CXferProgressCallback
-> IO (FunPtr CXferProgressCallback)
type CXfer = (CInt)
-> (CInt)
-> (CInt)
-> FunPtr CXferProgressCallback
-> ((Ptr ()))
-> IO (CInt)
type Xfer = [XferOptions]
-> Maybe XferProgressCallback
-> Maybe XferErrorCallback
-> Either XferOverwriteMode XferOverwriteCallback
-> Maybe XferDuplicateCallback
-> IO ()
marshalXfer :: CXfer
-> Xfer
marshalXfer cXfer xferOptions progressCallback errorCallback overwriteOpt duplicateCallback =
voidResultMarshal $ do
cProgressCallback <- xferProgressCallbackMarshal
progressCallback
errorCallback'
overwriteCallback
duplicateCallback
cResult <- cXfer (cFromFlags xferOptions)
(cFromEnum errorMode)
(cFromEnum overwriteMode)
cProgressCallback nullPtr
freeHaskellFunPtr cProgressCallback
return cResult
where
(overwriteMode, overwriteCallback) =
case overwriteOpt of
Left overwriteMode ->
(overwriteMode,
const $ return $ error "marshalXfer: overwrite callback called unexpectedly")
Right overwriteCallback ->
(XferOverwriteModeQuery,
overwriteCallback)
(errorMode, errorCallback') =
case errorCallback of
Just errorCallback' ->
(XferErrorModeQuery,
errorCallback')
Nothing ->
(XferErrorModeAbort,
const $ return $ error "marshalXfer: error callback called unexpectedly")
xferURI :: URI
-> URI
-> [XferOptions]
-> Maybe XferProgressCallback
-> Maybe XferErrorCallback
-> Either XferOverwriteMode XferOverwriteCallback
-> Maybe XferDuplicateCallback
-> IO ()
xferURI sourceURI targetURI =
marshalXfer ((\(URI arg1) (URI arg2) arg3 arg4 arg5 arg6 arg7 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->gnome_vfs_xfer_uri argPtr1 argPtr2 arg3 arg4 arg5 arg6 arg7) sourceURI targetURI)
withURIList :: [URI]
-> (GList -> IO a)
-> IO a
withURIList uriList action =
withMany withURI uriList $ \cURIList ->
toGList cURIList >>= action
xferURIList :: [(URI, URI)]
-> [XferOptions]
-> Maybe XferProgressCallback
-> Maybe XferErrorCallback
-> Either XferOverwriteMode XferOverwriteCallback
-> Maybe XferDuplicateCallback
-> IO ()
xferURIList sourceTargetURIList xferOptions progressCallback errorCallback overwriteOpt duplicateCallback =
withURIList sourceURIList $ \cSourceURIList ->
withURIList targetURIList $ \cTargetURIList ->
marshalXfer (gnome_vfs_xfer_uri_list cSourceURIList cTargetURIList)
xferOptions progressCallback
errorCallback overwriteOpt duplicateCallback
where (sourceURIList, targetURIList) = unzip sourceTargetURIList
xferDeleteList :: [URI]
-> [XferOptions]
-> Maybe XferProgressCallback
-> Maybe XferErrorCallback
-> IO ()
xferDeleteList sourceURIList xferOptions progressCallback errorCallback =
withURIList sourceURIList $ \cSourceURIList ->
do cProgressCallback <- xferProgressCallbackMarshal progressCallback
errorCallback'
(return $ error "xferDeleteList: overwrite callback called unexpectedly")
(return $ error "xferDeleteList: duplicate callback called unexpectedly")
voidResultMarshal $
gnome_vfs_xfer_delete_list
cSourceURIList
(cFromEnum errorMode)
(cFromFlags xferOptions)
cProgressCallback
nullPtr
where (errorMode, errorCallback') =
case errorCallback of
Just errorCallback' ->
(XferErrorModeQuery,
errorCallback')
Nothing ->
(XferErrorModeAbort,
const $ return XferErrorActionAbort)
foreign import ccall safe "g_free"
g_free :: ((Ptr ()) -> (IO ()))
foreign import ccall safe "gnome_vfs_xfer_uri"
gnome_vfs_xfer_uri :: ((Ptr URI) -> ((Ptr URI) -> (CInt -> (CInt -> (CInt -> ((FunPtr ((Ptr ()) -> ((Ptr ()) -> (IO CInt)))) -> ((Ptr ()) -> (IO CInt))))))))
foreign import ccall safe "gnome_vfs_xfer_uri_list"
gnome_vfs_xfer_uri_list :: ((Ptr ()) -> ((Ptr ()) -> (CInt -> (CInt -> (CInt -> ((FunPtr ((Ptr ()) -> ((Ptr ()) -> (IO CInt)))) -> ((Ptr ()) -> (IO CInt))))))))
foreign import ccall safe "gnome_vfs_xfer_delete_list"
gnome_vfs_xfer_delete_list :: ((Ptr ()) -> (CInt -> (CInt -> ((FunPtr ((Ptr ()) -> ((Ptr ()) -> (IO CInt)))) -> ((Ptr ()) -> (IO CInt))))))