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
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."
-- 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
)
<$> 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
(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
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
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. -}
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
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
#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"
#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
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
]
_ -> $(widgetFile "configurators/adds3")
#else
-postAddS3R = error "S3 not supported by this build"
+postAddS3R = giveup "S3 not supported by this build"
#endif
getAddGlacierR :: Handler Html
]
_ -> $(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
#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
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 ()
]
_ -> $(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
#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
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"
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
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
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
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
]
_ -> $(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
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
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
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.
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. -}
* sync: Pass --allow-unrelated-histories to git merge when used with git
git 2.9.0 or newer. This makes merging a remote into a freshly created
direct mode repository work the same as it works in indirect mode.
+ * Avoid backtraces on expected failures when built with ghc 8;
+ only use backtraces for unexpected errors.
-- Joey Hess <id@joeyh.name> Tue, 15 Nov 2016 11:15:27 -0400
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,
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.
--
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 ()
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
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:
| 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 ...]"
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
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'
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."
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
[] -> do
void $ liftIO $ cleanup
getfiles c ps
- _ -> error needforce
+ _ -> giveup needforce
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesNotInGit skipdotfiles a 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 $
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
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
(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
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
- 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"
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."
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
)
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
| 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)
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
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
_ -> wrongnumparams
batchInput Right $ checker >=> batchResult
where
- wrongnumparams = error "Wrong number of parameters"
+ wrongnumparams = giveup "Wrong number of parameters"
data Result = Present | NotPresent | CheckFailure String
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)
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
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
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
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.
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
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
_ -> 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
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
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
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
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
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
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.
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
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
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"
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
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"
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
start (g:expr:[]) = do
showStart "groupwanted" g
next $ performSet groupPreferredContentSet expr g
-start _ = error "Specify a group."
+start _ = giveup "Specify a group."
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)
{- 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
- 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
)
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
)
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
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.
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)"
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
return True
, return False
)
-start _ = error "Specify exactly 1 key."
+start _ = giveup "Specify exactly 1 key."
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
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)
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
]
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."
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
( 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
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
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
( 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
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"
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
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
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
)
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
( 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"
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
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
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
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
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"
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)
, exitSuccess
]
stop
-start _ = error "wrong number of parameters"
+start _ = giveup "wrong number of parameters"
readUpdate :: IO (Maybe Integer)
readUpdate = readish <$> getLine
-}
, 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
-- 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
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
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
{- 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."
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."
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. -}
, (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
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."
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) }
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
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
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
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
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
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
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
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
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
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
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
-- 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
-
- 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
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)
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"
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"
| otherwise -> sleep n
Nothing -> list
where
- list = error $ unlines $
+ list = giveup $ unlines $
[ "Unknown command '" ++ input ++ "'"
, ""
, "Did you mean one of these?"
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 }
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
{- 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 ()
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
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]
-}
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)
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") ++
- 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
- 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
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
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"
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) ]
_ -> 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)
#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
(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
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
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'
| 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
, 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
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
, 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
( return True
, ifM (doesDirectoryExist d)
( return False
- , error $ "directory " ++ d ++ " is not accessible"
+ , giveup $ "directory " ++ d ++ " is not accessible"
)
)
(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
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
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
_ -> 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
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
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 ()
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 ()
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
setprepared Prepared
PREPARE_FAILURE errmsg -> Just $ do
setprepared $ FailedPrepare errmsg
- error errmsg
+ giveup errmsg
_ -> Nothing
where
setprepared status = liftIO $ atomically $ void $
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)
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
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
]
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
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
, 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
| 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
-}
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)
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'
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) $
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
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)
| 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
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
, 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
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. -}
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)
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)])
(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
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"
checkSaneGlacierCommand :: IO ()
checkSaneGlacierCommand =
whenM ((Nothing /=) <$> catchMaybeIO shouldfail) $
- error wrongcmd
+ giveup wrongcmd
where
test = proc "glacier" ["--compatibility-test-git-annex"]
shouldfail = withQuietOutput createProcessSuccess test
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]
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)
-- 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
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
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
, 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
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
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
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
(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
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
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 )
-- 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-*
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
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)
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
{ 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
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)
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
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 ->
[ Param "--raw"
, Param cap
]
- either error return v
+ either giveup return v
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
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
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
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
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
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 $
_ -> 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
_ -> 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)
import qualified Upgrade.V5
checkUpgrade :: Version -> Annex ()
-checkUpgrade = maybe noop error <=< needsUpgrade
+checkUpgrade = maybe noop giveup <=< needsUpgrade
needsUpgrade :: Version -> Annex (Maybe String)
needsUpgrade v
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
#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.
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 ++ " )"
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
-- 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 ()
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
module Utility.Exception (
module X,
+ giveup,
catchBoolIO,
catchMaybeIO,
catchDefaultIO,
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
matchGlob
) where
+import Utility.Exception
+
import System.Path.WildMatch
import "regex-tdfa" Text.Regex.TDFA
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
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, ")"
]
=<< 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
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
import Utility.Env
import Utility.Data
+import Utility.Exception
import System.PosixCompat
import Control.Applicative
-
- 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"]
projects / git-annex.git / commitdiff