diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Map.hs | 2 | ||||
| -rw-r--r-- | Command/SendKey.hs | 8 | ||||
| -rw-r--r-- | Command/TestRemote.hs | 35 | ||||
| -rw-r--r-- | Command/Unlock.hs | 13 |
4 files changed, 48 insertions, 10 deletions
diff --git a/Command/Map.hs b/Command/Map.hs index a62c3e1ad..b1d28113b 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -200,7 +200,7 @@ tryScan r where p = proc cmd $ toCommand params - configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] [] + configlist = Ssh.onRemote r (pipedconfig, return Nothing) "configlist" [] [] manualconfiglist = do gc <- Annex.getRemoteGitConfig r sshparams <- Ssh.toRepo r gc [Param sshcmd] diff --git a/Command/SendKey.hs b/Command/SendKey.hs index a201d1b89..6b5127aca 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -47,3 +47,11 @@ fieldTransfer direction key a = do (\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a) =<< Fields.getField Fields.remoteUUID liftIO $ exitBool ok + where + {- Allow the key to be sent to the remote even if there seems to be + - another transfer of that key going on to that remote. + - That one may be stale, etc. + -} + runner + | direction == Upload = alwaysRunTransfer + | otherwise = runTransfer diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index cb36b66ba..3e1933d21 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -62,13 +62,16 @@ start basesz ws = do ks <- mapM randKey (keySizes basesz fast) rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) rs' <- concat <$> mapM encryptionVariants rs - next $ perform rs' ks + unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r] + next $ perform rs' unavailrs ks -perform :: [Remote] -> [Key] -> CommandPerform -perform rs ks = do +perform :: [Remote] -> [Remote] -> [Key] -> CommandPerform +perform rs unavailrs ks = do st <- Annex.getState id - let tests = testGroup "Remote Tests" $ - [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ] + let tests = testGroup "Remote Tests" $ concat + [ [ testGroup "unavailable remote" (testUnavailable st r (Prelude.head ks)) | r <- unavailrs ] + , [ testGroup (desc r k) (test st r k) | k <- ks, r <- rs ] + ] ok <- case tryIngredients [consoleTestReporter] mempty tests of Nothing -> error "No tests found!?" Just act -> liftIO act @@ -155,6 +158,28 @@ test st r k = store = Remote.storeKey r k Nothing nullMeterUpdate remove = Remote.removeKey r k +testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree] +testUnavailable st r k = + [ check (== Right False) "removeKey" $ + Remote.removeKey r k + , check (== Right False) "storeKey" $ + Remote.storeKey r k Nothing nullMeterUpdate + , check (`notElem` [Right True, Right False]) "checkPresent" $ + Remote.checkPresent r k + , check (== Right False) "retrieveKeyFile" $ + getViaTmp k $ \dest -> + Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate + , check (== Right False) "retrieveKeyFileCheap" $ + getViaTmp k $ \dest -> + Remote.retrieveKeyFileCheap r k dest + ] + where + check checkval desc a = testCase desc $ do + v <- Annex.eval st $ do + Annex.setOutput QuietOutput + either (Left . show) Right <$> tryNonAsync a + checkval v @? ("(got: " ++ show v ++ ")") + cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup rs ks ok = do forM_ rs $ \r -> forM_ ks (Remote.removeKey r) diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 8cc72f3a3..19a1b258f 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -26,12 +26,17 @@ seek = withFilesInGit $ whenAnnexed start {- The unlock subcommand replaces the symlink with a copy of the file's - content. -} start :: FilePath -> Key -> CommandStart -start file key = stopUnless (inAnnex key) $ do +start file key = do showStart "unlock" file - ifM (checkDiskSpace Nothing key 0) - ( next $ perform file key + ifM (inAnnex key) + ( ifM (checkDiskSpace Nothing key 0) + ( next $ perform file key + , do + warning "not enough disk space to copy file" + next $ next $ return False + ) , do - warning "not enough disk space to copy file" + warning "content not present; cannot unlock" next $ next $ return False ) |