Avoid backtraces on expected failures when built with ghc 8; only use backtraces for unexpected errors.

ghc 8 added backtraces on uncaught errors. This is great, but git-annex was
using error in many places for a error message targeted at the user, in
some known problem case. A backtrace only confuses such a message, so omit it.

Notably, commands like git annex drop that failed due to eg, numcopies,
used to use error, so had a backtrace.

This commit was sponsored by Ethan Aubin.
This commit is contained in:
Joey Hess 2016-11-15 21:29:54 -04:00
parent 69915c6c9b
commit 0a4479b8ec
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
116 changed files with 287 additions and 270 deletions

View file

@ -596,7 +596,7 @@ checkAdjustedClone = ifM isBareRepo
aps <- fmap commitParent <$> findAdjustingCommit (AdjBranch currbranch)
case aps of
Just [p] -> setBasisBranch basis p
_ -> error $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch
ifM versionSupportsUnlockedPointers
( return InAdjustedClone
, return NeedUpgradeForAdjustedClone
@ -610,6 +610,6 @@ isGitVersionSupported = not <$> Git.Version.older "2.2.0"
checkVersionSupported :: Annex ()
checkVersionSupported = do
unlessM versionSupportsAdjustedBranch $
error "Adjusted branches are only supported in v6 or newer repositories."
giveup "Adjusted branches are only supported in v6 or newer repositories."
unlessM (liftIO isGitVersionSupported) $
error "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."
giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."

View file

@ -225,7 +225,7 @@ getHistorical date file =
-- This check avoids some ugly error messages when the reflog
-- is empty.
ifM (null <$> inRepo (Git.RefLog.get' [Param (fromRef fullname), Param "-n1"]))
( error ("No reflog for " ++ fromRef fullname)
( giveup ("No reflog for " ++ fromRef fullname)
, getRef (Git.Ref.dateRef fullname date) file
)
@ -574,7 +574,7 @@ checkBranchDifferences ref = do
<$> catFile ref differenceLog
mydiffs <- annexDifferences <$> Annex.getGitConfig
when (theirdiffs /= mydiffs) $
error "Remote repository is tuned in incompatable way; cannot be merged with local repository."
giveup "Remote repository is tuned in incompatable way; cannot be merged with local repository."
ignoreRefs :: [Git.Sha] -> Annex ()
ignoreRefs rs = do

View file

@ -268,8 +268,8 @@ lockContentUsing locker key a = do
(unlock lockfile)
(const a)
where
alreadylocked = error "content is locked"
failedtolock e = error $ "failed to lock content: " ++ show e
alreadylocked = giveup "content is locked"
failedtolock e = giveup $ "failed to lock content: " ++ show e
lock contentfile lockfile =
(maybe alreadylocked return

View file

@ -165,7 +165,7 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
mkmatcher expr = do
parser <- mkLargeFilesParser
either badexpr return $ parsedToMatcher $ parser expr
badexpr e = error $ "bad annex.largefiles configuration: " ++ e
badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e
simply :: MatchFiles Annex -> ParseResult
simply = Right . Operation

View file

@ -129,7 +129,7 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade
where
needsinit = ifM Annex.Branch.hasSibling
( initialize Nothing Nothing
, error "First run: git-annex init"
, giveup "First run: git-annex init"
)
{- Checks if a repository is initialized. Does not check version for ugrade. -}

View file

@ -110,7 +110,7 @@ refineView origview = checksize . calc Unchanged origview
in (view', Narrowing)
checksize r@(v, _)
| viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
| viewTooLarge v = giveup $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
| otherwise = r
updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
@ -424,4 +424,4 @@ genViewBranch view = withViewIndex $ do
return branch
withCurrentView :: (View -> Annex a) -> Annex a
withCurrentView a = maybe (error "Not in a view.") a =<< currentView
withCurrentView a = maybe (giveup "Not in a view.") a =<< currentView

View file

@ -65,10 +65,10 @@ checkCanWatch
#else
noop
#endif
| otherwise = error "watch mode is not available on this system"
| otherwise = giveup "watch mode is not available on this system"
needLsof :: Annex ()
needLsof = error $ unlines
needLsof = giveup $ unlines
[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
, "To override lsof checks to ensure that files are not open for writing"
, "when added to the annex, you can use --force"

View file

@ -71,7 +71,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
#ifdef __ANDROID__
when (isJust listenhost') $
-- See Utility.WebApp
error "Sorry, --listen is not currently supported on Android"
giveup "Sorry, --listen is not currently supported on Android"
#endif
webapp <- WebApp
<$> pure assistantdata

View file

@ -153,7 +153,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
where
changeprogram program = liftIO $ do
unlessM (boolSystem program [Param "version"]) $
error "New git-annex program failed to run! Not using."
giveup "New git-annex program failed to run! Not using."
pf <- programFile
liftIO $ writeFile pf program

View file

@ -139,7 +139,7 @@ postAddS3R = awsConfigurator $ do
]
_ -> $(widgetFile "configurators/adds3")
#else
postAddS3R = error "S3 not supported by this build"
postAddS3R = giveup "S3 not supported by this build"
#endif
getAddGlacierR :: Handler Html
@ -161,7 +161,7 @@ postAddGlacierR = glacierConfigurator $ do
]
_ -> $(widgetFile "configurators/addglacier")
#else
postAddGlacierR = error "S3 not supported by this build"
postAddGlacierR = giveup "S3 not supported by this build"
#endif
getEnableS3R :: UUID -> Handler Html
@ -179,7 +179,7 @@ postEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
#else
postEnableS3R _ = error "S3 not supported by this build"
postEnableS3R _ = giveup "S3 not supported by this build"
#endif
getEnableGlacierR :: UUID -> Handler Html
@ -205,7 +205,7 @@ enableAWSRemote remotetype uuid = do
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enableaws")
#else
enableAWSRemote _ _ = error "S3 not supported by this build"
enableAWSRemote _ _ = giveup "S3 not supported by this build"
#endif
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()

View file

@ -147,7 +147,7 @@ postAddIAR = iaConfigurator $ do
]
_ -> $(widgetFile "configurators/addia")
#else
postAddIAR = error "S3 not supported by this build"
postAddIAR = giveup "S3 not supported by this build"
#endif
getEnableIAR :: UUID -> Handler Html
@ -157,7 +157,7 @@ postEnableIAR :: UUID -> Handler Html
#ifdef WITH_S3
postEnableIAR = iaConfigurator . enableIARemote
#else
postEnableIAR _ = error "S3 not supported by this build"
postEnableIAR _ = giveup "S3 not supported by this build"
#endif
#ifdef WITH_S3

View file

@ -151,7 +151,7 @@ getFirstRepositoryR = postFirstRepositoryR
postFirstRepositoryR :: Handler Html
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
unlessM (liftIO $ inPath "git") $
error "You need to install git in order to use git-annex!"
giveup "You need to install git in order to use git-annex!"
#ifdef __ANDROID__
androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
let path = "/sdcard/annex"
@ -309,7 +309,7 @@ getFinishAddDriveR drive = go
mu <- liftAnnex $ probeGCryptRemoteUUID dir
case mu of
Just u -> enableexistinggcryptremote u
Nothing -> error "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
Nothing -> giveup "The drive contains a gcrypt repository that is not a git-annex special remote. This is not supported."
enableexistinggcryptremote u = do
remotename' <- liftAnnex $ getGCryptRemoteName u dir
makewith $ const $ do

View file

@ -196,7 +196,7 @@ postEnableSshGCryptR u = whenGcryptInstalled $
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
sshConfigurator $
checkExistingGCrypt sshdata' $
error "Expected to find an encrypted git repository, but did not."
giveup "Expected to find an encrypted git repository, but did not."
getsshinput = parseSshUrl <=< M.lookup "gitrepo"
getEnableSshGitRemoteR :: UUID -> Handler Html
@ -475,7 +475,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
case mu of
Just u -> void $ liftH $
combineExistingGCrypt sshdata u
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
Nothing -> giveup "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
where
repourl = genSshUrl sshdata
@ -641,7 +641,7 @@ enableRsyncNetGCrypt sshinput reponame =
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
enableGCrypt sshdata reponame
where
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
notencrypted = giveup "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
notinstalled = error "internal"
{- Prepares rsync.net ssh key and creates the directory that will be

View file

@ -82,7 +82,7 @@ postAddBoxComR = boxConfigurator $ do
]
_ -> $(widgetFile "configurators/addbox.com")
#else
postAddBoxComR = error "WebDAV not supported by this build"
postAddBoxComR = giveup "WebDAV not supported by this build"
#endif
getEnableWebDAVR :: UUID -> Handler Html
@ -120,7 +120,7 @@ postEnableWebDAVR uuid = do
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enablewebdav")
#else
postEnableWebDAVR _ = error "WebDAV not supported by this build"
postEnableWebDAVR _ = giveup "WebDAV not supported by this build"
#endif
#ifdef WITH_WEBDAV

View file

@ -56,7 +56,7 @@ withNewSecretKey use = do
liftIO $ genSecretKey cmd RSA "" userid maxRecommendedKeySize
results <- M.keys . M.filter (== userid) <$> liftIO (secretKeys cmd)
case results of
[] -> error "Failed to generate gpg key!"
[] -> giveup "Failed to generate gpg key!"
(key:_) -> use key
{- Tries to find the name used in remote.log for a gcrypt repository
@ -85,7 +85,7 @@ getGCryptRemoteName u repoloc = do
void $ inRepo $ Git.Remote.Remove.remove tmpremote
maybe missing return mname
where
missing = error $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
missing = giveup $ "Cannot find configuration for the gcrypt remote at " ++ repoloc
{- Checks to see if a repo is encrypted with gcrypt, and runs one action if
- it's not an another if it is.
@ -103,7 +103,7 @@ checkGCryptRepoEncryption location notencrypted notinstalled encrypted =
dispatch Git.GCrypt.Decryptable = encrypted
dispatch Git.GCrypt.NotEncrypted = notencrypted
dispatch Git.GCrypt.NotDecryptable =
error "This git repository is encrypted with a GnuPG key that you do not have."
giveup "This git repository is encrypted with a GnuPG key that you do not have."
{- Gets the UUID of the gcrypt repo at a location, which may not exist.
- Only works if the gcrypt repo was created as a git-annex remote. -}

View file

@ -9,6 +9,8 @@ git-annex (6.20161112) UNRELEASED; urgency=medium
* sync: Pass --allow-unrelated-histories to git merge when used with git
git 2.9.0 or newer. This makes merging a remote into a freshly created
direct mode repository work the same as it works in indirect mode.
* Avoid backtraces on expected failures when built with ghc 8;
only use backtraces for unexpected errors.
-- Joey Hess <id@joeyh.name> Tue, 15 Nov 2016 11:15:27 -0400

View file

@ -38,7 +38,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
showerrcount =<< Annex.getState Annex.errcounter
where
showerrcount 0 = noop
showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed"
showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed"
{- Runs one of the actions needed to perform a command.
- Individual actions can fail without stopping the whole command,

View file

@ -56,7 +56,7 @@ batchInput parser a = do
either parseerr a (parser v)
batchInput parser a
where
parseerr s = error $ "Batch input parse failure: " ++ s
parseerr s = giveup $ "Batch input parse failure: " ++ s
-- Runs a CommandStart in batch mode.
--

View file

@ -71,7 +71,7 @@ globalOptions =
check Nothing = unexpected expected "uninitialized repository"
check (Just u) = unexpectedUUID expected u
unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
unexpected expected s = error $
unexpected expected s = giveup $
"expected repository UUID " ++ expected ++ " but found " ++ s
run :: [String] -> IO ()
@ -109,7 +109,7 @@ builtin cmd dir params = do
Git.Config.read r
`catchIO` \_ -> do
hn <- fromMaybe "unknown" <$> getHostname
error $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
external :: [String] -> IO ()
external params = do
@ -120,7 +120,7 @@ external params = do
checkDirectory lastparam
checkNotLimited
unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
error "git-shell failed"
giveup "git-shell failed"
{- Split the input list into 3 groups separated with a double dash --.
- Parameters between two -- markers are field settings, in the form:
@ -150,6 +150,6 @@ checkField (field, val)
| otherwise = False
failure :: IO ()
failure = error $ "bad parameters\n\n" ++ usage h cmds
failure = giveup $ "bad parameters\n\n" ++ usage h cmds
where
h = "git-annex-shell [-c] command [parameters ...] [option ...]"

View file

@ -26,7 +26,7 @@ checkEnv var = do
case v of
Nothing -> noop
Just "" -> noop
Just _ -> error $ "Action blocked by " ++ var
Just _ -> giveup $ "Action blocked by " ++ var
checkDirectory :: Maybe FilePath -> IO ()
checkDirectory mdir = do
@ -44,7 +44,7 @@ checkDirectory mdir = do
then noop
else req d' (Just dir')
where
req d mdir' = error $ unwords
req d mdir' = giveup $ unwords
[ "Only allowed to access"
, d
, maybe "and could not determine directory from command line" ("not " ++) mdir'
@ -64,4 +64,4 @@ gitAnnexShellCheck :: Command -> Command
gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
where
okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
error "Not a git-annex or gcrypt repository."
giveup "Not a git-annex or gcrypt repository."

View file

@ -40,7 +40,7 @@ withFilesInGitNonRecursive :: String -> (FilePath -> CommandStart) -> CmdParams
withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
( withFilesInGit a params
, if null params
then error needforce
then giveup needforce
else seekActions $ prepFiltered a (getfiles [] params)
)
where
@ -54,7 +54,7 @@ withFilesInGitNonRecursive needforce a params = ifM (Annex.getState Annex.force)
[] -> do
void $ liftIO $ cleanup
getfiles c ps
_ -> error needforce
_ -> giveup needforce
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesNotInGit skipdotfiles a params
@ -117,7 +117,7 @@ withPairs a params = seekActions $ return $ map a $ pairs [] params
where
pairs c [] = reverse c
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = error "expected pairs"
pairs _ _ = giveup "expected pairs"
withFilesToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
@ -152,11 +152,11 @@ withFilesMaybeModified a params = seekActions $
withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek
withKeys a params = seekActions $ return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ file2key p
parse p = fromMaybe (giveup "bad key") $ file2key p
withNothing :: CommandStart -> CmdParams -> CommandSeek
withNothing a [] = seekActions $ return [a]
withNothing _ _ = error "This command takes no parameters."
withNothing _ _ = giveup "This command takes no parameters."
{- Handles the --all, --branch, --unused, --failed, --key, and
- --incomplete options, which specify particular keys to run an
@ -191,7 +191,7 @@ withKeyOptions'
withKeyOptions' ko auto mkkeyaction fallbackaction params = do
bare <- fromRepo Git.repoIsLocalBare
when (auto && bare) $
error "Cannot use --auto in a bare repository"
giveup "Cannot use --auto in a bare repository"
case (null params, ko) of
(True, Nothing)
| bare -> noauto $ runkeyaction loggedKeys
@ -203,10 +203,10 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
(True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k])
(True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys
(True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs
(False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
(False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"
where
noauto a
| auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
| auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"
| otherwise = a
incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True
runkeyaction getks = do

View file

@ -101,15 +101,15 @@ repoExists = CommandCheck 0 ensureInitialized
notDirect :: Command -> Command
notDirect = addCheck $ whenM isDirect $
error "You cannot run this command in a direct mode repository."
giveup "You cannot run this command in a direct mode repository."
notBareRepo :: Command -> Command
notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
error "You cannot run this command in a bare repository."
giveup "You cannot run this command in a bare repository."
noDaemonRunning :: Command -> Command
noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
error "You cannot run this command while git-annex watch or git-annex assistant is running."
giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
where
daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile

View file

@ -38,4 +38,4 @@ perform key = next $ do
- it seems better to error out, rather than moving bad/tmp content into
- the annex. -}
performOther :: String -> Key -> CommandPerform
performOther other _ = error $ "cannot addunused " ++ other ++ "content"
performOther other _ = giveup $ "cannot addunused " ++ other ++ "content"

View file

@ -133,7 +133,7 @@ checkUrl r o u = do
let f' = adjustFile o (deffile </> fromSafeFilePath f)
void $ commandAction $
startRemote r (relaxedOption o) f' u' sz
| otherwise = error $ unwords
| otherwise = giveup $ unwords
[ "That url contains multiple files according to the"
, Remote.name r
, " remote; cannot add it to a single file."
@ -182,7 +182,7 @@ startWeb :: AddUrlOptions -> String -> CommandStart
startWeb o s = go $ fromMaybe bad $ parseURI urlstring
where
(urlstring, downloader) = getDownloader s
bad = fromMaybe (error $ "bad url " ++ urlstring) $
bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
Url.parseURIRelaxed $ urlstring
go url = case downloader of
QuviDownloader -> usequvi
@ -208,7 +208,7 @@ startWeb o s = go $ fromMaybe bad $ parseURI urlstring
)
showStart "addurl" file
next $ performWeb (relaxedOption o) urlstring file urlinfo
badquvi = error $ "quvi does not know how to download url " ++ urlstring
badquvi = giveup $ "quvi does not know how to download url " ++ urlstring
usequvi = do
page <- fromMaybe badquvi
<$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] urlstring
@ -372,7 +372,7 @@ url2file url pathdepth pathmax = case pathdepth of
| depth >= length urlbits -> frombits id
| depth > 0 -> frombits $ drop depth
| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
| otherwise -> error "bad --pathdepth"
| otherwise -> giveup "bad --pathdepth"
where
fullurl = concat
[ maybe "" uriRegName (uriAuthority url)
@ -385,7 +385,7 @@ url2file url pathdepth pathmax = case pathdepth of
urlString2file :: URLString -> Maybe Int -> Int -> FilePath
urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of
Nothing -> error $ "bad uri " ++ s
Nothing -> giveup $ "bad uri " ++ s
Just u -> url2file u pathdepth pathmax
adjustFile :: AddUrlOptions -> FilePath -> FilePath

View file

@ -66,14 +66,14 @@ startNoRepo :: AssistantOptions -> IO ()
startNoRepo o
| autoStartOption o = autoStart o
| autoStopOption o = autoStop
| otherwise = error "Not in a git repository."
| otherwise = giveup "Not in a git repository."
autoStart :: AssistantOptions -> IO ()
autoStart o = do
dirs <- liftIO readAutoStartFile
when (null dirs) $ do
f <- autoStartFile
error $ "Nothing listed in " ++ f
giveup $ "Nothing listed in " ++ f
program <- programPath
haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
forM_ dirs $ \d -> do

View file

@ -40,7 +40,7 @@ seek o = case batchOption o of
_ -> wrongnumparams
batchInput Right $ checker >=> batchResult
where
wrongnumparams = error "Wrong number of parameters"
wrongnumparams = giveup "Wrong number of parameters"
data Result = Present | NotPresent | CheckFailure String
@ -71,8 +71,8 @@ batchResult Present = liftIO $ putStrLn "1"
batchResult _ = liftIO $ putStrLn "0"
toKey :: String -> Key
toKey = fromMaybe (error "Bad key") . file2key
toKey = fromMaybe (giveup "Bad key") . file2key
toRemote :: String -> Annex Remote
toRemote rn = maybe (error "Unknown remote") return
toRemote rn = maybe (giveup "Unknown remote") return
=<< Remote.byNameWithUUID (Just rn)

View file

@ -19,7 +19,7 @@ cmd = noCommit $ noMessages $
run :: () -> String -> Annex Bool
run _ p = do
let k = fromMaybe (error "bad key") $ file2key p
let k = fromMaybe (giveup "bad key") $ file2key p
maybe (return False) (\f -> liftIO (putStrLn f) >> return True)
=<< inAnnex' (pure True) Nothing check k
where

View file

@ -37,7 +37,7 @@ startKey key = do
ls <- keyLocations key
case ls of
[] -> next $ performKey key
_ -> error "This key is still known to be present in some locations; not marking as dead."
_ -> giveup "This key is still known to be present in some locations; not marking as dead."
performKey :: Key -> CommandPerform
performKey key = do

View file

@ -25,7 +25,7 @@ start (name:description) = do
showStart "describe" name
u <- Remote.nameToUUID name
next $ perform u $ unwords description
start _ = error "Specify a repository and a description."
start _ = giveup "Specify a repository and a description."
perform :: UUID -> String -> CommandPerform
perform u description = do

View file

@ -73,7 +73,7 @@ parseReq opts = case separate (== "--") opts of
mk (unmergedpath:[]) = UnmergedReq { rPath = unmergedpath }
mk _ = badopts
badopts = error $ "Unexpected input: " ++ unwords opts
badopts = giveup $ "Unexpected input: " ++ unwords opts
{- Check if either file is a symlink to a git-annex object,
- which git-diff will leave as a normal file containing the link text.

View file

@ -26,7 +26,7 @@ seek = withNothing start
start :: CommandStart
start = ifM versionSupportsDirectMode
( ifM isDirect ( stop , next perform )
, error "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
, giveup "Direct mode is not suppported by this repository version. Use git-annex unlock instead."
)
perform :: CommandPerform

View file

@ -32,7 +32,7 @@ optParser desc = DropKeyOptions
seek :: DropKeyOptions -> CommandSeek
seek o = do
unlessM (Annex.getState Annex.force) $
error "dropkey can cause data loss; use --force if you're sure you want to do this"
giveup "dropkey can cause data loss; use --force if you're sure you want to do this"
withKeys start (toDrop o)
case batchOption o of
Batch -> batchInput parsekey $ batchCommandAction . start

View file

@ -63,7 +63,7 @@ startSpecialRemote name config Nothing = do
_ -> unknownNameError "Unknown remote name."
startSpecialRemote name config (Just (u, c)) = do
let fullconfig = config `M.union` c
t <- either error return (Annex.SpecialRemote.findType fullconfig)
t <- either giveup return (Annex.SpecialRemote.findType fullconfig)
showStart "enableremote" name
gc <- maybe def Remote.gitconfig <$> Remote.byUUID u
next $ performSpecialRemote t u fullconfig gc
@ -94,7 +94,7 @@ unknownNameError prefix = do
disabledremotes <- filterM isdisabled =<< Annex.fromRepo Git.remotes
let remotesmsg = unlines $ map ("\t" ++) $
mapMaybe Git.remoteName disabledremotes
error $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
giveup $ concat $ filter (not . null) [prefix ++ "\n", remotesmsg, specialmsg]
where
isdisabled r = anyM id
[ (==) NoUUID <$> getRepoUUID r

View file

@ -21,6 +21,6 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
run :: Maybe Utility.Format.Format -> String -> Annex Bool
run format p = do
let k = fromMaybe (error "bad key") $ file2key p
let k = fromMaybe (giveup "bad key") $ file2key p
showFormatted format (key2file k) (keyVars k)
return True

View file

@ -92,7 +92,7 @@ start (Expire expire) noact actlog descs u =
data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime))
parseExpire :: [String] -> Annex Expire
parseExpire [] = error "Specify an expire time."
parseExpire [] = giveup "Specify an expire time."
parseExpire ps = do
now <- liftIO getPOSIXTime
Expire . M.fromList <$> mapM (parse now) ps
@ -104,7 +104,7 @@ parseExpire ps = do
return (Just r, parsetime now t)
parsetime _ "never" = Nothing
parsetime now s = case parseDuration s of
Nothing -> error $ "bad expire time: " ++ s
Nothing -> giveup $ "bad expire time: " ++ s
Just d -> Just (now - durationToPOSIXTime d)
parseActivity :: Monad m => String -> m Activity

View file

@ -33,14 +33,14 @@ start force (keyname:file:[]) = do
let key = mkKey keyname
unless force $ do
inbackend <- inAnnex key
unless inbackend $ error $
unless inbackend $ giveup $
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
showStart "fromkey" file
next $ perform key file
start _ [] = do
showStart "fromkey" "stdin"
next massAdd
start _ _ = error "specify a key and a dest file"
start _ _ = giveup "specify a key and a dest file"
massAdd :: CommandPerform
massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
@ -51,7 +51,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
ok <- perform' key f
let !status' = status && ok
go status' rest
go _ _ = error "Expected pairs of key and file on stdin, but got something else."
go _ _ = giveup "Expected pairs of key and file on stdin, but got something else."
-- From user input to a Key.
-- User can input either a serialized key, or an url.
@ -66,7 +66,7 @@ mkKey s = case parseURI s of
Backend.URL.fromUrl s Nothing
_ -> case file2key s of
Just k -> k
Nothing -> error $ "bad key/url " ++ s
Nothing -> giveup $ "bad key/url " ++ s
perform :: Key -> FilePath -> CommandPerform
perform key file = do

View file

@ -584,7 +584,7 @@ prepIncremental u (Just StartIncrementalO) = do
recordStartTime u
ifM (FsckDb.newPass u)
( StartIncremental <$> openFsckDb u
, error "Cannot start a new --incremental fsck pass; another fsck process is already running."
, giveup "Cannot start a new --incremental fsck pass; another fsck process is already running."
)
prepIncremental u (Just MoreIncrementalO) =
ContIncremental <$> openFsckDb u

View file

@ -39,7 +39,7 @@ start = do
guardTest :: Annex ()
guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
error $ unlines
giveup $ unlines
[ "Running fuzz tests *writes* to and *deletes* files in"
, "this repository, and pushes those changes to other"
, "repositories! This is a developer tool, not something"

View file

@ -25,7 +25,7 @@ start :: String -> CommandStart
start gcryptid = next $ next $ do
u <- getUUID
when (u /= NoUUID) $
error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
g <- gitRepo
gu <- Remote.GCrypt.getGCryptUUID True g
@ -35,5 +35,5 @@ start gcryptid = next $ next $ do
then do
void $ Remote.GCrypt.setupRepo gcryptid g
return True
else error "cannot use gcrypt in a non-bare repository"
else error "gcryptsetup uuid mismatch"
else giveup "cannot use gcrypt in a non-bare repository"
else giveup "gcryptsetup uuid mismatch"

View file

@ -30,7 +30,7 @@ start (name:[]) = do
u <- Remote.nameToUUID name
showRaw . unwords . S.toList =<< lookupGroups u
stop
start _ = error "Specify a repository and a group."
start _ = giveup "Specify a repository and a group."
setGroup :: UUID -> Group -> CommandPerform
setGroup uuid g = do

View file

@ -25,4 +25,4 @@ start (g:[]) = next $ performGet groupPreferredContentMapRaw g
start (g:expr:[]) = do
showStart "groupwanted" g
next $ performSet groupPreferredContentSet expr g
start _ = error "Specify a group."
start _ = giveup "Specify a group."

View file

@ -62,7 +62,7 @@ seek o = allowConcurrentOutput $ do
repopath <- liftIO . absPath =<< fromRepo Git.repoPath
inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o)
unless (null inrepops) $ do
error $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops
largematcher <- largeFilesMatcher
withPathContents (start largematcher (duplicateMode o)) (importFiles o)

View file

@ -147,7 +147,7 @@ findDownloads u = go =<< downloadFeed u
{- Feeds change, so a feed download cannot be resumed. -}
downloadFeed :: URLString -> Annex (Maybe Feed)
downloadFeed url
| Url.parseURIRelaxed url == Nothing = error "invalid feed url"
| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
| otherwise = do
showOutput
uo <- Url.getUrlOptions
@ -336,7 +336,7 @@ noneValue = "none"
- Throws an error if the feed is broken, otherwise shows a warning. -}
feedProblem :: URLString -> String -> Annex ()
feedProblem url message = ifM (checkFeedBroken url)
( error $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
( giveup $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
, warning $ "warning: " ++ message
)

View file

@ -33,9 +33,9 @@ start :: CommandStart
start = ifM isDirect
( do
unlessM (coreSymlinks <$> Annex.getGitConfig) $
error "Git is configured to not use symlinks, so you must use direct mode."
giveup "Git is configured to not use symlinks, so you must use direct mode."
whenM probeCrippledFileSystem $
error "This repository seems to be on a crippled filesystem, you must use direct mode."
giveup "This repository seems to be on a crippled filesystem, you must use direct mode."
next perform
, stop
)

View file

@ -26,16 +26,16 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Specify a name for the remote."
start [] = giveup "Specify a name for the remote."
start (name:ws) = ifM (isJust <$> findExisting name)
( error $ "There is already a special remote named \"" ++ name ++
( giveup $ "There is already a special remote named \"" ++ name ++
"\". (Use enableremote to enable an existing special remote.)"
, do
ifM (isJust <$> Remote.byNameOnly name)
( error $ "There is already a remote named \"" ++ name ++ "\""
( giveup $ "There is already a remote named \"" ++ name ++ "\""
, do
let c = newConfig name
t <- either error return (findType config)
t <- either giveup return (findType config)
showStart "initremote" name
next $ perform t name $ M.union config c

View file

@ -79,7 +79,7 @@ performNew file key = do
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContent obj $ replaceFile obj $ \tmp -> do
unlessM (checkedCopyFile key obj tmp Nothing) $
error "unable to lock file"
giveup "unable to lock file"
Database.Keys.storeInodeCaches key [obj]
-- Try to repopulate obj from an unmodified associated file.
@ -115,4 +115,4 @@ performOld file = do
next $ return True
errorModified :: a
errorModified = error "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"
errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

View file

@ -32,7 +32,7 @@ start [ks] = do
then exitSuccess
else exitFailure
where
k = fromMaybe (error "bad key") (file2key ks)
k = fromMaybe (giveup "bad key") (file2key ks)
locksuccess = ifM (inAnnex k)
( liftIO $ do
putStrLn contentLockedMarker
@ -41,4 +41,4 @@ start [ks] = do
return True
, return False
)
start _ = error "Specify exactly 1 key."
start _ = giveup "Specify exactly 1 key."

View file

@ -93,7 +93,7 @@ seek o = do
case (logFiles o, allOption o) of
(fs, False) -> withFilesInGit (whenAnnexed $ start o outputter) fs
([], True) -> commandAction (startAll o outputter)
(_, True) -> error "Cannot specify both files and --all"
(_, True) -> giveup "Cannot specify both files and --all"
start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart
start o outputter file key = do

View file

@ -81,7 +81,7 @@ seek o = do
Batch -> withMessageState $ \s -> case outputType s of
JSONOutput _ -> batchInput parseJSONInput $
commandAction . startBatch now
_ -> error "--batch is currently only supported in --json mode"
_ -> giveup "--batch is currently only supported in --json mode"
start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart
start now o file k = startKeys now o k (mkActionItem afile)
@ -156,7 +156,7 @@ startBatch now (i, (MetaData m)) = case i of
mk <- lookupFile f
case mk of
Just k -> go k (mkActionItem (Just f))
Nothing -> error $ "not an annexed file: " ++ f
Nothing -> giveup $ "not an annexed file: " ++ f
Right k -> go k (mkActionItem k)
where
go k ai = do

View file

@ -197,4 +197,4 @@ fromPerform src move key afile = ifM (inAnnex key)
]
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok
faileddropremote = error "Unable to drop from remote."
faileddropremote = giveup "Unable to drop from remote."

View file

@ -23,15 +23,15 @@ seek = withWords start
start :: [String] -> CommandStart
start [] = startGet
start [s] = case readish s of
Nothing -> error $ "Bad number: " ++ s
Nothing -> giveup $ "Bad number: " ++ s
Just n
| n > 0 -> startSet n
| n == 0 -> ifM (Annex.getState Annex.force)
( startSet n
, error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
, giveup "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force."
)
| otherwise -> error "Number cannot be negative!"
start _ = error "Specify a single number."
| otherwise -> giveup "Number cannot be negative!"
start _ = giveup "Specify a single number."
startGet :: CommandStart
startGet = next $ next $ do

View file

@ -46,7 +46,7 @@ seek ps = lockPreCommitHook $ ifM isDirect
( do
(fs, cleanup) <- inRepo $ Git.typeChangedStaged ps
whenM (anyM isOldUnlocked fs) $
error "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
giveup "Cannot make a partial commit with unlocked annexed files. You should `git annex add` the files you want to commit, and then run git commit."
void $ liftIO cleanup
, do
-- fix symlinks to files being committed

View file

@ -30,7 +30,7 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Did not specify command to run."
start [] = giveup "Did not specify command to run."
start (c:ps) = liftIO . exitWith =<< ifM isDirect
( do
tmp <- gitAnnexTmpMiscDir <$> gitRepo

View file

@ -33,7 +33,7 @@ seek = withPairs start
start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
where
newkey = fromMaybe (error "bad key") $ file2key keyname
newkey = fromMaybe (giveup "bad key") $ file2key keyname
go oldkey
| oldkey == newkey = stop
| otherwise = do
@ -46,7 +46,7 @@ perform file oldkey newkey = do
( unlessM (linkKey file oldkey newkey) $
error "failed"
, unlessM (Annex.getState Annex.force) $
error $ file ++ " is not available (use --force to override)"
giveup $ file ++ " is not available (use --force to override)"
)
next $ cleanup file oldkey newkey

View file

@ -27,5 +27,5 @@ start (ks:us:[]) = do
then liftIO exitSuccess
else liftIO exitFailure
where
k = fromMaybe (error "bad key") (file2key ks)
start _ = error "Wrong number of parameters"
k = fromMaybe (giveup "bad key") (file2key ks)
start _ = giveup "Wrong number of parameters"

View file

@ -32,7 +32,7 @@ start (keyname:url:[]) = do
start [] = do
showStart "registerurl" "stdin"
next massAdd
start _ = error "specify a key and an url"
start _ = giveup "specify a key and an url"
massAdd :: CommandPerform
massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
@ -43,7 +43,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
ok <- perform' key u
let !status' = status && ok
go status' rest
go _ _ = error "Expected pairs of key and url on stdin, but got something else."
go _ _ = giveup "Expected pairs of key and url on stdin, but got something else."
perform :: Key -> URLString -> CommandPerform
perform key url = do

View file

@ -47,7 +47,7 @@ startSrcDest (src:dest:[])
next $ ifAnnexed dest
(\key -> perform src key (verifyKeyContent DefaultVerify UnVerified key src))
stop
startSrcDest _ = error "specify a src file and a dest file"
startSrcDest _ = giveup "specify a src file and a dest file"
startKnown :: FilePath -> CommandStart
startKnown src = notAnnexed src $ do
@ -63,7 +63,8 @@ startKnown src = notAnnexed src $ do
)
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src = ifAnnexed src (error $ "cannot used annexed file as src: " ++ src)
notAnnexed src = ifAnnexed src $
giveup $ "cannot used annexed file as src: " ++ src
perform :: FilePath -> Key -> Annex Bool -> CommandPerform
perform src key verify = ifM move

View file

@ -33,8 +33,8 @@ start = do
( do
void $ commitResolvedMerge Git.Branch.ManualCommit
next $ next $ return True
, error "Merge conflict could not be automatically resolved."
, giveup "Merge conflict could not be automatically resolved."
)
where
nobranch = error "No branch is currently checked out."
nomergehead = error "No SHA found in .git/merge_head"
nobranch = giveup "No branch is currently checked out."
nomergehead = giveup "No SHA found in .git/merge_head"

View file

@ -31,7 +31,7 @@ start = parse
parse (name:expr:[]) = go name $ \uuid -> do
showStart "schedile" name
performSet expr uuid
parse _ = error "Specify a repository."
parse _ = giveup "Specify a repository."
go name a = do
u <- Remote.nameToUUID name
@ -47,7 +47,7 @@ performGet uuid = do
performSet :: String -> UUID -> CommandPerform
performSet expr uuid = case parseScheduledActivities expr of
Left e -> error $ "Parse error: " ++ e
Left e -> giveup $ "Parse error: " ++ e
Right l -> do
scheduleSet uuid l
next $ return True

View file

@ -23,10 +23,10 @@ start :: [String] -> CommandStart
start (keyname:file:[]) = do
showStart "setkey" file
next $ perform file (mkKey keyname)
start _ = error "specify a key and a content file"
start _ = giveup "specify a key and a content file"
mkKey :: String -> Key
mkKey = fromMaybe (error "bad key") . file2key
mkKey = fromMaybe (giveup "bad key") . file2key
perform :: FilePath -> Key -> CommandPerform
perform file key = do

View file

@ -26,9 +26,9 @@ start (ks:us:vs:[]) = do
showStart' "setpresentkey" k (mkActionItem k)
next $ perform k (toUUID us) s
where
k = fromMaybe (error "bad key") (file2key ks)
s = fromMaybe (error "bad value") (parseStatus vs)
start _ = error "Wrong number of parameters"
k = fromMaybe (giveup "bad key") (file2key ks)
s = fromMaybe (giveup "bad value") (parseStatus vs)
start _ = giveup "Wrong number of parameters"
perform :: Key -> UUID -> LogStatus -> CommandPerform
perform k u s = next $ do

View file

@ -292,7 +292,7 @@ updateSyncBranch (Just branch, madj) = do
updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO ()
updateBranch syncbranch updateto g =
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
unlessM go $ giveup $ "failed to update " ++ Git.fromRef syncbranch
where
go = Git.Command.runBool
[ Param "branch"

View file

@ -57,7 +57,7 @@ seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o)
start :: Int -> RemoteName -> CommandStart
start basesz name = do
showStart "testremote" name
r <- either error id <$> Remote.byName' name
r <- either giveup id <$> Remote.byName' name
showAction "generating test keys"
fast <- Annex.getState Annex.fast
ks <- mapM randKey (keySizes basesz fast)

View file

@ -59,7 +59,7 @@ start (k:[]) = do
, exitSuccess
]
stop
start _ = error "wrong number of parameters"
start _ = giveup "wrong number of parameters"
readUpdate :: IO (Maybe Integer)
readUpdate = readish <$> getLine

View file

@ -45,7 +45,7 @@ wrapUnannex a = ifM (versionSupportsUnlockedPointers <||> isDirect)
-}
, ifM cleanindex
( lockPreCommitHook $ commit `after` a
, error "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
, giveup "Cannot proceed with uncommitted changes staged in the index. Recommend you: git commit"
)
)
where

View file

@ -32,7 +32,7 @@ seek ps = do
-- in the index.
(fs, cleanup) <- inRepo $ LsFiles.notInRepo False ps
unless (null fs) $
error $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs
giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs
void $ liftIO $ cleanup
-- Committing staged changes before undo allows later

View file

@ -26,7 +26,7 @@ start (name:g:[]) = do
showStart "ungroup" name
u <- Remote.nameToUUID name
next $ perform u g
start _ = error "Specify a repository and a group."
start _ = giveup "Specify a repository and a group."
perform :: UUID -> Group -> CommandPerform
perform uuid g = do

View file

@ -30,12 +30,12 @@ cmd = addCheck check $
check :: Annex ()
check = do
b <- current_branch
when (b == Annex.Branch.name) $ error $
when (b == Annex.Branch.name) $ giveup $
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
top <- fromRepo Git.repoPath
currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
error "can only run uninit from the top of the git repository"
giveup "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
@ -51,7 +51,7 @@ seek ps = do
{- git annex symlinks that are not checked into git could be left by an
- interrupted add. -}
startCheckIncomplete :: FilePath -> Key -> CommandStart
startCheckIncomplete file _ = error $ unlines
startCheckIncomplete file _ = giveup $ unlines
[ file ++ " points to annexed content, but is not checked into git."
, "Perhaps this was left behind by an interrupted git annex add?"
, "Not continuing with uninit; either delete or git annex add the file and retry."
@ -65,7 +65,7 @@ finish = do
prepareRemoveAnnexDir annexdir
if null leftovers
then liftIO $ removeDirectoryRecursive annexdir
else error $ unlines
else giveup $ unlines
[ "Not fully uninitialized"
, "Some annexed data is still left in " ++ annexobjectdir
, "This may include deleted files, or old versions of modified files."

View file

@ -320,7 +320,7 @@ unusedSpec m spec
range (a, b) = case (readish a, readish b) of
(Just x, Just y) -> [x..y]
_ -> badspec
badspec = error $ "Expected number or range, not \"" ++ spec ++ "\""
badspec = giveup $ "Expected number or range, not \"" ++ spec ++ "\""
{- Seek action for unused content. Finds the number in the maps, and
- calls one of 3 actions, depending on the type of unused file. -}
@ -335,7 +335,7 @@ startUnused message unused badunused tmpunused maps n = search
, (unusedTmpMap maps, tmpunused)
]
where
search [] = error $ show n ++ " not valid (run git annex unused for list)"
search [] = giveup $ show n ++ " not valid (run git annex unused for list)"
search ((m, a):rest) =
case M.lookup n m of
Nothing -> search rest

View file

@ -33,6 +33,6 @@ start params = do
next $ next $ return True
Narrowing -> next $ next $ do
if visibleViewSize view' == visibleViewSize view
then error "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd."
else checkoutViewBranch view' narrowView
Widening -> error "Widening view to match more files is not currently supported."
Widening -> giveup "Widening view to match more files is not currently supported."

View file

@ -25,7 +25,7 @@ seek = withNothing start
start ::CommandStart
start = go =<< currentView
where
go Nothing = error "Not in a view."
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart "vcycle" ""
let v' = v { viewComponents = vcycle [] (viewComponents v) }

View file

@ -26,5 +26,5 @@ start params = do
let view' = filterView view $
map parseViewParam $ reverse params
next $ next $ if visibleViewSize view' > visibleViewSize view
then error "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter."
else checkoutViewBranch view' narrowView

View file

@ -26,7 +26,7 @@ seek = withWords start
start :: [String] -> CommandStart
start ps = go =<< currentView
where
go Nothing = error "Not in a view."
go Nothing = giveup "Not in a view."
go (Just v) = do
showStart "vpop" (show num)
removeView v

View file

@ -50,7 +50,7 @@ vicfg curcfg f = do
vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR"
-- Allow EDITOR to be processed by the shell, so it can contain options.
unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
error $ vi ++ " exited nonzero; aborting"
giveup $ vi ++ " exited nonzero; aborting"
r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrictAnyEncoding f)
liftIO $ nukeFile f
case r of

View file

@ -25,7 +25,7 @@ seek :: CmdParams -> CommandSeek
seek = withWords start
start :: [String] -> CommandStart
start [] = error "Specify metadata to include in view"
start [] = giveup "Specify metadata to include in view"
start ps = do
showStart "view" ""
view <- mkView ps
@ -34,7 +34,7 @@ start ps = do
go view Nothing = next $ perform view
go view (Just v)
| v == view = stop
| otherwise = error "Already in a view. Use the vfilter and vadd commands to further refine this view."
| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."
perform :: View -> CommandPerform
perform view = do
@ -47,7 +47,7 @@ paramView = paramRepeating "FIELD=VALUE"
mkView :: [String] -> Annex View
mkView ps = go =<< inRepo Git.Branch.current
where
go Nothing = error "not on any branch!"
go Nothing = giveup "not on any branch!"
go (Just b) = return $ fst $ refineView (View b []) $
map parseViewParam $ reverse ps

View file

@ -37,7 +37,7 @@ cmd' name desc getter setter = command name SectionSetup desc pdesc (withParams
start (rname:expr:[]) = go rname $ \uuid -> do
showStart name rname
performSet setter expr uuid
start _ = error "Specify a repository."
start _ = giveup "Specify a repository."
go rname a = do
u <- Remote.nameToUUID rname
@ -52,7 +52,7 @@ performGet getter a = do
performSet :: (a -> PreferredContentExpression -> Annex ()) -> String -> a -> CommandPerform
performSet setter expr a = case checkPreferredContentExpression expr of
Just e -> error $ "Parse error: " ++ e
Just e -> giveup $ "Parse error: " ++ e
Nothing -> do
setter a expr
next $ return True

View file

@ -77,7 +77,7 @@ start' allowauto o = do
else annexListen <$> Annex.getGitConfig
ifM (checkpid <&&> checkshim f)
( if isJust (listenAddress o)
then error "The assistant is already running, so --listen cannot be used."
then giveup "The assistant is already running, so --listen cannot be used."
else do
url <- liftIO . readFile
=<< fromRepo gitAnnexUrlFile
@ -125,7 +125,7 @@ startNoRepo o = go =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
go ds
Right state -> void $ Annex.eval state $ do
whenM (fromRepo Git.repoIsLocalBare) $
error $ d ++ " is a bare git repository, cannot run the webapp in it"
giveup $ d ++ " is a bare git repository, cannot run the webapp in it"
callCommandAction $
start' False o

View file

@ -80,4 +80,4 @@ readProgramFile = do
cannotFindProgram :: IO a
cannotFindProgram = do
f <- programFile
error $ "cannot find git-annex program in PATH or in the location listed in " ++ f
giveup $ "cannot find git-annex program in PATH or in the location listed in " ++ f

View file

@ -105,7 +105,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
-- Not a problem for shared cipher.
case storablecipher of
SharedCipher {} -> showLongNote "gpg error above was caused by an old git-annex bug in credentials storage. Working around it.."
_ -> error "*** Insecure credentials storage detected for this remote! See https://git-annex.branchable.com/upgrades/insecure_embedded_creds/"
_ -> giveup "*** Insecure credentials storage detected for this remote! See https://git-annex.branchable.com/upgrades/insecure_embedded_creds/"
fromcreds $ fromB64 enccreds
fromcreds creds = case decodeCredPair creds of
Just credpair -> do

View file

@ -100,7 +100,7 @@ genSharedPubKeyCipher cmd keyid highQuality = do
-
- When the Cipher is encrypted, re-encrypts it. -}
updateCipherKeyIds :: LensGpgEncParams encparams => Gpg.GpgCmd -> encparams -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher
updateCipherKeyIds _ _ _ SharedCipher{} = error "Cannot update shared cipher"
updateCipherKeyIds _ _ _ SharedCipher{} = giveup "Cannot update shared cipher"
updateCipherKeyIds _ _ [] c = return c
updateCipherKeyIds cmd encparams changes encipher@(EncryptedCipher _ variant ks) = do
ks' <- updateCipherKeyIds' cmd changes ks
@ -113,11 +113,11 @@ updateCipherKeyIds' :: Gpg.GpgCmd -> [(Bool, Gpg.KeyId)] -> KeyIds -> IO KeyIds
updateCipherKeyIds' cmd changes (KeyIds ks) = do
dropkeys <- listKeyIds [ k | (False, k) <- changes ]
forM_ dropkeys $ \k -> unless (k `elem` ks) $
error $ "Key " ++ k ++ " was not present; cannot remove."
giveup $ "Key " ++ k ++ " was not present; cannot remove."
addkeys <- listKeyIds [ k | (True, k) <- changes ]
let ks' = (addkeys ++ ks) \\ dropkeys
when (null ks') $
error "Cannot remove the last key."
giveup "Cannot remove the last key."
return $ KeyIds ks'
where
listKeyIds = concat <$$> mapM (keyIds <$$> Gpg.findPubKeys cmd)

View file

@ -25,7 +25,7 @@ toSKey :: Key -> SKey
toSKey = SKey . key2file
fromSKey :: SKey -> Key
fromSKey (SKey s) = fromMaybe (error $ "bad serialied Key " ++ s) (file2key s)
fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s)
derivePersistField "SKey"
@ -43,7 +43,7 @@ toIKey :: Key -> IKey
toIKey = IKey . key2file
fromIKey :: IKey -> Key
fromIKey (IKey s) = fromMaybe (error $ "bad serialied Key " ++ s) (file2key s)
fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s)
derivePersistField "IKey"

View file

@ -50,7 +50,7 @@ prepare input showmatch matches r =
| otherwise -> sleep n
Nothing -> list
where
list = error $ unlines $
list = giveup $ unlines $
[ "Unknown command '" ++ input ++ "'"
, ""
, "Did you mean one of these?"

View file

@ -52,7 +52,7 @@ get = do
curr <- getCurrentDirectory
Git.Config.read $ newFrom $
Local { gitdir = absd, worktree = Just curr }
configure Nothing Nothing = error "Not in a git repository."
configure Nothing Nothing = giveup "Not in a git repository."
addworktree w r = changelocation r $
Local { gitdir = gitdir (location r), worktree = w }

View file

@ -46,7 +46,7 @@ encryptedRemote baserepo = go
u = show url
plen = length urlPrefix
go _ = notencrypted
notencrypted = error "not a gcrypt encrypted repository"
notencrypted = giveup "not a gcrypt encrypted repository"
data ProbeResult = Decryptable | NotDecryptable | NotEncrypted

View file

@ -73,7 +73,7 @@ addToken = add . Utility.Matcher.token
{- Adds a new limit. -}
addLimit :: Either String (MatchFiles Annex) -> Annex ()
addLimit = either error (\l -> add $ Utility.Matcher.Operation $ l S.empty)
addLimit = either giveup (\l -> add $ Utility.Matcher.Operation $ l S.empty)
{- Add a limit to skip files that do not match the glob. -}
addInclude :: String -> Annex ()
@ -289,7 +289,7 @@ limitMetaData s = case parseMetaDataMatcher s of
addTimeLimit :: String -> Annex ()
addTimeLimit s = do
let seconds = maybe (error "bad time-limit") durationToPOSIXTime $
let seconds = maybe (giveup "bad time-limit") durationToPOSIXTime $
parseDuration s
start <- liftIO getPOSIXTime
let cutoff = start + seconds

View file

@ -60,7 +60,7 @@ parseTransitions = check . map parseTransitionLine . splitLines
parseTransitionsStrictly :: String -> String -> Transitions
parseTransitionsStrictly source = fromMaybe badsource . parseTransitions
where
badsource = error $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"
badsource = giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"
showTransitionLine :: TransitionLine -> String
showTransitionLine (TransitionLine ts t) = unwords [show t, show ts]

View file

@ -112,7 +112,7 @@ byUUID u = headMaybe . filter matching <$> remoteList
-}
byName :: Maybe RemoteName -> Annex (Maybe Remote)
byName Nothing = return Nothing
byName (Just n) = either error Just <$> byName' n
byName (Just n) = either giveup Just <$> byName' n
{- Like byName, but the remote must have a configured UUID. -}
byNameWithUUID :: Maybe RemoteName -> Annex (Maybe Remote)
@ -120,7 +120,7 @@ byNameWithUUID = checkuuid <=< byName
where
checkuuid Nothing = return Nothing
checkuuid (Just r)
| uuid r == NoUUID = error $
| uuid r == NoUUID = giveup $
if remoteAnnexIgnore (gitconfig r)
then noRemoteUUIDMsg r ++
" (" ++ show (remoteConfig (repo r) "ignore") ++
@ -156,7 +156,7 @@ noRemoteUUIDMsg r = "cannot determine uuid for " ++ name r ++ " (perhaps you nee
- and returns its UUID. Finds even repositories that are not
- configured in .git/config. -}
nameToUUID :: RemoteName -> Annex UUID
nameToUUID = either error return <=< nameToUUID'
nameToUUID = either giveup return <=< nameToUUID'
nameToUUID' :: RemoteName -> Annex (Either String UUID)
nameToUUID' "." = Right <$> getUUID -- special case for current repo

View file

@ -111,7 +111,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 +138,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 +268,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 +343,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 +366,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 +379,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

View file

@ -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

View file

@ -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

View file

@ -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"
)
)

View file

@ -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 ()
@ -413,14 +412,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 +451,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 +459,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 +519,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 +529,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

View file

@ -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

View file

@ -95,20 +95,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)
@ -202,7 +202,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 +321,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) $
@ -357,7 +357,7 @@ dropKey r key
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
@ -414,7 +414,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 +444,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 +547,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

View file

@ -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

View file

@ -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]

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

Some files were not shown because too many files have changed in this diff Show more