, Param $ fromRef name
, Param $ fromRef originname
]
- fromMaybe (error $ "failed to create " ++ fromRef name)
+ fromMaybe (giveup $ "failed to create " ++ fromRef name)
<$> branchsha
go False = withIndex' True $ do
-- Create the index file. This is not necessary,
(const a)
where
modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }
- modlocation _ = error "withWorkTree of non-local git repo"
+ modlocation _ = giveup "withWorkTree of non-local git repo"
{- Runs an action with the git index file and HEAD, and a few other
- files that are related to the work tree coming from an overlay
gochunked db c
-- Downloading cannot be done when chunked, since only
-- the first chunk is processed before returning.
- | importcontent = error "importKeys does not support downloading chunked import"
+ | importcontent = giveup "importKeys does not support downloading chunked import"
-- Chunked import is currently only used by thirdpartypopulated
-- remotes.
- | not thirdpartypopulated = error "importKeys does not support chunked import when not thirdpartypopulated"
+ | not thirdpartypopulated = giveup "importKeys does not support chunked import when not thirdpartypopulated"
| otherwise = do
l <- forM (importableContentsSubTree c) $ \(loc, i) -> do
let loc' = importableContentsChunkFullLocation (importableContentsSubDir c) loc
( unchanged
, do
let port = Git.Url.port remote
- let sshhost = either error id (mkSshHost host)
+ let sshhost = either giveup id (mkSshHost host)
(msockfile, cacheparams) <- sshCachingInfo (sshhost, port)
case msockfile of
Nothing -> use []
- Remote data. -}
disableRemote :: UUID -> Assistant Remote
disableRemote uuid = do
- remote <- fromMaybe (error "unknown remote")
+ remote <- fromMaybe (giveup "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
liftAnnex $ do
inRepo $ Git.Remote.Remove.remove (Remote.name remote)
Just keys
| null keys -> finishRemovingRemote urlrenderer uuid
| otherwise -> do
- r <- fromMaybe (error "unknown remote")
+ r <- fromMaybe (giveup "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
mapM_ (queueremaining r) keys
Nothing -> noop
addRemote a = do
name <- a
remotesChanged
- maybe (error "failed to add remote") return
+ maybe (giveup "failed to add remote") return
=<< Remote.byName (Just name)
{- Inits a rsync special remote, and returns its name. -}
enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype mcreds config =
Annex.SpecialRemote.findExisting name >>= \case
- [] -> error $ "Cannot find a special remote named " ++ name
+ [] -> giveup $ "Cannot find a special remote named " ++ name
((u, c, mcu):_) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
(transcript, ok) <-
processTranscript "git" (toCommand params) Nothing
unless ok $
- error $ "git init failed!\nOutput:\n" ++ transcript
+ giveup $ "git init failed!\nOutput:\n" ++ transcript
return True
)
where
- side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
- Left err -> error err
+ Left err -> giveup err
Right pubkey -> do
absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
- error "failed setting up ssh authorized keys"
+ giveup "failed setting up ssh authorized keys"
{- When local pairing is complete, this is used to set up the remote for
- the host we paired with. -}
{- user@host or host -}
genSshHost :: Text -> Maybe Text -> SshHost
-genSshHost host user = either error id $ mkSshHost $
+genSshHost host user = either giveup id $ mkSshHost $
maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
{- Generates a ssh or rsync url from a SshData. -}
, Param "-f", File $ dir </> "key"
]
unless ok $
- error "ssh-keygen failed"
+ giveup "ssh-keygen failed"
SshKeyPair
<$> readFile (dir </> "key.pub")
<*> readFile (dir </> "key")
{- Called when there's an error with inotify. -}
onErr :: Handler
-onErr = error
+onErr = giveup
{- Called when a new branch ref is written, or a branch ref is modified.
-
{- Called when there's an error with inotify. -}
onErr :: Handler
-onErr = error
+onErr = giveup
{- Called when a new transfer information file is written. -}
onAdd :: Handler
, Param "--directory", File tmpdir
]
unless tarok $
- error $ "failed to untar " ++ distributionfile
+ giveup $ "failed to untar " ++ distributionfile
sanitycheck $ tmpdir </> installBase
installby R.rename newdir (tmpdir </> installBase)
let deleteold = do
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
- error $ "did not find " ++ dir ++ " in " ++ distributionfile
+ giveup $ "did not find " ++ dir ++ " in " ++ distributionfile
makeorigsymlink olddir = do
let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
removeWhenExistsWith R.removeLink (toRawFilePath origdir)
{- Finds where the old version was installed. -}
oldVersionLocation :: IO FilePath
oldVersionLocation = readProgramFile >>= \case
- Nothing -> error "Cannot find old distribution bundle; not upgrading."
+ Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
Just pf -> do
let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
#ifdef darwin_HOST_OS
let olddir = pdir
#endif
when (null olddir) $
- error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
+ giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
return olddir
{- Finds a place to install the new version.
then redirect DeleteCurrentRepositoryR
else go =<< liftAnnex (Remote.remoteFromUUID uuid)
where
- go Nothing = error "Unknown UUID"
+ go Nothing = giveup "Unknown UUID"
go (Just _) = a
getDeleteRepositoryR :: UUID -> Handler Html
getStartDeleteRepositoryR :: UUID -> Handler Html
getStartDeleteRepositoryR uuid = do
- remote <- fromMaybe (error "unknown remote")
+ remote <- fromMaybe (giveup "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
liftAnnex $ do
trustSet uuid UnTrusted
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
when (mremote == Nothing) $
whenM ((/=) uuid <$> liftAnnex getUUID) $
- error "unknown remote"
+ giveup "unknown remote"
curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote
mrepo <- liftAnnex $
- background. -}
thread <- liftAssistant $ asIO $ do
keypair <- liftIO $ genSshKeyPair
- let pubkey = either error id $ validateSshPubKey $ sshPubKey keypair
+ let pubkey = either giveup id $ validateSshPubKey $ sshPubKey keypair
pairdata <- liftIO $ PairData
<$> getHostname
- <*> (either error id <$> myUserName)
+ <*> (either giveup id <$> myUserName)
<*> pure reldir
<*> pure pubkey
<*> (maybe genUUID return muuid)
addScript $ StaticR js_longpolling_js
$(widgetFile "page")
withUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
- Just msg -> error msg
+ Just msg -> giveup msg
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
| hashsize == 224 = mkHasher sha2_224 sha2_224_context
| hashsize == 384 = mkHasher sha2_384 sha2_384_context
| hashsize == 512 = mkHasher sha2_512 sha2_512_context
- | otherwise = error $ "unsupported SHA2 size " ++ show hashsize
+ | otherwise = giveup $ "unsupported SHA2 size " ++ show hashsize
sha3Hasher :: HashSize -> Hasher
sha3Hasher (HashSize hashsize)
| hashsize == 224 = mkHasher sha3_224 sha3_224_context
| hashsize == 384 = mkHasher sha3_384 sha3_384_context
| hashsize == 512 = mkHasher sha3_512 sha3_512_context
- | otherwise = error $ "unsupported SHA3 size " ++ show hashsize
+ | otherwise = giveup $ "unsupported SHA3 size " ++ show hashsize
skeinHasher :: HashSize -> Hasher
skeinHasher (HashSize hashsize)
| hashsize == 256 = mkHasher skein256 skein256_context
| hashsize == 512 = mkHasher skein512 skein512_context
- | otherwise = error $ "unsupported SKEIN size " ++ show hashsize
+ | otherwise = giveup $ "unsupported SKEIN size " ++ show hashsize
blake2bHasher :: HashSize -> Hasher
blake2bHasher (HashSize hashsize)
| hashsize == 160 = mkHasher blake2b_160 blake2b_160_context
| hashsize == 224 = mkHasher blake2b_224 blake2b_224_context
| hashsize == 384 = mkHasher blake2b_384 blake2b_384_context
- | otherwise = error $ "unsupported BLAKE2B size " ++ show hashsize
+ | otherwise = giveup $ "unsupported BLAKE2B size " ++ show hashsize
blake2bpHasher :: HashSize -> Hasher
blake2bpHasher (HashSize hashsize)
| hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_context
- | otherwise = error $ "unsupported BLAKE2BP size " ++ show hashsize
+ | otherwise = giveup $ "unsupported BLAKE2BP size " ++ show hashsize
blake2sHasher :: HashSize -> Hasher
blake2sHasher (HashSize hashsize)
| hashsize == 256 = mkHasher blake2s_256 blake2s_256_context
| hashsize == 160 = mkHasher blake2s_160 blake2s_160_context
| hashsize == 224 = mkHasher blake2s_224 blake2s_224_context
- | otherwise = error $ "unsupported BLAKE2S size " ++ show hashsize
+ | otherwise = giveup $ "unsupported BLAKE2S size " ++ show hashsize
blake2spHasher :: HashSize -> Hasher
blake2spHasher (HashSize hashsize)
| hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_context
| hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_context
- | otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize
+ | otherwise = giveup $ "unsupported BLAKE2SP size " ++ show hashsize
sha1Hasher :: Hasher
sha1Hasher = mkHasher sha1 sha1_context
"capabilities" -> putStrLn "connect" >> ready
"connect git-upload-pack" -> go UploadPack
"connect git-receive-pack" -> go ReceivePack
- l -> error $ "git-remote-helpers protocol error at " ++ show l
+ l -> giveup $ "git-remote-helpers protocol error at " ++ show l
where
(onionaddress, onionport)
| '/' `elem` address = parseAddressPort $
in keyaction lt (SeekInput [], k, bfp)
Nothing -> noop
unlessM (liftIO cleanup) $
- error ("git ls-tree " ++ Git.fromRef b ++ " failed")
+ giveup ("git ls-tree " ++ Git.fromRef b ++ " failed")
runfailedtransfers = do
keyaction <- mkkeyaction
pathmax <- liftIO $ fileNameLengthLimit "."
let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o))
go deffile =<< maybe
- (error $ "unable to checkUrl of " ++ Remote.name r)
+ (giveup $ "unable to checkUrl of " ++ Remote.name r)
(tryNonAsync . flip id u)
(Remote.checkUrl r)
where
let tmp' = toRawFilePath tmp
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
unlessM (checkedCopyFile key obj tmp' mode) $
- error "unable to break hard link"
+ giveup "unable to break hard link"
thawContent tmp'
Database.Keys.storeInodeCaches key [tmp']
modifyContentDir obj $ freezeContent obj
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
linkFromAnnex' key (toRawFilePath tmp) mode >>= \case
- LinkAnnexFailed -> error "unable to make hard link"
+ LinkAnnexFailed -> giveup "unable to make hard link"
_ -> noop
next $ return True
return (Just [])
else do
res <- tryNonAsync $ maybe
- (error $ "unable to checkUrl of " ++ Remote.name r)
+ (giveup $ "unable to checkUrl of " ++ Remote.name r)
(flip id url)
(Remote.checkUrl r)
case res of
go _ = Nothing
parseTimeStamp :: String -> POSIXTime
-parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (giveup "bad timestamp") .
parseTimeM True defaultTimeLocale "%s"
showTimeStamp :: TimeZone -> POSIXTime -> String
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
let tmp' = toRawFilePath tmp
unlessM (checkedCopyFile oldkey oldobj tmp' Nothing) $
- error "can't lock old key"
+ giveup "can't lock old key"
thawContent tmp'
ic <- withTSDelta (liftIO . genInodeCache file)
case v of
perform :: RawFilePath -> Key -> CommandPerform
perform src key = ifM move
( next $ cleanup key
- , error "failed"
+ , giveup "failed"
)
where
move = checkDiskSpaceToGet key False $
run :: DaemonOptions -> CommandSeek
run o
- | stopDaemonOption o = error "--stop not implemented for remotedaemon"
+ | stopDaemonOption o = giveup "--stop not implemented for remotedaemon"
| foregroundDaemonOption o = liftIO runInteractive
| otherwise = do
#ifndef mingw32_HOST_OS
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRawFilePath <$> fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
- them <- fromMaybe (error nomergehead) . extractSha
+ them <- fromMaybe (giveup nomergehead) . extractSha
<$> liftIO (S.readFile merge_head)
ifM (resolveMerge (Just us) them False)
( do
else return True
if ok
then next $ cleanup key
- else error "mv failed!"
+ else giveup "move failed!"
cleanup :: Key -> CommandCleanup
cleanup key = do
postingest (Just k, _) = do
logStatus k InfoPresent
return k
- postingest _ = error "could not add file to the annex"
+ postingest _ = giveup "could not add file to the annex"
cfg = LockDownConfig
{ lockingFile = False
-- Variant of a remote with exporttree disabled.
disableExportTree :: RemoteVariantCache -> Remote -> Annex Remote
-disableExportTree cache r = maybe (error "failed disabling exportree") return
+disableExportTree cache r = maybe (giveup "failed disabling exportree") return
=<< adjustRemoteConfig cache r (M.delete exportTreeField)
-- Variant of a remote with exporttree enabled.
go rest
go [] = noop
go [""] = noop
- go v = error $ "transferkeys protocol error: " ++ show v
+ go v = giveup $ "transferkeys protocol error: " ++ show v
readrequests = liftIO $ split fieldSep <$> hGetContents readh
sendresult b = liftIO $ do
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.Undo where
import Command
case r of
LinkAnnexOk -> return ()
LinkAnnexNoop -> return ()
- LinkAnnexFailed -> error "unlock failed"
+ LinkAnnexFailed -> giveup "unlock failed"
, liftIO $ writePointerFile (toRawFilePath tmp) key destmode
)
withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))
import Annex.UUID
import qualified Utility.Format
import qualified Command.Find
-import Types.ActionItem
import qualified Data.Map as M
import qualified Data.Vector as V
writeCacheCredPair credpair storage
return $ Just credpair
- _ -> error "bad creds"
+ _ -> giveup "bad creds"
getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
cipherPassphrase :: Cipher -> String
cipherPassphrase (Cipher c) = drop cipherBeginning c
-cipherPassphrase (MacOnlyCipher _) = error "MAC-only cipher"
+cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher"
cipherMac :: Cipher -> String
cipherMac (Cipher c) = take cipherBeginning c
]
]
#else
-benchmarkDbs _ = error "not built with criterion, cannot benchmark"
+benchmarkDbs _ = giveup "not built with criterion, cannot benchmark"
#endif
#ifdef WITH_BENCHMARK
Right r -> either throwIO return r
Left BlockedIndefinitelyOnMVar -> do
err <- takeMVar errvar
- error $ "sqlite worker thread crashed: " ++ err
+ giveup $ "sqlite worker thread crashed: " ++ err
{- Writes a change to the database.
-
repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
-repoLocation Repo { location = Unknown } = error "unknown repoLocation"
+repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"
{- Path to a repository. For non-bare, this is the worktree, for bare,
- it's the gitdir, and for URL repositories, is the path on the remote
repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
-repoPath Repo { location = Unknown } = error "unknown repoPath"
-repoPath Repo { location = UnparseableUrl _u } = error "unknown repoPath"
+repoPath Repo { location = Unknown } = giveup "unknown repoPath"
+repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"
repoWorkTree :: Repo -> Maybe RawFilePath
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> RawFilePath
localGitDir Repo { location = Local { gitdir = d } } = d
-localGitDir _ = error "unknown localGitDir"
+localGitDir _ = giveup "unknown localGitDir"
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
assertLocal :: Repo -> a -> a
assertLocal repo action
- | repoIsUrl repo = error $ unwords
+ | repoIsUrl repo = giveup $ unwords
[ "acting on non-local git repo"
, repoDescribe repo
, "not supported"
content <- readObjectContent from r
return $ Just (content, sha, objtype)
Just DNE -> return Nothing
- Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
+ Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object)
where
-- Slow fallback path for filenames containing newlines.
newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case
eatchar expected = do
c <- hGetChar h
when (c /= expected) $
- error $ "missing " ++ (show expected) ++ " from git cat-file"
+ giveup $ "missing " ++ (show expected) ++ " from git cat-file"
readObjectContent _ DNE = error "internal"
{- Gets the size and type of an object, without reading its content. -}
getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
["unspecified"] -> "" : getvals l xs
[v] -> v : getvals l xs
- _ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
+ _ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
send to = B.hPutStr to $ file' `B.snoc` 0
receive c from = do
fromAbsPath dir
| absoluteGitPath dir = fromPath dir
| otherwise =
- error $ "internal error, " ++ show dir ++ " is not absolute"
+ giveup $ "internal error, " ++ show dir ++ " is not absolute"
{- Construct a Repo for a remote's url.
-
go [] = []
go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of
A.Done _ r -> r : go rest
- A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err
- go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""
+ A.Fail _ _ err -> giveup $ "diff-tree parse error: " ++ err
+ go (s:[]) = giveup $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""
-- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
--
import Utility.PartialPrelude
import Utility.FileSystemEncoding
+import Utility.Exception
{- This is a variable length binary string, but its size is limited to
- maxPktLineLength. Its serialization includes a 4 byte hexadecimal
stringPktLine :: String -> PktLine
stringPktLine s
| length s > maxPktLineLength =
- error "textPktLine called with too-long value"
+ giveup "textPktLine called with too-long value"
| otherwise = PktLine (encodeBS s <> "\n")
{- Sends a PktLine to a Handle, and flushes it so that it will be
getSha :: String -> IO S.ByteString -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
where
- bad = error $ "failed to read sha from git " ++ subcommand
+ bad = giveup $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a ByteString.
-
getTree :: LsTree.LsTreeRecursive -> Ref -> Repo -> IO Tree
getTree recursive r repo = do
(l, cleanup) <- lsTreeWithObjects recursive r repo
- let !t = either (\e -> error ("ls-tree parse error:" ++ e)) id
+ let !t = either (\e -> giveup ("ls-tree parse error:" ++ e)) id
(extractTree l)
void cleanup
return t
Just (TreeItem f m s) ->
let commit = TreeCommit f m s
in go h wasmodified (commit:c) depth intree is
- _ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
+ _ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
| otherwise = return (c, wasmodified, i:is)
adjustlist h depth ishere underhere l = do
go [] = noop
go (info:file:rest) = mergeFile info file hashhandle ch >>=
maybe (go rest) (\l -> streamer l >> go rest)
- go (_:[]) = error $ "parse error " ++ show differ
+ go (_:[]) = giveup $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
{- Adds a new syntax token. -}
addSyntaxToken :: String -> Annex ()
-addSyntaxToken = either error add . Utility.Matcher.syntaxToken
+addSyntaxToken = either giveup add . Utility.Matcher.syntaxToken
{- Adds a new limit. -}
addLimit :: Either String (MatchFiles Annex) -> Annex ()
waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO ()
waitOutputSerializedResponse getr r = tryIO getr >>= \case
Right (Just r') | r' == r -> return ()
- v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
+ v -> giveup $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
-- known. Force content
-- verification.
return (rightsize, MustVerify)
- Left e -> error $ describeProtoFailure e
+ Left e -> giveup $ describeProtoFailure e
sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go
where
, enumerate = list
, generate = gen
, configParser = mkRemoteConfigParser []
- , setup = error "not supported"
+ , setup = giveup "not supported"
, exportSupported = exportUnsupported
, importSupported = importUnsupported
, thirdPartyPopulated = False
{- Convert remote DdarRepo to host and path on remote end -}
splitRemoteDdarRepo :: DdarRepo -> (SshHost, String)
-splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo')
+splitRemoteDdarRepo ddarrepo = (either giveup id $ mkSshHost host, ddarrepo')
where
(host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo)
ddarrepo' = drop 1 remainder
directoryExists <- ddarDirectoryExists ddarrepo
case directoryExists of
Left e -> error e
- Right True -> either error return
+ Right True -> either giveup return
=<< inDdarManifest ddarrepo key
Right False -> return False
let rsyncpath = if "/~/" `isPrefixOf` path
then drop 3 path
else path
- sshhost = either error id (mkSshHost host)
+ sshhost = either giveup id (mkSshHost host)
mkopts = rsyncShell . (Param "ssh" :)
<$> sshOptions ConsumeStdin (sshhost, Nothing) gc []
in (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessGitAnnexShell)
]
(r:_)
| Git.repoLocation r == url -> noop
- | otherwise -> error "Another remote with the same name already exists."
+ | otherwise -> giveup "Another remote with the same name already exists."
pc <- either giveup return . parseRemoteConfig c'
=<< configParser remote c'
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
liftIO (catchMaybeIO $ Git.Config.read r)
| not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>)
- [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ error "configlist failed")) "configlist" [] []
+ [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ giveup "configlist failed")) "configlist" [] []
, getConfigViaRsync r gc
]
| otherwise = return (Nothing, r)
fromB64bs :: String -> String
fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)
where
- bad = error "bad base64 encoded data"
+ bad = giveup "bad base64 encoded data"
toRepo cs r gc remotecmd = do
let host = maybe
(giveup "bad ssh url")
- (either error id . mkSshHost)
+ (either giveup id . mkSshHost)
(Git.Url.hostuser r)
sshCommand cs (host, Git.Url.port r) gc remotecmd
httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
httpAlsoSetup _ Nothing _ _ _ =
- error "Must use --sameas when initializing a httpalso remote."
+ giveup "Must use --sameas when initializing a httpalso remote."
httpAlsoSetup _ (Just u) _ c gc = do
_url <- maybe (giveup "Specify url=")
(return . fromProposedAccepted)
, enumerate = const (return [])
, generate = \_ _ _ _ _ -> return Nothing
, configParser = mkRemoteConfigParser []
- , setup = error "P2P remotes are set up using git-annex p2p"
+ , setup = giveup "P2P remotes are set up using git-annex p2p"
, exportSupported = exportUnsupported
, importSupported = importUnsupported
, thirdPartyPopulated = False
case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
"ssh":sshopts -> do
let (port, sshopts') = sshReadPort sshopts
- userhost = either error id $ mkSshHost $
+ userhost = either giveup id $ mkSshHost $
takeWhile (/= ':') url
return $ (Param "ssh":) <$> sshOptions ConsumeStdin
(userhost, port) gc
user = toDavUser u
pass = toDavPass p
-testDav _ Nothing = error "Need to configure webdav username and password."
+testDav _ Nothing = giveup "Need to configure webdav username and password."
{- Tries to make all the parent directories in the WebDAV urls's path,
- right down to the root.
choke f = do
x <- f
case x of
- Left e -> error e
+ Left e -> giveup e
Right r -> return r
data DavHandle = DavHandle DAVContext DavUser DavPass URLString
inLocation l $
snd <$> getContentM
where
- onerr = error "download failed"
+ onerr = giveup "download failed"
checkKeyLegacyChunked :: DavHandle -> CheckPresent
checkKeyLegacyChunked dav k = liftIO $
- either error id <$> withStoredFilesLegacyChunked k dav onerr check
+ either giveup id <$> withStoredFilesLegacyChunked k dav onerr check
where
check [] = return $ Right True
check (l:ls) = do
let reader = forever $ do
l <- hGetLine readh
case parseMessage l of
- Nothing -> error $ "protocol error: " ++ l
+ Nothing -> giveup $ "protocol error: " ++ l
Just cmd -> atomically $ writeTChan ichan cmd
let writer = forever $ do
msg <- atomically $ readTChan ochan
innewrepo $ do
git_annex "init" [reponame, "--quiet"] "init"
setupremote remotename
- r <- annexeval $ either error return
+ r <- annexeval $ either giveup return
=<< Remote.byName' remotename
cache <- Command.TestRemote.newRemoteVariantCache
unavailr <- annexeval $ Types.Remote.mkUnavailable r
import qualified Utility.SimpleProtocol as Proto
import Utility.Hash
+import Utility.Exception
import Data.SecureMem
import Data.Maybe
g <- newGenIO :: IO SystemRandom
return $
case genBytes 512 g of
- Left e -> error $ "failed to generate auth token: " ++ show e
- Right (s, _) -> fromMaybe (error "auth token encoding failed") $
+ Left e -> giveup $ "failed to generate auth token: " ++ show e
+ Right (s, _) -> fromMaybe (giveup "auth token encoding failed") $
toAuthToken $ T.pack $ take len $
show $ sha2_512 $ L.fromChunks [s]
import Utility.FileSystemEncoding
import Utility.QuickCheck
+import Utility.Exception
import qualified "sandi" Codec.Binary.Base64 as B64
import Data.Maybe
fromB64 :: String -> String
fromB64 = fromMaybe bad . fromB64Maybe
where
- bad = error "bad base64 encoded data"
+ bad = giveup "bad base64 encoded data"
fromB64' :: B.ByteString -> B.ByteString
fromB64' = fromMaybe bad . fromB64Maybe'
where
- bad = error "bad base64 encoded data"
+ bad = giveup "bad base64 encoded data"
-- Only ascii strings are tested, because an arbitrary string may contain
-- characters not encoded using the FileSystemEncoding, which would thus
import GHC.IO.Exception (IOErrorType(..))
import Utility.Data
+import Utility.SafeOutput
{- 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 expected to see in some
- - circumstances. -}
+ - circumstances.
+ -
+ - Also, control characters are filtered out of the message.
+ -}
giveup :: [Char] -> a
-giveup = errorWithoutStackTrace
+giveup = errorWithoutStackTrace . safeOutput
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
splitnull = splitc '\0'
- parsefail = error $ "failed to parse lsof output: " ++ show s
+ parsefail = giveup $ "failed to parse lsof output: " ++ show s
--- /dev/null
+{- Safe output to the terminal of possibly attacker-controlled strings,
+ - avoiding displaying control characters.
+ -
+ - Copyright 2023 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.SafeOutput (safeOutput) where
+
+import Data.Char
+import qualified Data.ByteString as S
+
+class SafeOutputtable t where
+ safeOutput :: t -> t
+
+instance SafeOutputtable String where
+ safeOutput = filter (not . isControl)
+
+instance SafeOutputtable S.ByteString where
+ safeOutput = S.filter (not . isControl . chr . fromIntegral)
-- getAddrInfo didn't used to work on windows; current status
-- unknown.
when (isJust h) $
- error "getSocket with HostName not supported on this OS"
+ giveup "getSocket with HostName not supported on this OS"
let addr = tupleToHostAddress (127,0,0,1)
sock <- socket AF_INET Stream defaultProtocol
preparesocket sock
case (partition (\a -> addrFamily a == AF_INET) addrs) of
(v4addr:_, _) -> go v4addr
(_, v6addr:_) -> go v6addr
- _ -> error "unable to bind to a local socket"
+ _ -> giveup "unable to bind to a local socket"
where
hostname = fromMaybe localhost h
localhost = "localhost"
- unknown reason on OSX. -}
go addr = go' 100 addr
go' :: Int -> AddrInfo -> IO Socket
- go' 0 _ = error "unable to bind to local socket"
+ go' 0 _ = giveup "unable to bind to local socket"
go' n addr = do
r <- tryIO $ bracketOnError (open addr) close (useaddr addr)
either (const $ go' (pred n) addr) return r
webAppSessionBackend _ = do
g <- newGenIO :: IO SystemRandom
case genBytes 96 g of
- Left e -> error $ "failed to generate random key: " ++ show e
+ Left e -> giveup $ "failed to generate random key: " ++ show e
Right (s, _) -> case CS.initKey s of
- Left e -> error $ "failed to initialize key: " ++ show e
+ Left e -> giveup $ "failed to initialize key: " ++ show e
Right key -> use key
where
timeout = 120 * 60 -- 120 minutes
> Update: Most git-annex commands now quote filenames, due to work on
> ActionItem display. `git-annex find`, `git-annex info $file`,
> and everywhere filenames get
-> embedded in error messages, warnings, info messages, still need to be done.
+> embedded in warnings, info messages, still need to be done.
----
Also: git-annex initremote with autoenable may be able to cause a remote
with a malicious name to be set up?
+
+Also: Any place that an exception is thrown with an attacker-controlled value.
+`giveup` has been made to filter out control characters, but that leave
+other exceptions, including ones thrown by libraries. Catch all exceptions
+at top-level (of program and/or worker threads) and filter out control
+characters?
Utility.ResourcePool
Utility.Rsync
Utility.SafeCommand
+ Utility.SafeOutput
Utility.Scheduled
Utility.Scheduled.QuickCheck
Utility.Shell
projects / git-annex.git / commitdiff