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:
parent
69915c6c9b
commit
0a4479b8ec
116 changed files with 287 additions and 270 deletions
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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.
|
||||
--
|
||||
|
|
|
@ -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 ...]"
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)"
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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) }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
2
Creds.hs
2
Creds.hs
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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?"
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
4
Limit.hs
4
Limit.hs
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
)
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
Loading…
Reference in a new issue