diff options
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Bup.hs | 1 | ||||
-rw-r--r-- | Remote/Ddar.hs | 1 | ||||
-rw-r--r-- | Remote/Directory.hs | 9 | ||||
-rw-r--r-- | Remote/External.hs | 4 | ||||
-rw-r--r-- | Remote/GCrypt.hs | 5 | ||||
-rw-r--r-- | Remote/Git.hs | 21 | ||||
-rw-r--r-- | Remote/Glacier.hs | 3 | ||||
-rw-r--r-- | Remote/Helper/Chunked.hs | 7 | ||||
-rw-r--r-- | Remote/Helper/Ssh.hs | 12 | ||||
-rw-r--r-- | Remote/Hook.hs | 4 | ||||
-rw-r--r-- | Remote/Rsync.hs | 1 | ||||
-rw-r--r-- | Remote/S3.hs | 3 | ||||
-rw-r--r-- | Remote/Tahoe.hs | 3 | ||||
-rw-r--r-- | Remote/Web.hs | 3 | ||||
-rw-r--r-- | Remote/WebDAV.hs | 3 |
15 files changed, 57 insertions, 23 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 80fffc056..0de0e2946 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -72,6 +72,7 @@ gen r u c gc = do , remotetype = remote , availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable , readonly = False + , mkUnavailable = return Nothing } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this buprepo) diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index beeb4d7cc..fc226ddff 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -69,6 +69,7 @@ gen r u c gc = do , remotetype = remote , availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable , readonly = False + , mkUnavailable = return Nothing } ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc specialcfg = (specialRemoteCfg c) diff --git a/Remote/Directory.hs b/Remote/Directory.hs index d9419757f..3137c9534 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -65,7 +65,9 @@ gen r u c gc = do localpath = Just dir, readonly = False, availability = LocallyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = gen r u c $ + gc { remoteAnnexDirectory = Just "/dev/null" } } where dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc @@ -196,5 +198,8 @@ checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k checkKey d _ k = liftIO $ ifM (anyM doesFileExist (locations d k)) ( return True - , error $ "directory " ++ d ++ " is not accessible" + , ifM (doesDirectoryExist d) + ( return False + , error $ "directory " ++ d ++ " is not accessible" + ) ) diff --git a/Remote/External.hs b/Remote/External.hs index 4fb760afd..6ba0e2f3a 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -65,7 +65,9 @@ gen r u c gc = do gitconfig = gc, readonly = False, availability = avail, - remotetype = remote + remotetype = remote, + mkUnavailable = gen r u c $ + gc { remoteAnnexExternalType = Just "!dne!" } } where externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 5edb3d022..a95f21669 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -120,6 +120,7 @@ gen' r u c gc = do , readonly = Git.repoIsHttp r , availability = availabilityCalc r , remotetype = remote + , mkUnavailable = return Nothing } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this rsyncopts) @@ -255,7 +256,7 @@ setupRepo gcryptid r {- Ask git-annex-shell to configure the repository as a gcrypt - repository. May fail if it is too old. -} - gitannexshellsetup = Ssh.onRemote r (boolSystem, False) + gitannexshellsetup = Ssh.onRemote r (boolSystem, return False) "gcryptsetup" [ Param gcryptid ] [] denyNonFastForwards = "receive.denyNonFastForwards" @@ -389,7 +390,7 @@ getGCryptId fast r | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r) | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) - [ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] [] + [ Ssh.onRemote r (Git.Config.fromPipe r, return (Left undefined)) "configlist" [] [] , getConfigViaRsync r ] | otherwise = return (Nothing, r) diff --git a/Remote/Git.hs b/Remote/Git.hs index 20955ff5b..5416a5cda 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -55,6 +55,7 @@ import Creds import Control.Concurrent import Control.Concurrent.MSampleVar import qualified Data.Map as M +import Network.URI remote :: RemoteType remote = RemoteType { @@ -156,8 +157,22 @@ gen r u c gc , readonly = Git.repoIsHttp r , availability = availabilityCalc r , remotetype = remote + , mkUnavailable = unavailable r u c gc } +unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) +unavailable r u c gc = gen r' u c gc + where + r' = case Git.location r of + Git.Local { Git.gitdir = d } -> + r { Git.location = Git.LocalUnknown d } + Git.Url url -> case uriAuthority url of + Just auth -> + let auth' = auth { uriRegName = "!dne!" } + in r { Git.location = Git.Url (url { uriAuthority = Just auth' })} + Nothing -> r { Git.location = Git.Unknown } + _ -> r -- already unavailable + {- Checks relatively inexpensively if a repository is available for use. -} repoAvail :: Git.Repo -> Annex Bool repoAvail r @@ -180,7 +195,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r | haveconfig r = return r -- already read | Git.repoIsSsh r = store $ do - v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] [] + v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] [] case v of Right r' | haveconfig r' -> return r' @@ -298,8 +313,8 @@ inAnnex rmt key ) checkremote = Ssh.inAnnex r key checklocal = guardUsable r (cantCheck r) $ - fromMaybe (cantCheck r) - <$> onLocal rmt (Annex.Content.inAnnexSafe key) + maybe (cantCheck r) return + =<< onLocal rmt (Annex.Content.inAnnexSafe key) keyUrls :: Remote -> Key -> [String] keyUrls r key = map tourl locs' diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index dd28def63..18038a79c 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -65,7 +65,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost localpath = Nothing, readonly = False, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = return Nothing } specialcfg = (specialRemoteCfg c) -- Disabled until jobList gets support for chunks. diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 5e4ea111f..271978658 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -348,11 +348,12 @@ checkPresentChunks checker u chunkconfig encryptor basek v <- check basek case v of Right True -> return True + Left e -> checklists (Just e) =<< chunkKeysOnly u basek _ -> checklists Nothing =<< chunkKeysOnly u basek | otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek where checklists Nothing [] = return False - checklists (Just deferrederror) [] = error deferrederror + checklists (Just deferrederror) [] = throwM deferrederror checklists d (l:ls) | not (null l) = do v <- checkchunks l @@ -362,14 +363,14 @@ checkPresentChunks checker u chunkconfig encryptor basek Right False -> checklists Nothing ls | otherwise = checklists d ls - checkchunks :: [Key] -> Annex (Either String Bool) + checkchunks :: [Key] -> Annex (Either SomeException Bool) checkchunks [] = return (Right True) checkchunks (k:ks) = do v <- check k case v of Right True -> checkchunks ks Right False -> return $ Right False - Left e -> return $ Left $ show e + Left e -> return $ Left e check = tryNonAsync . checker . encryptor diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 42d77ea59..9f0a77178 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -69,7 +69,7 @@ git_annex_shell r command params fields - a specified error value. -} onRemote :: Git.Repo - -> (FilePath -> [CommandParam] -> IO a, a) + -> (FilePath -> [CommandParam] -> IO a, Annex a) -> String -> [CommandParam] -> [(Field, String)] @@ -78,7 +78,7 @@ onRemote r (with, errorval) command params fields = do s <- git_annex_shell r command params fields case s of Just (c, ps) -> liftIO $ with c ps - Nothing -> return errorval + Nothing -> errorval {- Checks if a remote contains a key. -} inAnnex :: Git.Repo -> Key -> Annex Bool @@ -86,14 +86,14 @@ inAnnex r k = do showChecking r onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] [] where - check c p = dispatch <$> safeSystem c p - dispatch ExitSuccess = True - dispatch (ExitFailure 1) = False + check c p = dispatch =<< safeSystem c p + dispatch ExitSuccess = return True + dispatch (ExitFailure 1) = return False dispatch _ = cantCheck r {- Removes a key from a remote. -} dropKey :: Git.Repo -> Key -> Annex Bool -dropKey r key = onRemote r (boolSystem, False) "dropkey" +dropKey r key = onRemote r (boolSystem, return False) "dropkey" [ Params "--quiet --force" , Param $ key2file key ] diff --git a/Remote/Hook.hs b/Remote/Hook.hs index a2d096ecd..8e6ac439d 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -58,7 +58,9 @@ gen r u c gc = do gitconfig = gc, readonly = False, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = gen r u c $ + gc { remoteAnnexHookType = Just "!dne!" } } where hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index afd13abf0..f7b3461a0 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -82,6 +82,7 @@ gen r u c gc = do , readonly = False , availability = if islocal then LocallyAvailable else GloballyAvailable , remotetype = remote + , mkUnavailable = return Nothing } where specialcfg = (specialRemoteCfg c) diff --git a/Remote/S3.hs b/Remote/S3.hs index 1aba39245..ae1acd531 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost localpath = Nothing, readonly = False, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc } s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 6e52c0981..bde8ee9d7 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -83,7 +83,8 @@ gen r u c gc = do localpath = Nothing, readonly = False, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = return Nothing } tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) diff --git a/Remote/Web.hs b/Remote/Web.hs index 7bdd8d185..04b453277 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -61,7 +61,8 @@ gen r _ c gc = repo = r, readonly = True, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = return Nothing } downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 4d5887c6c..bb8b4cc06 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost localpath = Nothing, readonly = False, availability = GloballyAvailable, - remotetype = remote + remotetype = remote, + mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc } chunkconfig = getChunkConfig c |