testremote: Add testing of behavior when remote is not available
Added a mkUnavailable method, which a Remote can use to generate a version of itself that is not available. Implemented for several, but not yet all remotes. This allows testing that checkPresent properly throws an exceptions when it cannot check if a key is present or not. It also allows testing that the other methods don't throw exceptions in these circumstances. This immediately found several bugs, which this commit also fixes! * git remotes using ssh accidentially had checkPresent return an exception, rather than throwing it * The chunking code accidentially returned False rather than propigating an exception when there were no chunks and checkPresent threw an exception for the non-chunked key. This commit was sponsored by Carlo Matteo Capocasa.
This commit is contained in:
parent
2fd9518f72
commit
6adbd50cd9
18 changed files with 92 additions and 30 deletions
|
@ -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'
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue