unify types
This commit is contained in:
parent
6873d785f0
commit
226781c047
12 changed files with 28 additions and 29 deletions
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 $
|
||||||
|
|
|
@ -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 ->
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue