diff options
Diffstat (limited to 'Annex')
| -rw-r--r-- | Annex/Content.hs | 24 | ||||
| -rw-r--r-- | Annex/Transfer.hs | 37 |
2 files changed, 37 insertions, 24 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 266cb9ac1..5032e2691 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -16,7 +16,8 @@ module Annex.Content ( getViaTmp, getViaTmp', checkDiskSpaceToGet, - Verify(..), + VerifyConfig(..), + Types.Remote.unVerified, prepTmp, withTmp, checkDiskSpace, @@ -218,18 +219,19 @@ lockContent key a = do {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} -getViaTmp :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmp :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Types.Remote.Verification)) -> Annex Bool getViaTmp v key action = checkDiskSpaceToGet key False $ getViaTmp' v key action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} -getViaTmp' :: Verify -> Key -> (FilePath -> Annex Bool) -> Annex Bool +getViaTmp' :: VerifyConfig -> Key -> (FilePath -> Annex (Bool, Types.Remote.Verification)) -> Annex Bool getViaTmp' v key action = do tmpfile <- prepTmp key - ifM (action tmpfile) - ( ifM (verifyKeyContent v key tmpfile) + (ok, verification) <- action tmpfile + if ok + then ifM (verifyKeyContent v verification key tmpfile) ( do moveAnnex key tmpfile logStatus key InfoPresent @@ -241,8 +243,7 @@ getViaTmp' v key action = do ) -- On transfer failure, the tmp file is left behind, in case -- caller wants to resume its transfer - , return False - ) + else return False {- Verifies that a file is the expected content of a key. - Configuration can prevent verification, for either a @@ -253,8 +254,9 @@ getViaTmp' v key action = do - When the key's backend allows verifying the content (eg via checksum), - it is checked. -} -verifyKeyContent :: Verify -> Key -> FilePath -> Annex Bool -verifyKeyContent v k f = ifM (shouldVerify v) +verifyKeyContent :: VerifyConfig -> Types.Remote.Verification -> Key -> FilePath -> Annex Bool +verifyKeyContent _ Types.Remote.Verified _ _ = return True +verifyKeyContent v Types.Remote.UnVerified k f = ifM (shouldVerify v) ( verifysize <&&> verifycontent , return True ) @@ -268,9 +270,9 @@ verifyKeyContent v k f = ifM (shouldVerify v) Nothing -> return True Just verifier -> verifier k f -data Verify = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify +data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify -shouldVerify :: Verify -> Annex Bool +shouldVerify :: VerifyConfig -> Annex Bool shouldVerify AlwaysVerify = return True shouldVerify NoVerify = return False shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index a2bac34be..e72f737ea 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, FlexibleInstances #-} module Annex.Transfer ( module X, @@ -24,20 +24,31 @@ import Annex.Notification as X import Annex.Perms import Utility.Metered import Utility.LockPool +import Types.Remote (Verification(..)) import Control.Concurrent -type TransferAction = MeterUpdate -> Annex Bool - type TransferObserver = Bool -> Transfer -> TransferInfo -> Annex () +class Observable a where + observeBool :: a -> Bool + observeFailure :: a + +instance Observable Bool where + observeBool = id + observeFailure = False + +instance Observable (Bool, Verification) where + observeBool = fst + observeFailure = (False, UnVerified) + noObserver :: TransferObserver noObserver _ _ _ = noop -upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool +upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v upload u key f d o a _witness = runTransfer (Transfer Upload u key) f d o a -download :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool +download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a {- Runs a transfer action. Creates and locks the lock file while the @@ -52,7 +63,7 @@ download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a - An upload can be run from a read-only filesystem, and in this case - no transfer information or lock file is used. -} -runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool +runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v runTransfer = runTransfer' False {- Like runTransfer, but ignores any existing transfer lock file for the @@ -60,10 +71,10 @@ runTransfer = runTransfer' False - - Note that this may result in confusing progress meter display in the - webapp, if multiple processes are writing to the transfer info file. -} -alwaysRunTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool +alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True -runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool +runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v runTransfer' ignorelock t file shouldretry transferobserver transferaction = do info <- liftIO $ startTransferInfo file (meter, tfile, metervar) <- mkProgressUpdater t info @@ -72,12 +83,12 @@ runTransfer' ignorelock t file shouldretry transferobserver transferaction = do if inprogress && not ignorelock then do showNote "transfer already in progress, or unable to take transfer lock" - return False + return observeFailure else do - ok <- retry info metervar $ transferaction meter + v <- retry info metervar $ transferaction meter liftIO $ cleanup tfile lck - transferobserver ok t info - return ok + transferobserver (observeBool v) t info + return v where #ifndef mingw32_HOST_OS prep tfile mode info = do @@ -128,7 +139,7 @@ runTransfer' ignorelock t file shouldretry transferobserver transferaction = do let newinfo = oldinfo { bytesComplete = Just b } if shouldretry oldinfo newinfo then retry newinfo metervar run - else return False + else return observeFailure getbytescomplete metervar | transferDirection t == Upload = liftIO $ readMVar metervar |