diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index 4caf637c7e..72c07a5bc4 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -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." diff --git a/Annex/Branch.hs b/Annex/Branch.hs index a426c76d85..9663311d51 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -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 diff --git a/Annex/Content.hs b/Annex/Content.hs index cb96a0068b..e879e4eebb 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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 diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index fa46e64b1d..654c5a9606 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -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 diff --git a/Annex/Init.hs b/Annex/Init.hs index 5aff4cf398..8a208fe2bb 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -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. -} diff --git a/Annex/View.hs b/Annex/View.hs index 7d2b43e608..d865c8f783 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -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 diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 1f50065b9c..4b82a799d7 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -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" diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 58effdc1c0..f9a456f357 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -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 diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index fa5870f3ea..28b838dc2b 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index bec3123f89..981477e114 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -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 () diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index a6816958e7..c46fcf510e 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 76f21e9937..f2079c0ed2 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 5ad28402e4..950290249c 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 613e5439a7..9c168d744f 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -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 diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs index 6afb20fd11..10223ccccb 100644 --- a/Assistant/WebApp/Gpg.hs +++ b/Assistant/WebApp/Gpg.hs @@ -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. -} diff --git a/CHANGELOG b/CHANGELOG index a792d71cc7..71ef1c1002 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -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 Tue, 15 Nov 2016 11:15:27 -0400 diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 7d9dce5743..27621e4458 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -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, diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index cca93b0b39..627c1df101 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -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. -- diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 599d12fec1..70c86ec2f7 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -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 ...]" diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs index 63d2e594f7..47bc11a767 100644 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -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." diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 5d20ad0dbe..7fc64c5284 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 diff --git a/Command.hs b/Command.hs index 94a4742577..f8d4fe32bb 100644 --- a/Command.hs +++ b/Command.hs @@ -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 diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 7a9a1ba30c..c83c74e726 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -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" diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 80f3582ed5..e32ceb5684 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -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 diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 690f36f199..6a9ae6436a 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -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 diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs index 29df810a63..4f9b4b1207 100644 --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -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) diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index 5b2acb6a54..202d76a21d 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -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 diff --git a/Command/Dead.hs b/Command/Dead.hs index ecbe412938..44cf7b7f6a 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -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 diff --git a/Command/Describe.hs b/Command/Describe.hs index 8872244f0f..dc7a5d8f91 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -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 diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index 2c9b4a39dc..1164dd103b 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -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. diff --git a/Command/Direct.hs b/Command/Direct.hs index 32d63f0598..06adf0e05b 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -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 diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 42516f838c..65446ba06e 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -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 diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index dc3e7bc56e..e1af8bb7a4 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -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 diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index e14ac10b8e..24d6942fe5 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -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 diff --git a/Command/Expire.hs b/Command/Expire.hs index fafee4506e..8dd0e962e5 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -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 diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 36cc1d31fd..670e9e6a6b 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index b37a26e122..9383c07f27 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 4aed02d465..0c5aac9b33 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -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" diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index f2943ea134..cbc2de0efb 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -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" diff --git a/Command/Group.hs b/Command/Group.hs index 8e901dfb34..6d9b4ab131 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -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 diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs index 6a9e300bf3..c0be2462db 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -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." diff --git a/Command/Import.hs b/Command/Import.hs index d5a2feed59..a16349ad2a 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -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) diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 8f3a607261..1736f2567c 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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 ) diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 74841a5f63..f12f9e59e7 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -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 ) diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 05717bc609..e5d7a90390 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -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 diff --git a/Command/Lock.hs b/Command/Lock.hs index 68360705cc..a3fc251172 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -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)" diff --git a/Command/LockContent.hs b/Command/LockContent.hs index de697c0901..35342c529b 100644 --- a/Command/LockContent.hs +++ b/Command/LockContent.hs @@ -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." diff --git a/Command/Log.hs b/Command/Log.hs index 3806d8fdf7..357bcf1f3e 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -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 diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 6e64207c83..04d859e4cf 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -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 diff --git a/Command/Move.hs b/Command/Move.hs index 9c43c6f1db..d74eea9003 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -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." diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index 0a9c4404b4..005a0d16af 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -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 diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index f55318475c..1ff2227d83 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -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 diff --git a/Command/Proxy.hs b/Command/Proxy.hs index f1f7f194f6..dba0300b8c 100644 --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -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 diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 4d20395307..51f9f6fe15 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -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 diff --git a/Command/ReadPresentKey.hs b/Command/ReadPresentKey.hs index 1eba2cc122..f73e22af40 100644 --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -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" diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index 273d111b0c..28dd2d8c5a 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index fa2459e22d..97aa602e7b 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -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 diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index 8742a1104f..0ba6efb362 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -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" diff --git a/Command/Schedule.hs b/Command/Schedule.hs index 5721e98e76..5cc8b37bf5 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -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 diff --git a/Command/SetKey.hs b/Command/SetKey.hs index fd7a4ab887..090edee0ba 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -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 diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs index 20c96ae365..da2a6fa3d9 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index fb80c3e74b..acc5fbbc94 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 40d02c166c..4c0ff9e3c8 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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) diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 21b7830c31..6870c84f01 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -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 diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 4e83fd4209..e744b51a86 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -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 diff --git a/Command/Undo.hs b/Command/Undo.hs index 24c099f92c..c366453a3d 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -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 diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index 5f84a375f0..ddcdba4667 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -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 diff --git a/Command/Uninit.hs b/Command/Uninit.hs index fa7e130137..d8c7d1295a 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -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." diff --git a/Command/Unused.hs b/Command/Unused.hs index c116cdc0e1..1711fe047c 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -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 diff --git a/Command/VAdd.hs b/Command/VAdd.hs index a4b3f379f2..c94ce57229 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -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." diff --git a/Command/VCycle.hs b/Command/VCycle.hs index 20fc9a22a6..28326e16fa 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -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) } diff --git a/Command/VFilter.hs b/Command/VFilter.hs index 60bbcd3d3f..130e2550cb 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -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 diff --git a/Command/VPop.hs b/Command/VPop.hs index 8490567dc6..58411001be 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -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 diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index d7963725a9..64daa598b7 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -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 diff --git a/Command/View.hs b/Command/View.hs index 65985fdac9..513e6d10c0 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -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 diff --git a/Command/Wanted.hs b/Command/Wanted.hs index dca92a7b42..8fd369df6a 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -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 diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 4dff8c9d16..d9c001b226 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -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 diff --git a/Config/Files.hs b/Config/Files.hs index 8f8b4c1158..b18d912e9e 100644 --- a/Config/Files.hs +++ b/Config/Files.hs @@ -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 diff --git a/Creds.hs b/Creds.hs index e818317c78..6be9b33916 100644 --- a/Creds.hs +++ b/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 diff --git a/Crypto.hs b/Crypto.hs index f3d6f5e5a9..d3cbfa2f7f 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -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) diff --git a/Database/Types.hs b/Database/Types.hs index 4521bb3463..9eabc6983e 100644 --- a/Database/Types.hs +++ b/Database/Types.hs @@ -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" diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs index 7a9d788511..ae7cc91a87 100644 --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -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?" diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index dab4ad21bf..69a679ee36 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -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 } diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index 2a2f7dfe15..e61b763588 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -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 diff --git a/Limit.hs b/Limit.hs index 4bd5dd59e3..efe4fea85b 100644 --- a/Limit.hs +++ b/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 diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs index 07667c4074..04f9824b16 100644 --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -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] diff --git a/Remote.hs b/Remote.hs index 10c526e1e4..bcd91b7034 100644 --- a/Remote.hs +++ b/Remote.hs @@ -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 diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index a0ccf99df2..899c57e3eb 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 22510859c0..332e8d5dc6 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -84,7 +84,7 @@ gen r u c gc = do (simplyPrepare $ checkKey r bupr') this where - buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc + buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc specialcfg = (specialRemoteCfg c) -- chunking would not improve bup { chunkConfig = NoChunks @@ -95,14 +95,14 @@ bupSetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let buprepo = fromMaybe (error "Specify buprepo=") $ + let buprepo = fromMaybe (giveup "Specify buprepo=") $ M.lookup "buprepo" c (c', _encsetup) <- encryptionSetup c gc -- bup init will create the repository. -- (If the repository already exists, bup init again appears safe.) showAction "bup init" - unlessM (bup "init" buprepo []) $ error "bup init failed" + unlessM (bup "init" buprepo []) $ giveup "bup init failed" storeBupUUID u buprepo @@ -197,7 +197,7 @@ storeBupUUID u buprepo = do showAction "storing uuid" unlessM (onBupRemote r boolSystem "git" [Param "config", Param "annex.uuid", Param v]) $ - error "ssh failed" + giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r let olduuid = Git.Config.get "annex.uuid" "" r' @@ -251,7 +251,7 @@ bup2GitRemote r | bupLocal r = if "/" `isPrefixOf` r then Git.Construct.fromAbsPath r - else error "please specify an absolute path" + else giveup "please specify an absolute path" | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir where bits = split ":" r diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index fded8d4200..dcb16f5ddc 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -76,7 +76,7 @@ gen r u c gc = do , claimUrl = Nothing , checkUrl = Nothing } - ddarrepo = maybe (error "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) + ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) specialcfg = (specialRemoteCfg c) -- chunking would not improve ddar { chunkConfig = NoChunks @@ -87,7 +87,7 @@ ddarSetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let ddarrepo = fromMaybe (error "Specify ddarrepo=") $ + let ddarrepo = fromMaybe (giveup "Specify ddarrepo=") $ M.lookup "ddarrepo" c (c', _encsetup) <- encryptionSetup c gc diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 3b26947b63..248e5d49f7 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -75,17 +75,17 @@ gen r u c gc = do , checkUrl = Nothing } where - dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc + dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) directorySetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let dir = fromMaybe (error "Specify directory=") $ + let dir = fromMaybe (giveup "Specify directory=") $ M.lookup "directory" c absdir <- liftIO $ absPath dir liftIO $ unlessM (doesDirectoryExist absdir) $ - error $ "Directory does not exist: " ++ absdir + giveup $ "Directory does not exist: " ++ absdir (c', _encsetup) <- encryptionSetup c gc -- The directory is stored in git config, not in this remote's @@ -216,6 +216,6 @@ checkKey d _ k = liftIO $ ( return True , ifM (doesDirectoryExist d) ( return False - , error $ "directory " ++ d ++ " is not accessible" + , giveup $ "directory " ++ d ++ " is not accessible" ) ) diff --git a/Remote/External.hs b/Remote/External.hs index 65b05fe624..0b0e1dc18b 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -107,12 +107,12 @@ gen r u c gc (simplyPrepare toremove) (simplyPrepare tocheckkey) rmt - externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc) + externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc) externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) externalSetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu - let externaltype = fromMaybe (error "Specify externaltype=") $ + let externaltype = fromMaybe (giveup "Specify externaltype=") $ M.lookup "externaltype" c (c', _encsetup) <- encryptionSetup c gc @@ -124,7 +124,7 @@ externalSetup mu _ c gc = do external <- newExternal externaltype u c' gc handleRequest external INITREMOTE Nothing $ \resp -> case resp of INITREMOTE_SUCCESS -> Just noop - INITREMOTE_FAILURE errmsg -> Just $ error errmsg + INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg _ -> Nothing withExternalState external $ liftIO . atomically . readTVar . externalConfig @@ -151,8 +151,7 @@ retrieve external = fileRetriever $ \d k p -> TRANSFER_SUCCESS Download k' | k == k' -> Just $ return () TRANSFER_FAILURE Download k' errmsg - | k == k' -> Just $ do - error errmsg + | k == k' -> Just $ giveup errmsg _ -> Nothing remove :: External -> Remover @@ -168,7 +167,7 @@ remove external k = safely $ _ -> Nothing checkKey :: External -> CheckPresent -checkKey external k = either error id <$> go +checkKey external k = either giveup id <$> go where go = handleRequest external (CHECKPRESENT k) Nothing $ \resp -> case resp of @@ -284,7 +283,7 @@ handleRequest' st external req mp responsehandler handleRemoteRequest (VERSION _) = sendMessage st external (ERROR "too late to send VERSION") - handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err + handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err send = sendMessage st external @@ -332,7 +331,7 @@ receiveMessage st external handleresponse handlerequest handleasync = Nothing -> case parseMessage s :: Maybe AsyncMessage of Just msg -> maybe (protocolError True s) id (handleasync msg) Nothing -> protocolError False s - protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ + protocolError parsed s = giveup $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ if parsed then "(command not allowed at this time)" else "(unable to parse command)" protocolDebug :: External -> ExternalState -> Bool -> String -> IO () @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index a0c8ecaf7a..78ab6ed79c 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -164,16 +164,16 @@ rsyncTransport r gc othertransport = return ([], loc, AccessDirect) noCrypto :: Annex a -noCrypto = error "cannot use gcrypt remote without encryption enabled" +noCrypto = giveup "cannot use gcrypt remote without encryption enabled" unsupportedUrl :: a -unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported" +unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported" gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c where remotename = fromJust (M.lookup "name" c) - go Nothing = error "Specify gitrepo=" + go Nothing = giveup "Specify gitrepo=" go (Just gitrepo) = do (c', _encsetup) <- encryptionSetup c gc inRepo $ Git.Command.run @@ -200,7 +200,7 @@ gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c ] g <- inRepo Git.Config.reRead case Git.GCrypt.remoteRepoId g (Just remotename) of - Nothing -> error "unable to determine gcrypt-id of remote" + Nothing -> giveup "unable to determine gcrypt-id of remote" Just gcryptid -> do let u = genUUIDInNameSpace gCryptNameSpace gcryptid if Just u == mu || isNothing mu @@ -208,7 +208,7 @@ gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo) gitConfigSpecialRemote u c' "gcrypt" (fromAccessMethod method) return (c', u) - else error $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")" + else giveup $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")" {- Sets up the gcrypt repository. The repository is either a local - repo, or it is accessed via rsync directly, or it is accessed over ssh @@ -258,7 +258,7 @@ setupRepo gcryptid r , Param rsyncurl ] unless ok $ - error "Failed to connect to remote to set it up." + giveup "Failed to connect to remote to set it up." return AccessDirect {- Ask git-annex-shell to configure the repository as a gcrypt @@ -337,7 +337,7 @@ retrieve r rsyncopts | Git.repoIsSsh (repo r) = if accessShell r then fileRetriever $ \f k p -> unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $ - error "rsync failed" + giveup "rsync failed" else fileRetriever $ Remote.Rsync.retrieve rsyncopts | otherwise = unsupportedUrl where diff --git a/Remote/Git.hs b/Remote/Git.hs index 34bdd83a16..3304e2069f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index eae2dab684..77a907b97c 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -146,7 +146,7 @@ retrieve r k sink = go =<< glacierEnv c gc u , Param $ getVault $ config r , Param $ archive r k ] - go Nothing = error "cannot retrieve from glacier" + go Nothing = giveup "cannot retrieve from glacier" go (Just e) = do let cmd = (proc "glacier" (toCommand params)) { env = Just e @@ -182,7 +182,7 @@ checkKey r k = do showChecking r go =<< glacierEnv (config r) (gitconfig r) (uuid r) where - go Nothing = error "cannot check glacier" + go Nothing = giveup "cannot check glacier" go (Just e) = do {- glacier checkpresent outputs the archive name to stdout if - it's present. -} @@ -190,7 +190,7 @@ checkKey r k = do let probablypresent = key2file k `elem` lines s if probablypresent then ifM (Annex.getFlag "trustglacier") - ( return True, error untrusted ) + ( return True, giveup untrusted ) else return False params = glacierParams (config r) @@ -222,7 +222,7 @@ glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam] glacierParams c params = datacenter:params where datacenter = Param $ "--region=" ++ - fromMaybe (error "Missing datacenter configuration") + fromMaybe (giveup "Missing datacenter configuration") (M.lookup "datacenter" c) glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)]) @@ -239,7 +239,7 @@ glacierEnv c gc u = do (uk, pk) = credPairEnvironment creds getVault :: RemoteConfig -> Vault -getVault = fromMaybe (error "Missing vault configuration") +getVault = fromMaybe (giveup "Missing vault configuration") . M.lookup "vault" archive :: Remote -> Key -> Archive @@ -249,7 +249,7 @@ archive r k = fileprefix ++ key2file k genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex () genVault c gc u = unlessM (runGlacier c gc u params) $ - error "Failed creating glacier vault." + giveup "Failed creating glacier vault." where params = [ Param "vault" @@ -312,7 +312,7 @@ jobList r keys = go =<< glacierEnv (config r) (gitconfig r) (uuid r) checkSaneGlacierCommand :: IO () checkSaneGlacierCommand = whenM ((Nothing /=) <$> catchMaybeIO shouldfail) $ - error wrongcmd + giveup wrongcmd where test = proc "glacier" ["--compatibility-test-git-annex"] shouldfail = withQuietOutput createProcessSuccess test diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index e3cf0d27b8..103dcf4ca1 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -59,7 +59,7 @@ getChunkConfig m = Just size | size == 0 -> NoChunks | size > 0 -> c (fromInteger size) - _ -> error $ "bad configuration " ++ f ++ "=" ++ v + _ -> giveup $ "bad configuration " ++ f ++ "=" ++ v -- An infinite stream of chunk keys, starting from chunk 1. newtype ChunkKeyStream = ChunkKeyStream [Key] diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 05c3e38a5e..45ceae0681 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -66,14 +66,14 @@ encryptionSetup c gc = do encsetup $ genEncryptedCipher cmd (c, gc) key Hybrid Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key - _ -> error $ "Specify " ++ intercalate " or " + _ -> giveup $ "Specify " ++ intercalate " or " (map ("encryption=" ++) ["none","shared","hybrid","pubkey", "sharedpubkey"]) ++ "." - key = fromMaybe (error "Specifiy keyid=...") $ M.lookup "keyid" c + key = fromMaybe (giveup "Specifiy keyid=...") $ M.lookup "keyid" c newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++ maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c) - cannotchange = error "Cannot set encryption type of existing remotes." + cannotchange = giveup "Cannot set encryption type of existing remotes." -- Update an existing cipher if possible. updateCipher cmd v = case v of SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup) diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs index f01dfd9224..ebe0f2598e 100644 --- a/Remote/Helper/Http.hs +++ b/Remote/Helper/Http.hs @@ -70,7 +70,7 @@ handlePopper numchunks chunksize meterupdate h sink = do -- meter as it goes. httpBodyRetriever :: FilePath -> MeterUpdate -> Response BodyReader -> IO () httpBodyRetriever dest meterupdate resp - | responseStatus resp /= ok200 = error $ show $ responseStatus resp + | responseStatus resp /= ok200 = giveup $ show $ responseStatus resp | otherwise = bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed) where reader = responseBody resp diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs index 484ea19552..0148257760 100644 --- a/Remote/Helper/Messages.hs +++ b/Remote/Helper/Messages.hs @@ -29,7 +29,7 @@ showChecking :: Describable a => a -> Annex () showChecking v = showAction $ "checking " ++ describe v cantCheck :: Describable a => a -> e -cantCheck v = error $ "unable to check " ++ describe v +cantCheck v = giveup $ "unable to check " ++ describe v showLocking :: Describable a => a -> Annex () showLocking v = showAction $ "locking " ++ describe v diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 4ec772296d..dff16b6568 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -29,7 +29,7 @@ import Config toRepo :: Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam] toRepo r gc sshcmd = do let opts = map Param $ remoteAnnexSshOptions gc - let host = fromMaybe (error "bad ssh url") $ Git.Url.hostuser r + let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r params <- sshOptions (host, Git.Url.port r) gc opts return $ params ++ Param host : sshcmd diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 7d8f7f0967..6abffe1177 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -68,12 +68,12 @@ gen r u c gc = do , checkUrl = Nothing } where - hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc + hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) hookSetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu - let hooktype = fromMaybe (error "Specify hooktype=") $ + let hooktype = fromMaybe (giveup "Specify hooktype=") $ M.lookup "hooktype" c (c', _encsetup) <- encryptionSetup c gc gitConfigSpecialRemote u c' "hooktype" hooktype @@ -129,7 +129,7 @@ store h = fileStorer $ \k src _p -> retrieve :: HookName -> Retriever retrieve h = fileRetriever $ \d k _p -> unlessM (runHook h "retrieve" k (Just d) $ return True) $ - error "failed to retrieve content" + giveup "failed to retrieve content" retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ _ = return False @@ -145,7 +145,7 @@ checkKey r h k = do where action = "checkpresent" findkey s = key2file k `elem` lines s - check Nothing = error $ action ++ " hook misconfigured" + check Nothing = giveup $ action ++ " hook misconfigured" check (Just hook) = do environ <- hookEnv action k Nothing findkey <$> readProcessEnv "sh" ["-c", hook] environ diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 4695ac7a9e..22ef0b2cfb 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -53,7 +53,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot gen r u c gc = do cst <- remoteCost gc expensiveRemoteCost (transport, url) <- rsyncTransport gc $ - fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc + fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc let o = genRsyncOpts c gc transport url let islocal = rsyncUrlIsPath $ rsyncUrl o return $ Just $ specialRemote' specialcfg c @@ -127,7 +127,7 @@ rsyncTransport gc url (map Param $ loginopt ++ sshopts') "rsh":rshopts -> return $ map Param $ "rsh" : loginopt ++ rshopts - rsh -> error $ "Unknown Rsync transport: " + rsh -> giveup $ "Unknown Rsync transport: " ++ unwords rsh | otherwise = return ([], url) where @@ -141,7 +141,7 @@ rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> rsyncSetup mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let url = fromMaybe (error "Specify rsyncurl=") $ + let url = fromMaybe (giveup "Specify rsyncurl=") $ M.lookup "rsyncurl" c (c', _encsetup) <- encryptionSetup c gc @@ -188,7 +188,7 @@ store o k src meterupdate = withRsyncScratchDir $ \tmp -> do retrieve :: RsyncOpts -> FilePath -> Key -> MeterUpdate -> Annex () retrieve o f k p = unlessM (rsyncRetrieve o k f (Just p)) $ - error "rsync failed" + giveup "rsync failed" retrieveCheap :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap o k _af f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False ) diff --git a/Remote/S3.hs b/Remote/S3.hs index 97265e1481..c6f23333f1 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -136,7 +136,7 @@ s3Setup' new u mcreds c gc -- Ensure user enters a valid bucket name, since -- this determines the name of the archive.org item. let validbucket = replace " " "-" $ - fromMaybe (error "specify bucket=") $ + fromMaybe (giveup "specify bucket=") $ getBucketName c' let archiveconfig = -- IA acdepts x-amz-* as an alias for x-archive-* @@ -252,7 +252,7 @@ retrieve r info Nothing = case getpublicurl info of return False Just geturl -> fileRetriever $ \f k p -> unlessM (downloadUrl k p [geturl k] f) $ - error "failed to download content" + giveup "failed to download content" retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False @@ -301,7 +301,7 @@ checkKey r info (Just h) k = do checkKey r info Nothing k = case getpublicurl info of Nothing -> do warnMissingCredPairFor "S3" (AWS.creds $ uuid r) - error "No S3 credentials configured" + giveup "No S3 credentials configured" Just geturl -> do showChecking r withUrlOptions $ checkBoth (geturl k) (keySize k) @@ -415,7 +415,7 @@ withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of Just h -> a h Nothing -> do warnMissingCredPairFor "S3" (AWS.creds u) - error "No S3 credentials configured" + giveup "No S3 credentials configured" withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a withS3HandleMaybe c gc u a = do @@ -437,7 +437,7 @@ s3Configuration c = cfg { S3.s3Port = port , S3.s3RequestStyle = case M.lookup "requeststyle" c of Just "path" -> S3.PathStyle - Just s -> error $ "bad S3 requeststyle value: " ++ s + Just s -> giveup $ "bad S3 requeststyle value: " ++ s Nothing -> S3.s3RequestStyle cfg } where @@ -455,7 +455,7 @@ s3Configuration c = cfg port = let s = fromJust $ M.lookup "port" c in case reads s of [(p, _)] -> p - _ -> error $ "bad S3 port value: " ++ s + _ -> giveup $ "bad S3 port value: " ++ s cfg = S3.s3 proto endpoint False tryS3 :: Annex a -> Annex (Either S3.S3Error a) @@ -475,7 +475,7 @@ data S3Info = S3Info extractS3Info :: RemoteConfig -> Annex S3Info extractS3Info c = do b <- maybe - (error "S3 bucket not configured") + (giveup "S3 bucket not configured") (return . T.pack) (getBucketName c) let info = S3Info diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 05b120d461..c29cfb438f 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -109,7 +109,7 @@ tahoeSetup mu _ c _ = do where scsk = "shared-convergence-secret" furlk = "introducer-furl" - missingfurl = error "Set TAHOE_FURL to the introducer furl to use." + missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." store :: UUID -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store u hdl k _f _p = sendAnnex k noop $ \src -> @@ -137,7 +137,7 @@ checkKey u hdl k = go =<< getCapability u k [ Param "--raw" , Param cap ] - either error return v + either giveup return v defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir defaultTahoeConfigDir u = do @@ -147,7 +147,7 @@ defaultTahoeConfigDir u = do tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret tahoeConfigure configdir furl mscs = do unlessM (createClient configdir furl) $ - error "tahoe create-client failed" + giveup "tahoe create-client failed" maybe noop (writeSharedConvergenceSecret configdir) mscs startTahoeDaemon configdir getSharedConvergenceSecret configdir @@ -173,7 +173,7 @@ getSharedConvergenceSecret configdir = go (60 :: Int) where f = convergenceFile configdir go n - | n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?" + | n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?" | otherwise = do v <- catchMaybeIO (readFile f) case v of diff --git a/Remote/Web.hs b/Remote/Web.hs index 033057dd8d..be2f265e08 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -100,7 +100,7 @@ checkKey key = do us <- getWebUrls key if null us then return False - else either error return =<< checkKey' key us + else either giveup return =<< checkKey' key us checkKey' :: Key -> [URLString] -> Annex (Either String Bool) checkKey' key us = firsthit us (Right False) $ \u -> do let (u', downloader) = getDownloader u diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 3de8b357e6..19dbaa8af5 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -85,7 +85,7 @@ webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig - webdavSetup mu mcreds c gc = do u <- maybe (liftIO genUUID) return mu url <- case M.lookup "url" c of - Nothing -> error "Specify url=" + Nothing -> giveup "Specify url=" Just url -> return url (c', encsetup) <- encryptionSetup c gc creds <- maybe (getCreds c' gc u) (return . Just) mcreds @@ -122,7 +122,7 @@ retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever -retrieve _ Nothing = error "unable to connect" +retrieve _ Nothing = giveup "unable to connect" retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $ goDAV dav $ @@ -147,7 +147,7 @@ remove (Just dav) k = liftIO $ do _ -> return False checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent -checkKey r _ Nothing _ = error $ name r ++ " not configured" +checkKey r _ Nothing _ = giveup $ name r ++ " not configured" checkKey r chunkconfig (Just dav) k = do showChecking r case chunkconfig of @@ -155,7 +155,7 @@ checkKey r chunkconfig (Just dav) k = do _ -> do v <- liftIO $ goDAV dav $ existsDAV (keyLocation k) - either error return v + either giveup return v configUrl :: Remote -> Maybe URLString configUrl r = fixup <$> M.lookup "url" (config r) diff --git a/Upgrade.hs b/Upgrade.hs index 20ed7a4022..c6552f89c0 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -21,7 +21,7 @@ import qualified Upgrade.V4 import qualified Upgrade.V5 checkUpgrade :: Version -> Annex () -checkUpgrade = maybe noop error <=< needsUpgrade +checkUpgrade = maybe noop giveup <=< needsUpgrade needsUpgrade :: Version -> Annex (Maybe String) needsUpgrade v @@ -49,8 +49,8 @@ upgrade automatic destversion = do go (Just "0") = Upgrade.V0.upgrade go (Just "1") = Upgrade.V1.upgrade #else - go (Just "0") = error "upgrade from v0 on Windows not supported" - go (Just "1") = error "upgrade from v1 on Windows not supported" + go (Just "0") = giveup "upgrade from v0 on Windows not supported" + go (Just "1") = giveup "upgrade from v1 on Windows not supported" #endif go (Just "2") = Upgrade.V2.upgrade go (Just "3") = Upgrade.V3.upgrade automatic diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 3cc2eb2613..5c0ea41696 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -111,7 +111,7 @@ lockPidFile pidfile = do #endif alreadyRunning :: IO () -alreadyRunning = error "Daemon is already running." +alreadyRunning = giveup "Daemon is already running." {- Checks if the daemon is running, by checking that the pid file - is locked by the same process that is listed in the pid file. @@ -135,7 +135,7 @@ checkDaemon pidfile = bracket setup cleanup go check _ Nothing = Nothing check (Just (pid, _)) (Just pid') | pid == pid' = Just pid - | otherwise = error $ + | otherwise = giveup $ "stale pid in " ++ pidfile ++ " (got " ++ show pid' ++ "; expected " ++ show pid ++ " )" diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs index a07139c44b..d7472d490a 100644 --- a/Utility/DirWatcher/FSEvents.hs +++ b/Utility/DirWatcher/FSEvents.hs @@ -17,7 +17,7 @@ import Data.Bits ((.&.)) watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO EventStream watchDir dir ignored scanevents hooks = do unlessM fileLevelEventsSupported $ - error "Need at least OSX 10.7.0 for file-level FSEvents" + giveup "Need at least OSX 10.7.0 for file-level FSEvents" scan dir eventStreamCreate [dir] 1.0 True True True dispatch where diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index 4d11b95a8d..1890b8af5e 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -152,7 +152,7 @@ watchDir i dir ignored scanevents hooks -- disk full error. | isFullError e = case errHook hooks of - Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")" + Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")" Just hook -> tooManyWatches hook dir -- The directory could have been deleted. | isDoesNotExistError e = return () diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 0ffc7103fa..5cd8fd1997 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2016 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -40,6 +41,17 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +#if MIN_VERSION_base(4,9,0) +giveup = errorWithoutStackTrace +#else +giveup = error +#endif + {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False diff --git a/Utility/Glob.hs b/Utility/Glob.hs index 98ffe751ba..119ea48347 100644 --- a/Utility/Glob.hs +++ b/Utility/Glob.hs @@ -12,6 +12,8 @@ module Utility.Glob ( matchGlob ) where +import Utility.Exception + import System.Path.WildMatch import "regex-tdfa" Text.Regex.TDFA @@ -26,7 +28,7 @@ compileGlob :: String -> GlobCase -> Glob compileGlob glob globcase = Glob $ case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of Right r -> r - Left _ -> error $ "failed to compile regex: " ++ regex + Left _ -> giveup $ "failed to compile regex: " ++ regex where regex = '^':wildToRegex glob casesentitive = case globcase of diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 21171b6fb0..1185152220 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -253,7 +253,7 @@ genRandom cmd highQuality size = checksize <$> readStrict cmd params then s else shortread len - shortread got = error $ unwords + shortread got = giveup $ unwords [ "Not enough bytes returned from gpg", show params , "(got", show got, "; expected", show expectedlength, ")" ] diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 6a3e86a3f5..bc8ddfe6bb 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -210,7 +210,7 @@ waitLock (Seconds timeout) lockfile = go timeout =<< tryLock lockfile | otherwise = do hPutStrLn stderr $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ lockfile - error $ "Gave up waiting for possibly stale pid lock file " ++ lockfile + giveup $ "Gave up waiting for possibly stale pid lock file " ++ lockfile dropLock :: LockHandle -> IO () dropLock (LockHandle lockfile _ sidelock) = do diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs index 09f74968b0..417ab7041c 100644 --- a/Utility/Quvi.hs +++ b/Utility/Quvi.hs @@ -79,8 +79,8 @@ forceQuery :: Query (Maybe Page) forceQuery v ps url = query' v ps url `catchNonAsync` onerr where onerr e = ifM (inPath "quvi") - ( error ("quvi failed: " ++ show e) - , error "quvi is not installed" + ( giveup ("quvi failed: " ++ show e) + , giveup "quvi is not installed" ) {- Returns Nothing if the page is not a video page, or quvi is not diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index ec0b0d0b2e..dd66c331e6 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -16,6 +16,7 @@ module Utility.UserInfo ( import Utility.Env import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -25,7 +26,7 @@ import Prelude - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = either error return =<< myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"]