unify types

This commit is contained in:
Joey Hess 2012-09-21 14:50:14 -04:00
parent 6873d785f0
commit 226781c047
12 changed files with 28 additions and 29 deletions

View file

@ -32,7 +32,7 @@ start key = ifM (inAnnex key)
liftIO exitFailure liftIO exitFailure
) )
fieldTransfer :: Direction -> Key -> (ProgressCallback -> Annex Bool) -> CommandStart fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
fieldTransfer direction key a = do fieldTransfer direction key a = do
afile <- Fields.getField Fields.associatedFile afile <- Fields.getField Fields.associatedFile
ok <- maybe (a $ const noop) ok <- maybe (a $ const noop)

View file

@ -74,7 +74,7 @@ percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
percentComplete (Transfer { transferKey = key }) info = percentComplete (Transfer { transferKey = key }) info =
percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info) percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
upload :: UUID -> Key -> AssociatedFile -> (ProgressCallback -> Annex Bool) -> Annex Bool upload :: UUID -> Key -> AssociatedFile -> (MeterUpdate -> Annex Bool) -> Annex Bool
upload u key file a = runTransfer (Transfer Upload u key) file a upload u key file a = runTransfer (Transfer Upload u key) file a
download :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool download :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
@ -87,7 +87,7 @@ download u key file a = runTransfer (Transfer Download u key) file (const a)
- If the transfer action returns False, the transfer info is - If the transfer action returns False, the transfer info is
- left in the failedTransferDir. - left in the failedTransferDir.
-} -}
runTransfer :: Transfer -> Maybe FilePath -> (ProgressCallback -> Annex Bool) -> Annex Bool runTransfer :: Transfer -> Maybe FilePath -> (MeterUpdate -> Annex Bool) -> Annex Bool
runTransfer t file a = do runTransfer t file a = do
tfile <- fromRepo $ transferFile t tfile <- fromRepo $ transferFile t
createAnnexDirectory $ takeDirectory tfile createAnnexDirectory $ takeDirectory tfile

View file

@ -11,7 +11,6 @@ module Messages (
showAction, showAction,
showProgress, showProgress,
metered, metered,
MeterUpdate,
showSideAction, showSideAction,
doSideAction, doSideAction,
doQuietSideAction, doQuietSideAction,
@ -42,6 +41,7 @@ import Common
import Types import Types
import Types.Messages import Types.Messages
import Types.Key import Types.Key
import Types.Remote
import qualified Annex import qualified Annex
import qualified Messages.JSON as JSON import qualified Messages.JSON as JSON
@ -63,7 +63,6 @@ showProgress = handle q $
{- Shows a progress meter while performing a transfer of a key. {- Shows a progress meter while performing a transfer of a key.
- The action is passed a callback to use to update the meter. -} - The action is passed a callback to use to update the meter. -}
type MeterUpdate = Integer -> IO ()
metered :: Key -> (MeterUpdate -> Annex a) -> Annex a metered :: Key -> (MeterUpdate -> Annex a) -> Annex a
metered key a = withOutputType $ go (keySize key) metered key a = withOutputType $ go (keySize key)
where where

View file

@ -113,14 +113,14 @@ bupSplitParams r buprepo k src = do
return $ bupParams "split" buprepo return $ bupParams "split" buprepo
(os ++ [Param "-n", Param (bupRef k), src]) (os ++ [Param "-n", Param (bupRef k), src])
store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r buprepo k _f p = do store r buprepo k _f _p = do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo k (File src) params <- bupSplitParams r buprepo k (File src)
liftIO $ boolSystem "bup" params liftIO $ boolSystem "bup" params
storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k p = do storeEncrypted r buprepo (cipher, enck) k _p = do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo enck (Param "-") params <- bupSplitParams r buprepo enck (Param "-")
liftIO $ catchBoolIO $ liftIO $ catchBoolIO $

View file

@ -124,7 +124,7 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withStoredFiles = withCheckedFiles doesFileExist withStoredFiles = withCheckedFiles doesFileExist
store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store d chunksize k _f p = do store d chunksize k _f p = do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
metered k $ \meterupdate -> metered k $ \meterupdate ->
@ -139,7 +139,7 @@ store d chunksize k _f p = do
storeSplit meterupdate chunksize dests storeSplit meterupdate chunksize dests
=<< L.readFile src =<< L.readFile src
storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted d chunksize (cipher, enck) k p = do storeEncrypted d chunksize (cipher, enck) k p = do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
metered k $ \meterupdate -> metered k $ \meterupdate ->

View file

@ -264,7 +264,7 @@ copyFromRemoteCheap r key file
| otherwise = return False | otherwise = return False
{- Tries to copy a key's content to a remote's annex. -} {- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Git.Repo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool copyToRemote :: Git.Repo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote r key file p copyToRemote r key file p
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do | not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key keysrc <- inRepo $ gitAnnexLocation key
@ -285,7 +285,7 @@ copyToRemote r key file p
rsyncHelper (Just p) =<< rsyncParamsRemote r False key keysrc file rsyncHelper (Just p) =<< rsyncParamsRemote r False key keysrc file
| otherwise = error "copying to non-ssh repo not supported" | otherwise = error "copying to non-ssh repo not supported"
rsyncHelper :: Maybe ProgressCallback -> [CommandParam] -> Annex Bool rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
rsyncHelper callback params = do rsyncHelper callback params = do
showOutput -- make way for progress bar showOutput -- make way for progress bar
ifM (liftIO $ (maybe rsync rsyncProgress callback) params) ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
@ -297,7 +297,7 @@ rsyncHelper callback params = do
{- Copys a file with rsync unless both locations are on the same {- Copys a file with rsync unless both locations are on the same
- filesystem. Then cp could be faster. -} - filesystem. Then cp could be faster. -}
rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> ProgressCallback -> Annex Bool rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool
rsyncOrCopyFile rsyncparams src dest p = rsyncOrCopyFile rsyncparams src dest p =
ifM (sameDeviceIds src dest) (dorsync, docopy) ifM (sameDeviceIds src dest) (dorsync, docopy)
where where

View file

@ -45,7 +45,7 @@ encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of
- to support storing and retrieving encrypted content. -} - to support storing and retrieving encrypted content. -}
encryptableRemote encryptableRemote
:: Maybe RemoteConfig :: Maybe RemoteConfig
-> ((Cipher, Key) -> Key -> ProgressCallback -> Annex Bool) -> ((Cipher, Key) -> Key -> MeterUpdate -> Annex Bool)
-> ((Cipher, Key) -> Key -> FilePath -> Annex Bool) -> ((Cipher, Key) -> Key -> FilePath -> Annex Bool)
-> Remote -> Remote
-> Remote -> Remote

View file

@ -103,12 +103,12 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
return False return False
) )
store :: String -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool store :: String -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store h k _f _p = do store h k _f _p = do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
runHook h "store" k (Just src) $ return True runHook h "store" k (Just src) $ return True
storeEncrypted :: String -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool storeEncrypted :: String -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp -> do storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp -> do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp

View file

@ -104,10 +104,10 @@ rsyncUrls o k = map use annexHashes
use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f) use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f)
f = keyFile k f = keyFile k
store :: RsyncOpts -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool store :: RsyncOpts -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store o k _f p = rsyncSend o p k <=< inRepo $ gitAnnexLocation k store o k _f p = rsyncSend o p k <=< inRepo $ gitAnnexLocation k
storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted o (cipher, enck) k p = withTmp enck $ \tmp -> do storeEncrypted o (cipher, enck) k p = withTmp enck $ \tmp -> do
src <- inRepo $ gitAnnexLocation k src <- inRepo $ gitAnnexLocation k
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
@ -191,7 +191,7 @@ withRsyncScratchDir a = do
nuke d = liftIO $ whenM (doesDirectoryExist d) $ nuke d = liftIO $ whenM (doesDirectoryExist d) $
removeDirectoryRecursive d removeDirectoryRecursive d
rsyncRemote :: RsyncOpts -> (Maybe ProgressCallback) -> [CommandParam] -> Annex Bool rsyncRemote :: RsyncOpts -> (Maybe MeterUpdate) -> [CommandParam] -> Annex Bool
rsyncRemote o callback params = do rsyncRemote o callback params = do
showOutput -- make way for progress bar showOutput -- make way for progress bar
ifM (liftIO $ (maybe rsync rsyncProgress callback) ps) ifM (liftIO $ (maybe rsync rsyncProgress callback) ps)
@ -207,7 +207,7 @@ rsyncRemote o callback params = do
{- To send a single key is slightly tricky; need to build up a temporary {- To send a single key is slightly tricky; need to build up a temporary
directory structure to pass to rsync so it can create the hash directory structure to pass to rsync so it can create the hash
directories. -} directories. -}
rsyncSend :: RsyncOpts -> ProgressCallback -> Key -> FilePath -> Annex Bool rsyncSend :: RsyncOpts -> MeterUpdate -> Key -> FilePath -> Annex Bool
rsyncSend o callback k src = withRsyncScratchDir $ \tmp -> do rsyncSend o callback k src = withRsyncScratchDir $ \tmp -> do
let dest = tmp </> Prelude.head (keyPaths k) let dest = tmp </> Prelude.head (keyPaths k)
liftIO $ createDirectoryIfMissing True $ parentDir dest liftIO $ createDirectoryIfMissing True $ parentDir dest

View file

@ -115,14 +115,14 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable -- be human-readable
M.delete "bucket" defaults M.delete "bucket" defaults
store :: Remote -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f p = s3Action r False $ \(conn, bucket) -> do store r k _f _p = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res s3Bool res
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) -> storeEncrypted r (cipher, enck) k _p = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file. -- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.) -- (An alternative would be chunking to to a constant size.)
withTmp enck $ \tmp -> do withTmp enck $ \tmp -> do

View file

@ -66,7 +66,7 @@ downloadKey key _file dest = get =<< getUrls key
downloadKeyCheap :: Key -> FilePath -> Annex Bool downloadKeyCheap :: Key -> FilePath -> Annex Bool
downloadKeyCheap _ _ = return False downloadKeyCheap _ _ = return False
uploadKey :: Key -> AssociatedFile -> ProgressCallback -> Annex Bool uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
uploadKey _ _ _ = do uploadKey _ _ _ = do
warning "upload to web not supported" warning "upload to web not supported"
return False return False

View file

@ -37,8 +37,8 @@ instance Eq (RemoteTypeA a) where
type AssociatedFile = Maybe FilePath type AssociatedFile = Maybe FilePath
{- An action that can be run repeatedly, feeding it the number of {- An action that can be run repeatedly, feeding it the number of
- bytes sent or retreived so far. -} - bytes sent or retrieved so far. -}
type ProgressCallback = (Integer -> IO ()) type MeterUpdate = (Integer -> IO ())
{- An individual remote. -} {- An individual remote. -}
data RemoteA a = Remote { data RemoteA a = Remote {
@ -49,7 +49,7 @@ data RemoteA a = Remote {
-- Remotes have a use cost; higher is more expensive -- Remotes have a use cost; higher is more expensive
cost :: Int, cost :: Int,
-- Transfers a key to the remote. -- Transfers a key to the remote.
storeKey :: Key -> AssociatedFile -> ProgressCallback -> a Bool, storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,
-- retrieves a key's contents to a file -- retrieves a key's contents to a file
retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool,
-- retrieves a key's contents to a tmp file, if it can be done cheaply -- retrieves a key's contents to a tmp file, if it can be done cheaply