summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/BitTorrent.hs15
-rw-r--r--Remote/Bup.hs10
-rw-r--r--Remote/Ddar.hs4
-rw-r--r--Remote/Directory.hs8
-rw-r--r--Remote/External.hs34
-rw-r--r--Remote/External/Types.hs8
-rw-r--r--Remote/GCrypt.hs14
-rw-r--r--Remote/Git.hs39
-rw-r--r--Remote/Glacier.hs14
-rw-r--r--Remote/Helper/Chunked.hs12
-rw-r--r--Remote/Helper/Encryptable.hs6
-rw-r--r--Remote/Helper/Http.hs2
-rw-r--r--Remote/Helper/Messages.hs2
-rw-r--r--Remote/Helper/Ssh.hs2
-rw-r--r--Remote/Hook.hs8
-rw-r--r--Remote/List.hs4
-rw-r--r--Remote/P2P.hs196
-rw-r--r--Remote/Rsync.hs8
-rw-r--r--Remote/S3.hs25
-rw-r--r--Remote/Tahoe.hs8
-rw-r--r--Remote/Web.hs2
-rw-r--r--Remote/WebDAV.hs25
22 files changed, 331 insertions, 115 deletions
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index a0ccf99df..0ec78aa64 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -21,6 +21,7 @@ import Types.CleanupActions
import Messages.Progress
import Utility.Metered
import Utility.Tmp
+import Utility.FileSystemEncoding
import Backend.URL
import Annex.Perms
import Annex.UUID
@@ -111,7 +112,7 @@ dropKey k = do
- implemented, it tells us nothing about the later state of the torrent.
-}
checkKey :: Key -> Annex Bool
-checkKey = error "cannot reliably check torrent status"
+checkKey = giveup "cannot reliably check torrent status"
getBitTorrentUrls :: Key -> Annex [URLString]
getBitTorrentUrls key = filter supported <$> getUrls key
@@ -138,7 +139,7 @@ checkTorrentUrl u = do
registerTorrentCleanup u
ifM (downloadTorrentFile u)
( torrentContents u
- , error "could not download torrent file"
+ , giveup "could not download torrent file"
)
{- To specify which file inside a multi-url torrent, the file number is
@@ -268,13 +269,13 @@ downloadTorrentContent k u dest filenum p = do
fs <- liftIO $ map fst <$> torrentFileSizes torrent
if length fs >= filenum
then return (fs !! (filenum - 1))
- else error "Number of files in torrent seems to have changed."
+ else giveup "Number of files in torrent seems to have changed."
checkDependencies :: Annex ()
checkDependencies = do
missing <- liftIO $ filterM (not <$$> inPath) deps
unless (null missing) $
- error $ "need to install additional software in order to download from bittorrent: " ++ unwords missing
+ giveup $ "need to install additional software in order to download from bittorrent: " ++ unwords missing
where
deps =
[ "aria2c"
@@ -343,7 +344,7 @@ torrentFileSizes torrent = do
let mkfile = joinPath . map (scrub . decodeBS)
b <- B.readFile torrent
return $ case readTorrent b of
- Left e -> error $ "failed to parse torrent: " ++ e
+ Left e -> giveup $ "failed to parse torrent: " ++ e
Right t -> case tInfo t of
SingleFile { tLength = l, tName = f } ->
[ (mkfile [f], l) ]
@@ -366,7 +367,7 @@ torrentFileSizes torrent = do
_ -> parsefailed (show v)
where
getfield = btshowmetainfo torrent
- parsefailed s = error $ "failed to parse btshowmetainfo output for torrent file: " ++ show s
+ parsefailed s = giveup $ "failed to parse btshowmetainfo output for torrent file: " ++ show s
-- btshowmetainfo outputs a list of "filename (size)"
splitsize d l = (scrub (d </> fn), sz)
@@ -379,7 +380,7 @@ torrentFileSizes torrent = do
#endif
-- a malicious torrent file might try to do directory traversal
scrub f = if isAbsolute f || any (== "..") (splitPath f)
- then error "found unsafe filename in torrent!"
+ then giveup "found unsafe filename in torrent!"
else f
torrentContents :: URLString -> Annex UrlContents
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 22510859c..332e8d5dc 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -84,7 +84,7 @@ gen r u c gc = do
(simplyPrepare $ checkKey r bupr')
this
where
- buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
+ buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc
specialcfg = (specialRemoteCfg c)
-- chunking would not improve bup
{ chunkConfig = NoChunks
@@ -95,14 +95,14 @@ bupSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
- let buprepo = fromMaybe (error "Specify buprepo=") $
+ let buprepo = fromMaybe (giveup "Specify buprepo=") $
M.lookup "buprepo" c
(c', _encsetup) <- encryptionSetup c gc
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)
showAction "bup init"
- unlessM (bup "init" buprepo []) $ error "bup init failed"
+ unlessM (bup "init" buprepo []) $ giveup "bup init failed"
storeBupUUID u buprepo
@@ -197,7 +197,7 @@ storeBupUUID u buprepo = do
showAction "storing uuid"
unlessM (onBupRemote r boolSystem "git"
[Param "config", Param "annex.uuid", Param v]) $
- error "ssh failed"
+ giveup "ssh failed"
else liftIO $ do
r' <- Git.Config.read r
let olduuid = Git.Config.get "annex.uuid" "" r'
@@ -251,7 +251,7 @@ bup2GitRemote r
| bupLocal r =
if "/" `isPrefixOf` r
then Git.Construct.fromAbsPath r
- else error "please specify an absolute path"
+ else giveup "please specify an absolute path"
| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
where
bits = split ":" r
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index fded8d420..dcb16f5dd 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -76,7 +76,7 @@ gen r u c gc = do
, claimUrl = Nothing
, checkUrl = Nothing
}
- ddarrepo = maybe (error "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)
+ ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)
specialcfg = (specialRemoteCfg c)
-- chunking would not improve ddar
{ chunkConfig = NoChunks
@@ -87,7 +87,7 @@ ddarSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
- let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
+ let ddarrepo = fromMaybe (giveup "Specify ddarrepo=") $
M.lookup "ddarrepo" c
(c', _encsetup) <- encryptionSetup c gc
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 3b26947b6..248e5d49f 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -75,17 +75,17 @@ gen r u c gc = do
, checkUrl = Nothing
}
where
- dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
+ dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
- let dir = fromMaybe (error "Specify directory=") $
+ let dir = fromMaybe (giveup "Specify directory=") $
M.lookup "directory" c
absdir <- liftIO $ absPath dir
liftIO $ unlessM (doesDirectoryExist absdir) $
- error $ "Directory does not exist: " ++ absdir
+ giveup $ "Directory does not exist: " ++ absdir
(c', _encsetup) <- encryptionSetup c gc
-- The directory is stored in git config, not in this remote's
@@ -216,6 +216,6 @@ checkKey d _ k = liftIO $
( return True
, ifM (doesDirectoryExist d)
( return False
- , error $ "directory " ++ d ++ " is not accessible"
+ , giveup $ "directory " ++ d ++ " is not accessible"
)
)
diff --git a/Remote/External.hs b/Remote/External.hs
index 65b05fe62..7091a657c 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -107,12 +107,12 @@ gen r u c gc
(simplyPrepare toremove)
(simplyPrepare tocheckkey)
rmt
- externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
+ externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc)
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
externalSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
- let externaltype = fromMaybe (error "Specify externaltype=") $
+ let externaltype = fromMaybe (giveup "Specify externaltype=") $
M.lookup "externaltype" c
(c', _encsetup) <- encryptionSetup c gc
@@ -124,7 +124,7 @@ externalSetup mu _ c gc = do
external <- newExternal externaltype u c' gc
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
INITREMOTE_SUCCESS -> Just noop
- INITREMOTE_FAILURE errmsg -> Just $ error errmsg
+ INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
_ -> Nothing
withExternalState external $
liftIO . atomically . readTVar . externalConfig
@@ -151,8 +151,7 @@ retrieve external = fileRetriever $ \d k p ->
TRANSFER_SUCCESS Download k'
| k == k' -> Just $ return ()
TRANSFER_FAILURE Download k' errmsg
- | k == k' -> Just $ do
- error errmsg
+ | k == k' -> Just $ giveup errmsg
_ -> Nothing
remove :: External -> Remover
@@ -168,7 +167,7 @@ remove external k = safely $
_ -> Nothing
checkKey :: External -> CheckPresent
-checkKey external k = either error id <$> go
+checkKey external k = either giveup id <$> go
where
go = handleRequest external (CHECKPRESENT k) Nothing $ \resp ->
case resp of
@@ -284,7 +283,7 @@ handleRequest' st external req mp responsehandler
handleRemoteRequest (VERSION _) =
sendMessage st external (ERROR "too late to send VERSION")
- handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err
+ handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err
send = sendMessage st external
@@ -332,7 +331,7 @@ receiveMessage st external handleresponse handlerequest handleasync =
Nothing -> case parseMessage s :: Maybe AsyncMessage of
Just msg -> maybe (protocolError True s) id (handleasync msg)
Nothing -> protocolError False s
- protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
+ protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
if parsed then "(command not allowed at this time)" else "(unable to parse command)"
protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
@@ -385,9 +384,6 @@ startExternal external = do
p <- propgit g basep
(Just hin, Just hout, Just herr, ph) <-
createProcess p `catchIO` runerr
- fileEncoding hin
- fileEncoding hout
- fileEncoding herr
stderrelay <- async $ errrelayer herr
checkearlytermination =<< getProcessExitCode ph
cv <- newTVarIO $ externalDefaultConfig external
@@ -413,14 +409,14 @@ startExternal external = do
environ <- propGitEnv g
return $ p { env = Just environ }
- runerr _ = error ("Cannot run " ++ basecmd ++ " -- Make sure it's in your PATH and is executable.")
+ runerr _ = giveup ("Cannot run " ++ basecmd ++ " -- Make sure it's in your PATH and is executable.")
checkearlytermination Nothing = noop
checkearlytermination (Just exitcode) = ifM (inPath basecmd)
- ( error $ unwords [ "failed to run", basecmd, "(" ++ show exitcode ++ ")" ]
+ ( giveup $ unwords [ "failed to run", basecmd, "(" ++ show exitcode ++ ")" ]
, do
path <- intercalate ":" <$> getSearchPath
- error $ basecmd ++ " is not installed in PATH (" ++ path ++ ")"
+ giveup $ basecmd ++ " is not installed in PATH (" ++ path ++ ")"
)
stopExternal :: External -> Annex ()
@@ -452,7 +448,7 @@ checkPrepared st external = do
v <- liftIO $ atomically $ readTVar $ externalPrepared st
case v of
Prepared -> noop
- FailedPrepare errmsg -> error errmsg
+ FailedPrepare errmsg -> giveup errmsg
Unprepared ->
handleRequest' st external PREPARE Nothing $ \resp ->
case resp of
@@ -460,7 +456,7 @@ checkPrepared st external = do
setprepared Prepared
PREPARE_FAILURE errmsg -> Just $ do
setprepared $ FailedPrepare errmsg
- error errmsg
+ giveup errmsg
_ -> Nothing
where
setprepared status = liftIO $ atomically $ void $
@@ -520,8 +516,8 @@ checkurl external url =
CHECKURL_MULTI ((_, sz, f):[]) ->
Just $ return $ UrlContents sz $ Just $ mkSafeFilePath f
CHECKURL_MULTI l -> Just $ return $ UrlMulti $ map mkmulti l
- CHECKURL_FAILURE errmsg -> Just $ error errmsg
- UNSUPPORTED_REQUEST -> error "CHECKURL not implemented by external special remote"
+ CHECKURL_FAILURE errmsg -> Just $ giveup errmsg
+ UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"
_ -> Nothing
where
mkmulti (u, s, f) = (u, s, mkSafeFilePath f)
@@ -530,7 +526,7 @@ retrieveUrl :: Retriever
retrieveUrl = fileRetriever $ \f k p -> do
us <- getWebUrls k
unlessM (downloadUrl k p us f) $
- error "failed to download content"
+ giveup "failed to download content"
checkKeyUrl :: Git.Repo -> CheckPresent
checkKeyUrl r k = do
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 2306989bb..ef8724ee7 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -250,14 +250,6 @@ instance Proto.Serializable Direction where
deserialize "RETRIEVE" = Just Download
deserialize _ = Nothing
-instance Proto.Serializable Key where
- serialize = key2file
- deserialize = file2key
-
-instance Proto.Serializable [Char] where
- serialize = id
- deserialize = Just
-
instance Proto.Serializable ProtocolVersion where
serialize = show
deserialize = readish
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index a0c8ecaf7..78ab6ed79 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -164,16 +164,16 @@ rsyncTransport r gc
othertransport = return ([], loc, AccessDirect)
noCrypto :: Annex a
-noCrypto = error "cannot use gcrypt remote without encryption enabled"
+noCrypto = giveup "cannot use gcrypt remote without encryption enabled"
unsupportedUrl :: a
-unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
+unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported"
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
- go Nothing = error "Specify gitrepo="
+ go Nothing = giveup "Specify gitrepo="
go (Just gitrepo) = do
(c', _encsetup) <- encryptionSetup c gc
inRepo $ Git.Command.run
@@ -200,7 +200,7 @@ gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
]
g <- inRepo Git.Config.reRead
case Git.GCrypt.remoteRepoId g (Just remotename) of
- Nothing -> error "unable to determine gcrypt-id of remote"
+ Nothing -> giveup "unable to determine gcrypt-id of remote"
Just gcryptid -> do
let u = genUUIDInNameSpace gCryptNameSpace gcryptid
if Just u == mu || isNothing mu
@@ -208,7 +208,7 @@ gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo)
gitConfigSpecialRemote u c' "gcrypt" (fromAccessMethod method)
return (c', u)
- else error $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")"
+ else giveup $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")"
{- Sets up the gcrypt repository. The repository is either a local
- repo, or it is accessed via rsync directly, or it is accessed over ssh
@@ -258,7 +258,7 @@ setupRepo gcryptid r
, Param rsyncurl
]
unless ok $
- error "Failed to connect to remote to set it up."
+ giveup "Failed to connect to remote to set it up."
return AccessDirect
{- Ask git-annex-shell to configure the repository as a gcrypt
@@ -337,7 +337,7 @@ retrieve r rsyncopts
| Git.repoIsSsh (repo r) = if accessShell r
then fileRetriever $ \f k p ->
unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $
- error "rsync failed"
+ giveup "rsync failed"
else fileRetriever $ Remote.Rsync.retrieve rsyncopts
| otherwise = unsupportedUrl
where
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 34bdd83a1..5eb6fbc9e 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -45,10 +45,13 @@ import Utility.CopyFile
#endif
import Utility.Env
import Utility.Batch
+import Utility.SimpleProtocol
import Remote.Helper.Git
import Remote.Helper.Messages
import qualified Remote.Helper.Ssh as Ssh
import qualified Remote.GCrypt
+import qualified Remote.P2P
+import P2P.Address
import Annex.Path
import Creds
import Annex.CatFile
@@ -95,20 +98,20 @@ list autoinit = do
-}
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gitSetup Nothing _ c _ = do
- let location = fromMaybe (error "Specify location=url") $
+ let location = fromMaybe (giveup "Specify location=url") $
Url.parseURIRelaxed =<< M.lookup "location" c
g <- Annex.gitRepo
u <- case filter (\r -> Git.location r == Git.Url location) (Git.remotes g) of
[r] -> getRepoUUID r
- [] -> error "could not find existing git remote with specified location"
- _ -> error "found multiple git remotes with specified location"
+ [] -> giveup "could not find existing git remote with specified location"
+ _ -> giveup "found multiple git remotes with specified location"
return (c, u)
gitSetup (Just u) _ c _ = do
inRepo $ Git.Command.run
[ Param "remote"
, Param "add"
- , Param $ fromMaybe (error "no name") (M.lookup "name" c)
- , Param $ fromMaybe (error "no location") (M.lookup "location" c)
+ , Param $ fromMaybe (giveup "no name") (M.lookup "name" c)
+ , Param $ fromMaybe (giveup "no location") (M.lookup "location" c)
]
return (c, u)
@@ -130,7 +133,9 @@ configRead autoinit r = do
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc
- | otherwise = go <$> remoteCost gc defcst
+ | otherwise = case repoP2PAddress r of
+ Nothing -> go <$> remoteCost gc defcst
+ Just addr -> Remote.P2P.chainGen addr r u c gc
where
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
go cst = Just new
@@ -202,7 +207,7 @@ tryGitConfigRead :: Bool -> Git.Repo -> Annex Git.Repo
tryGitConfigRead autoinit r
| haveconfig r = return r -- already read
| Git.repoIsSsh r = store $ do
- v <- Ssh.onRemote r (pipedconfig, return (Left $ error "configlist failed")) "configlist" [] configlistfields
+ v <- Ssh.onRemote r (pipedconfig, return (Left $ giveup "configlist failed")) "configlist" [] configlistfields
case v of
Right r'
| haveconfig r' -> return r'
@@ -321,7 +326,7 @@ inAnnex rmt key
showChecking r
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
( return True
- , error "not found"
+ , giveup "not found"
)
checkremote = Ssh.inAnnex r key
checklocal = guardUsable r (cantCheck r) $
@@ -352,12 +357,12 @@ dropKey r key
commitOnCleanup r $ onLocal r $ do
ensureInitialized
whenM (Annex.Content.inAnnex key) $ do
- Annex.Content.lockContentForRemoval key
- Annex.Content.removeAnnex
- logStatus key InfoMissing
+ Annex.Content.lockContentForRemoval key $ \lock -> do
+ Annex.Content.removeAnnex lock
+ logStatus key InfoMissing
Annex.Content.saveState True
return True
- | Git.repoIsHttp (repo r) = error "dropping from http remote not supported"
+ | Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported"
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
@@ -386,7 +391,7 @@ lockKey r key callback
, std_out = CreatePipe
, std_err = UseHandle nullh
}
- v <- liftIO $ tryIO $ hGetLine hout
+ v <- liftIO $ tryIO $ getProtocolLine hout
let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync
[ hPutStrLn hout ""
, hFlush hout
@@ -404,7 +409,7 @@ lockKey r key callback
void $ waitForProcess p
failedlock
Right l
- | l == Ssh.contentLockedMarker -> bracket_
+ | l == Just Ssh.contentLockedMarker -> bracket_
noop
signaldone
(withVerifiedCopy LockedCopy r checkexited callback)
@@ -414,7 +419,7 @@ lockKey r key callback
failedlock
| otherwise = failedlock
where
- failedlock = error "can't lock content"
+ failedlock = giveup "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -}
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
@@ -444,7 +449,7 @@ copyFromRemote' r key file dest meterupdate
| Git.repoIsSsh (repo r) = unVerified $ feedprogressback $ \p -> do
Ssh.rsyncHelper (Just (combineMeterUpdate meterupdate p))
=<< Ssh.rsyncParamsRemote False r Download key dest file
- | otherwise = error "copying from non-ssh, non-http remote not supported"
+ | otherwise = giveup "copying from non-ssh, non-http remote not supported"
where
{- Feed local rsync's progress info back to the remote,
- by forking a feeder thread that runs
@@ -547,7 +552,7 @@ copyToRemote' r key file meterupdate
unlocked <- isDirect <||> versionSupportsUnlockedPointers
Ssh.rsyncHelper (Just meterupdate)
=<< Ssh.rsyncParamsRemote unlocked r Upload key object file
- | otherwise = error "copying to non-ssh repo not supported"
+ | otherwise = giveup "copying to non-ssh repo not supported"
where
copylocal Nothing = return False
copylocal (Just (object, checksuccess)) = do
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index eae2dab68..77a907b97 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -146,7 +146,7 @@ retrieve r k sink = go =<< glacierEnv c gc u
, Param $ getVault $ config r
, Param $ archive r k
]
- go Nothing = error "cannot retrieve from glacier"
+ go Nothing = giveup "cannot retrieve from glacier"
go (Just e) = do
let cmd = (proc "glacier" (toCommand params))
{ env = Just e
@@ -182,7 +182,7 @@ checkKey r k = do
showChecking r
go =<< glacierEnv (config r) (gitconfig r) (uuid r)
where
- go Nothing = error "cannot check glacier"
+ go Nothing = giveup "cannot check glacier"
go (Just e) = do
{- glacier checkpresent outputs the archive name to stdout if
- it's present. -}
@@ -190,7 +190,7 @@ checkKey r k = do
let probablypresent = key2file k `elem` lines s
if probablypresent
then ifM (Annex.getFlag "trustglacier")
- ( return True, error untrusted )
+ ( return True, giveup untrusted )
else return False
params = glacierParams (config r)
@@ -222,7 +222,7 @@ glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam]
glacierParams c params = datacenter:params
where
datacenter = Param $ "--region=" ++
- fromMaybe (error "Missing datacenter configuration")
+ fromMaybe (giveup "Missing datacenter configuration")
(M.lookup "datacenter" c)
glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
@@ -239,7 +239,7 @@ glacierEnv c gc u = do
(uk, pk) = credPairEnvironment creds
getVault :: RemoteConfig -> Vault
-getVault = fromMaybe (error "Missing vault configuration")
+getVault = fromMaybe (giveup "Missing vault configuration")
. M.lookup "vault"
archive :: Remote -> Key -> Archive
@@ -249,7 +249,7 @@ archive r k = fileprefix ++ key2file k
genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genVault c gc u = unlessM (runGlacier c gc u params) $
- error "Failed creating glacier vault."
+ giveup "Failed creating glacier vault."
where
params =
[ Param "vault"
@@ -312,7 +312,7 @@ jobList r keys = go =<< glacierEnv (config r) (gitconfig r) (uuid r)
checkSaneGlacierCommand :: IO ()
checkSaneGlacierCommand =
whenM ((Nothing /=) <$> catchMaybeIO shouldfail) $
- error wrongcmd
+ giveup wrongcmd
where
test = proc "glacier" ["--compatibility-test-git-annex"]
shouldfail = withQuietOutput createProcessSuccess test
diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs
index e3cf0d27b..f3c69c38d 100644
--- a/Remote/Helper/Chunked.hs
+++ b/Remote/Helper/Chunked.hs
@@ -59,7 +59,7 @@ getChunkConfig m =
Just size
| size == 0 -> NoChunks
| size > 0 -> c (fromInteger size)
- _ -> error $ "bad configuration " ++ f ++ "=" ++ v
+ _ -> giveup $ "bad configuration " ++ f ++ "=" ++ v
-- An infinite stream of chunk keys, starting from chunk 1.
newtype ChunkKeyStream = ChunkKeyStream [Key]
@@ -250,9 +250,9 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
let ls' = maybe ls (setupResume ls) currsize
if any null ls'
then return True -- dest is already complete
- else firstavail currsize ls' `catchNonAsync` giveup
+ else firstavail currsize ls' `catchNonAsync` unable
- giveup e = do
+ unable e = do
warning (show e)
return False
@@ -273,10 +273,10 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
let sz = toBytesProcessed $
fromMaybe 0 $ keyChunkSize k
getrest p h sz sz ks
- `catchNonAsync` giveup
+ `catchNonAsync` unable
case v of
Left e
- | null ls -> giveup e
+ | null ls -> unable e
| otherwise -> firstavail currsize ls
Right r -> return r
@@ -286,7 +286,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
liftIO $ p' zeroBytesProcessed
ifM (retriever (encryptor k) p' $ tosink (Just h) p')
( getrest p h sz (addBytesProcessed bytesprocessed sz) ks
- , giveup "chunk retrieval failed"
+ , unable "chunk retrieval failed"
)
getunchunked = retriever (encryptor basek) basep $ tosink Nothing basep
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index 05c3e38a5..45ceae068 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -66,14 +66,14 @@ encryptionSetup c gc = do
encsetup $ genEncryptedCipher cmd (c, gc) key Hybrid
Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey
Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key
- _ -> error $ "Specify " ++ intercalate " or "
+ _ -> giveup $ "Specify " ++ intercalate " or "
(map ("encryption=" ++)
["none","shared","hybrid","pubkey", "sharedpubkey"])
++ "."
- key = fromMaybe (error "Specifiy keyid=...") $ M.lookup "keyid" c
+ key = fromMaybe (giveup "Specifiy keyid=...") $ M.lookup "keyid" c
newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++
maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c)
- cannotchange = error "Cannot set encryption type of existing remotes."
+ cannotchange = giveup "Cannot set encryption type of existing remotes."
-- Update an existing cipher if possible.
updateCipher cmd v = case v of
SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs
index f01dfd922..ebe0f2598 100644
--- a/Remote/Helper/Http.hs
+++ b/Remote/Helper/Http.hs
@@ -70,7 +70,7 @@ handlePopper numchunks chunksize meterupdate h sink = do
-- meter as it goes.
httpBodyRetriever :: FilePath -> MeterUpdate -> Response BodyReader -> IO ()
httpBodyRetriever dest meterupdate resp
- | responseStatus resp /= ok200 = error $ show $ responseStatus resp
+ | responseStatus resp /= ok200 = giveup $ show $ responseStatus resp
| otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed)
where
reader = responseBody resp
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index 484ea1955..014825776 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -29,7 +29,7 @@ showChecking :: Describable a => a -> Annex ()
showChecking v = showAction $ "checking " ++ describe v
cantCheck :: Describable a => a -> e
-cantCheck v = error $ "unable to check " ++ describe v
+cantCheck v = giveup $ "unable to check " ++ describe v
showLocking :: Describable a => a -> Annex ()
showLocking v = showAction $ "locking " ++ describe v
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 4ec772296..dff16b656 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -29,7 +29,7 @@ import Config
toRepo :: Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
toRepo r gc sshcmd = do
let opts = map Param $ remoteAnnexSshOptions gc
- let host = fromMaybe (error "bad ssh url") $ Git.Url.hostuser r
+ let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r
params <- sshOptions (host, Git.Url.port r) gc opts
return $ params ++ Param host : sshcmd
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 7d8f7f096..6abffe117 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -68,12 +68,12 @@ gen r u c gc = do
, checkUrl = Nothing
}
where
- hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
+ hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
hookSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
- let hooktype = fromMaybe (error "Specify hooktype=") $
+ let hooktype = fromMaybe (giveup "Specify hooktype=") $
M.lookup "hooktype" c
(c', _encsetup) <- encryptionSetup c gc
gitConfigSpecialRemote u c' "hooktype" hooktype
@@ -129,7 +129,7 @@ store h = fileStorer $ \k src _p ->
retrieve :: HookName -> Retriever
retrieve h = fileRetriever $ \d k _p ->
unlessM (runHook h "retrieve" k (Just d) $ return True) $
- error "failed to retrieve content"
+ giveup "failed to retrieve content"
retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ _ = return False
@@ -145,7 +145,7 @@ checkKey r h k = do
where
action = "checkpresent"
findkey s = key2file k `elem` lines s
- check Nothing = error $ action ++ " hook misconfigured"
+ check Nothing = giveup $ action ++ " hook misconfigured"
check (Just hook) = do
environ <- hookEnv action k Nothing
findkey <$> readProcessEnv "sh" ["-c", hook] environ
diff --git a/Remote/List.hs b/Remote/List.hs
index 9c231b124..a5e305622 100644
--- a/Remote/List.hs
+++ b/Remote/List.hs
@@ -23,6 +23,7 @@ import qualified Git.Config
import qualified Remote.Git
import qualified Remote.GCrypt
+import qualified Remote.P2P
#ifdef WITH_S3
import qualified Remote.S3
#endif
@@ -44,6 +45,7 @@ remoteTypes :: [RemoteType]
remoteTypes =
[ Remote.Git.remote
, Remote.GCrypt.remote
+ , Remote.P2P.remote
#ifdef WITH_S3
, Remote.S3.remote
#endif
@@ -116,4 +118,4 @@ updateRemote remote = do
{- Checks if a remote is syncable using git. -}
gitSyncableRemote :: Remote -> Bool
gitSyncableRemote r = remotetype r `elem`
- [ Remote.Git.remote, Remote.GCrypt.remote ]
+ [ Remote.Git.remote, Remote.GCrypt.remote, Remote.P2P.remote ]
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
new file mode 100644
index 000000000..f0848f831
--- /dev/null
+++ b/Remote/P2P.hs
@@ -0,0 +1,196 @@
+{- git remotes using the git-annex P2P protocol
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.P2P (
+ remote,
+ chainGen
+) where
+
+import Annex.Common
+import qualified Annex
+import qualified P2P.Protocol as P2P
+import P2P.Address
+import P2P.Annex
+import P2P.IO
+import P2P.Auth
+import Types.Remote
+import Types.GitConfig
+import qualified Git
+import Annex.UUID
+import Config
+import Config.Cost
+import Remote.Helper.Git
+import Messages.Progress
+import Utility.Metered
+import Utility.AuthToken
+import Types.NumCopies
+
+import Control.Concurrent
+import Control.Concurrent.STM
+
+remote :: RemoteType
+remote = RemoteType {
+ typename = "p2p",
+ -- Remote.Git takes care of enumerating P2P remotes,
+ -- and will call chainGen on them.
+ enumerate = const (return []),
+ generate = \_ _ _ _ -> return Nothing,
+ setup = error "P2P remotes are set up using git-annex p2p"
+}
+
+chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
+chainGen addr r u c gc = do
+ connpool <- mkConnectionPool
+ cst <- remoteCost gc expensiveRemoteCost
+ let this = Remote
+ { uuid = u
+ , cost = cst
+ , name = Git.repoDescribe r
+ , storeKey = store u addr connpool
+ , retrieveKeyFile = retrieve u addr connpool
+ , retrieveKeyFileCheap = \_ _ _ -> return False
+ , removeKey = remove u addr connpool
+ , lockContent = Just (lock u addr connpool)
+ , checkPresent = checkpresent u addr connpool
+ , checkPresentCheap = False
+ , whereisKey = Nothing
+ , remoteFsck = Nothing
+ , repairRepo = Nothing
+ , config = c
+ , localpath = Nothing
+ , repo = r
+ , gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
+ , readonly = False
+ , availability = GloballyAvailable
+ , remotetype = remote
+ , mkUnavailable = return Nothing
+ , getInfo = gitRepoInfo this
+ , claimUrl = Nothing
+ , checkUrl = Nothing
+ }
+ return (Just this)
+
+store :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+store u addr connpool k af p =
+ metered (Just p) k $ \p' -> fromMaybe False
+ <$> runProto u addr connpool (P2P.put k af p')
+
+retrieve :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
+retrieve u addr connpool k af dest p = unVerified $
+ metered (Just p) k $ \p' -> fromMaybe False
+ <$> runProto u addr connpool (P2P.get dest k af p')
+
+remove :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool
+remove u addr connpool k = fromMaybe False
+ <$> runProto u addr connpool (P2P.remove k)
+
+checkpresent :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool
+checkpresent u addr connpool k = maybe unavail return
+ =<< runProto u addr connpool (P2P.checkPresent k)
+ where
+ unavail = giveup "can't connect to peer"
+
+lock :: UUID -> P2PAddress -> ConnectionPool -> Key -> (VerifiedCopy -> Annex r) -> Annex r
+lock u addr connpool k callback =
+ withConnection u addr connpool $ \conn -> do
+ connv <- liftIO $ newMVar conn
+ let runproto d p = do
+ c <- liftIO $ takeMVar connv
+ (c', mr) <- runProto' p c
+ liftIO $ putMVar connv c'
+ return (fromMaybe d mr)
+ r <- P2P.lockContentWhile runproto k go
+ conn' <- liftIO $ takeMVar connv
+ return (conn', r)
+ where
+ go False = giveup "can't lock content"
+ go True = withVerifiedCopy LockedCopy u (return True) callback
+
+-- | A connection to the peer.
+data Connection
+ = OpenConnection P2PConnection
+ | ClosedConnection
+
+type ConnectionPool = TVar [Connection]
+
+mkConnectionPool :: Annex ConnectionPool
+mkConnectionPool = liftIO $ newTVarIO []
+
+-- Runs the Proto action.
+runProto :: UUID -> P2PAddress -> ConnectionPool -> P2P.Proto a -> Annex (Maybe a)
+runProto u addr connpool a = withConnection u addr connpool (runProto' a)
+
+runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a)
+runProto' _ ClosedConnection = return (ClosedConnection, Nothing)
+runProto' a (OpenConnection conn) = do
+ v <- runFullProto Client conn a
+ -- When runFullProto fails, the connection is no longer usable,
+ -- so close it.
+ case v of
+ Left e -> do
+ warning $ "Lost connection to peer (" ++ e ++ ")"
+ liftIO $ closeConnection conn
+ return (ClosedConnection, Nothing)
+ Right r -> return (OpenConnection conn, Just r)
+
+-- Uses an open connection if one is available in the ConnectionPool;
+-- otherwise opens a new connection.
+--
+-- Once the action is done, the connection is added back to the
+-- ConnectionPool, unless it's no longer open.
+withConnection :: UUID -> P2PAddress -> ConnectionPool -> (Connection -> Annex (Connection, a)) -> Annex a
+withConnection u addr connpool a = bracketOnError get cache go
+ where
+ get = do
+ mc <- liftIO $ atomically $ do
+ l <- readTVar connpool
+ case l of
+ [] -> do
+ writeTVar connpool []
+ return Nothing
+ (c:cs) -> do
+ writeTVar connpool cs
+ return (Just c)
+ maybe (openConnection u addr) return mc
+
+ cache ClosedConnection = return ()
+ cache conn = liftIO $ atomically $ modifyTVar' connpool (conn:)
+
+ go conn = do
+ (conn', r) <- a conn
+ cache conn'
+ return r
+
+openConnection :: UUID -> P2PAddress -> Annex Connection
+openConnection u addr = do
+ g <- Annex.gitRepo
+ v <- liftIO $ tryNonAsync $ connectPeer g addr
+ case v of
+ Right conn -> do
+ myuuid <- getUUID
+ authtoken <- fromMaybe nullAuthToken
+ <$> loadP2PRemoteAuthToken addr
+ res <- liftIO $ runNetProto conn $
+ P2P.auth myuuid authtoken
+ case res of
+ Right (Just theiruuid)
+ | u == theiruuid -> return (OpenConnection conn)
+ | otherwise -> do
+ liftIO $ closeConnection conn
+ warning "Remote peer uuid seems to have changed."
+ return ClosedConnection
+ Right Nothing -> do
+ warning "Unable to authenticate with peer."
+ liftIO $ closeConnection conn
+ return ClosedConnection
+ Left e -> do
+ warning $ "Problem communicating with peer. (" ++ e ++ ")"
+ liftIO $ closeConnection conn
+ return ClosedConnection
+ Left e -> do
+ warning $ "Unable to connect to peer. (" ++ show e ++ ")"
+ return ClosedConnection
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 4695ac7a9..22ef0b2cf 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -53,7 +53,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
(transport, url) <- rsyncTransport gc $
- fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
+ fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc
let o = genRsyncOpts c gc transport url
let islocal = rsyncUrlIsPath $ rsyncUrl o
return $ Just $ specialRemote' specialcfg c
@@ -127,7 +127,7 @@ rsyncTransport gc url
(map Param $ loginopt ++ sshopts')
"rsh":rshopts -> return $ map Param $ "rsh" :
loginopt ++ rshopts
- rsh -> error $ "Unknown Rsync transport: "
+ rsh -> giveup $ "Unknown Rsync transport: "
++ unwords rsh
| otherwise = return ([], url)
where
@@ -141,7 +141,7 @@ rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig ->
rsyncSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
- let url = fromMaybe (error "Specify rsyncurl=") $
+ let url = fromMaybe (giveup "Specify rsyncurl=") $
M.lookup "rsyncurl" c
(c', _encsetup) <- encryptionSetup c gc
@@ -188,7 +188,7 @@ store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
retrieve :: RsyncOpts -> FilePath -> Key -> MeterUpdate -> Annex ()
retrieve o f k p =
unlessM (rsyncRetrieve o k f (Just p)) $
- error "rsync failed"
+ giveup "rsync failed"
retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 97265e148..2b7c58e6f 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -49,6 +49,13 @@ import Annex.Content
import Annex.Url (withUrlOptions)
import Utility.Url (checkBoth, managerSettings, closeManager)
+#if MIN_VERSION_http_client(0,5,0)
+import Network.HTTP.Client (responseTimeoutNone)
+#else
+responseTimeoutNone :: Maybe Int
+responseTimeoutNone = Nothing
+#endif
+
type BucketName = String
remote :: RemoteType
@@ -136,7 +143,7 @@ s3Setup' new u mcreds c gc
-- Ensure user enters a valid bucket name, since
-- this determines the name of the archive.org item.
let validbucket = replace " " "-" $
- fromMaybe (error "specify bucket=") $
+ fromMaybe (giveup "specify bucket=") $
getBucketName c'
let archiveconfig =
-- IA acdepts x-amz-* as an alias for x-archive-*
@@ -193,7 +200,7 @@ store _r info h = fileStorer $ \k f p -> do
uploadid <- S3.imurUploadId <$> sendS3Handle h startreq
-- The actual part size will be a even multiple of the
- -- 32k chunk size that hGetUntilMetered uses.
+ -- 32k chunk size that lazy ByteStrings use.
let partsz' = (partsz `div` toInteger defaultChunkSize) * toInteger defaultChunkSize
-- Send parts of the file, taking care to stream each part
@@ -252,7 +259,7 @@ retrieve r info Nothing = case getpublicurl info of
return False
Just geturl -> fileRetriever $ \f k p ->
unlessM (downloadUrl k p [geturl k] f) $
- error "failed to download content"
+ giveup "failed to download content"
retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
@@ -301,7 +308,7 @@ checkKey r info (Just h) k = do
checkKey r info Nothing k = case getpublicurl info of
Nothing -> do
warnMissingCredPairFor "S3" (AWS.creds $ uuid r)
- error "No S3 credentials configured"
+ giveup "No S3 credentials configured"
Just geturl -> do
showChecking r
withUrlOptions $ checkBoth (geturl k) (keySize k)
@@ -415,7 +422,7 @@ withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of
Just h -> a h
Nothing -> do
warnMissingCredPairFor "S3" (AWS.creds u)
- error "No S3 credentials configured"
+ giveup "No S3 credentials configured"
withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
withS3HandleMaybe c gc u a = do
@@ -430,14 +437,14 @@ withS3HandleMaybe c gc u a = do
where
s3cfg = s3Configuration c
httpcfg = managerSettings
- { managerResponseTimeout = Nothing }
+ { managerResponseTimeout = responseTimeoutNone }
s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery
s3Configuration c = cfg
{ S3.s3Port = port
, S3.s3RequestStyle = case M.lookup "requeststyle" c of
Just "path" -> S3.PathStyle
- Just s -> error $ "bad S3 requeststyle value: " ++ s
+ Just s -> giveup $ "bad S3 requeststyle value: " ++ s
Nothing -> S3.s3RequestStyle cfg
}
where
@@ -455,7 +462,7 @@ s3Configuration c = cfg
port = let s = fromJust $ M.lookup "port" c in
case reads s of
[(p, _)] -> p
- _ -> error $ "bad S3 port value: " ++ s
+ _ -> giveup $ "bad S3 port value: " ++ s
cfg = S3.s3 proto endpoint False
tryS3 :: Annex a -> Annex (Either S3.S3Error a)
@@ -475,7 +482,7 @@ data S3Info = S3Info
extractS3Info :: RemoteConfig -> Annex S3Info
extractS3Info c = do
b <- maybe
- (error "S3 bucket not configured")
+ (giveup "S3 bucket not configured")
(return . T.pack)
(getBucketName c)
let info = S3Info
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 05b120d46..c29cfb438 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -109,7 +109,7 @@ tahoeSetup mu _ c _ = do
where
scsk = "shared-convergence-secret"
furlk = "introducer-furl"
- missingfurl = error "Set TAHOE_FURL to the introducer furl to use."
+ missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
store :: UUID -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store u hdl k _f _p = sendAnnex k noop $ \src ->
@@ -137,7 +137,7 @@ checkKey u hdl k = go =<< getCapability u k
[ Param "--raw"
, Param cap
]
- either error return v
+ either giveup return v
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
@@ -147,7 +147,7 @@ defaultTahoeConfigDir u = do
tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret
tahoeConfigure configdir furl mscs = do
unlessM (createClient configdir furl) $
- error "tahoe create-client failed"
+ giveup "tahoe create-client failed"
maybe noop (writeSharedConvergenceSecret configdir) mscs
startTahoeDaemon configdir
getSharedConvergenceSecret configdir
@@ -173,7 +173,7 @@ getSharedConvergenceSecret configdir = go (60 :: Int)
where
f = convergenceFile configdir
go n
- | n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
+ | n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
| otherwise = do
v <- catchMaybeIO (readFile f)
case v of
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 033057dd8..be2f265e0 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -100,7 +100,7 @@ checkKey key = do
us <- getWebUrls key
if null us
then return False
- else either error return =<< checkKey' key us
+ else either giveup return =<< checkKey' key us
checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 3de8b357e..14947f1e9 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -5,6 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Remote.WebDAV (remote, davCreds, configUrl) where
@@ -34,6 +35,10 @@ import Utility.Url (URLString, matchStatusCodeException)
import Annex.UUID
import Remote.WebDAV.DavLocation
+#if MIN_VERSION_http_client(0,5,0)
+import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)
+#endif
+
remote :: RemoteType
remote = RemoteType {
typename = "webdav",
@@ -85,7 +90,7 @@ webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -
webdavSetup mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
url <- case M.lookup "url" c of
- Nothing -> error "Specify url="
+ Nothing -> giveup "Specify url="
Just url -> return url
(c', encsetup) <- encryptionSetup c gc
creds <- maybe (getCreds c' gc u) (return . Just) mcreds
@@ -122,7 +127,7 @@ retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
-retrieve _ Nothing = error "unable to connect"
+retrieve _ Nothing = giveup "unable to connect"
retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav
retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $
goDAV dav $
@@ -147,7 +152,7 @@ remove (Just dav) k = liftIO $ do
_ -> return False
checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent
-checkKey r _ Nothing _ = error $ name r ++ " not configured"
+checkKey r _ Nothing _ = giveup $ name r ++ " not configured"
checkKey r chunkconfig (Just dav) k = do
showChecking r
case chunkconfig of
@@ -155,7 +160,7 @@ checkKey r chunkconfig (Just dav) k = do
_ -> do
v <- liftIO $ goDAV dav $
existsDAV (keyLocation k)
- either error return v
+ either giveup return v
configUrl :: Remote -> Maybe URLString
configUrl r = fixup <$> M.lookup "url" (config r)
@@ -302,6 +307,17 @@ goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
{- Catch StatusCodeException and trim it to only the statusMessage part,
- eliminating a lot of noise, which can include the whole request that
- failed. The rethrown exception is no longer a StatusCodeException. -}
+#if MIN_VERSION_http_client(0,5,0)
+prettifyExceptions :: DAVT IO a -> DAVT IO a
+prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
+ where
+ go (HttpExceptionRequest _ (StatusCodeException response message)) = error $ unwords
+ [ "DAV failure:"
+ , show (responseStatus response)
+ , show (message)
+ ]
+ go e = throwM e
+#else
prettifyExceptions :: DAVT IO a -> DAVT IO a
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
where
@@ -311,6 +327,7 @@ prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
, show (statusMessage status)
]
go e = throwM e
+#endif
prepDAV :: DavUser -> DavPass -> DAVT IO ()
prepDAV user pass = do
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-01 15:01:38 +0000