From cd544e548b91fe7a940a2221414e3df6f9ca80f9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Apr 2023 13:38:14 -0400 Subject: [PATCH] filter out control characters in error messages giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon --- Annex/Branch.hs | 2 +- Annex/GitOverlay.hs | 2 +- Annex/Import.hs | 4 ++-- Annex/Ssh.hs | 2 +- Assistant/DeleteRemote.hs | 4 ++-- Assistant/MakeRemote.hs | 4 ++-- Assistant/MakeRepo.hs | 2 +- Assistant/Pairing/MakeRemote.hs | 4 ++-- Assistant/Ssh.hs | 4 ++-- Assistant/Threads/Merger.hs | 2 +- Assistant/Threads/TransferWatcher.hs | 2 +- Assistant/Upgrade.hs | 8 +++---- Assistant/WebApp/Configurators/Delete.hs | 4 ++-- Assistant/WebApp/Configurators/Edit.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 4 ++-- Assistant/WebApp/Page.hs | 2 +- Backend/Hash.hs | 14 ++++++------ CmdLine/GitRemoteTorAnnex.hs | 2 +- CmdLine/Seek.hs | 2 +- Command/AddUrl.hs | 2 +- Command/Fix.hs | 4 ++-- Command/ImportFeed.hs | 2 +- Command/Log.hs | 2 +- Command/ReKey.hs | 2 +- Command/Reinject.hs | 2 +- Command/RemoteDaemon.hs | 2 +- Command/ResolveMerge.hs | 2 +- Command/SetKey.hs | 2 +- Command/Smudge.hs | 2 +- Command/TestRemote.hs | 2 +- Command/TransferKeys.hs | 2 +- Command/Undo.hs | 2 ++ Command/Unlock.hs | 2 +- Command/Whereis.hs | 1 - Creds.hs | 2 +- Crypto.hs | 2 +- Database/Benchmark.hs | 2 +- Database/Handle.hs | 2 +- Git.hs | 10 ++++----- Git/CatFile.hs | 4 ++-- Git/CheckAttr.hs | 2 +- Git/Construct.hs | 2 +- Git/DiffTree.hs | 4 ++-- Git/PktLine.hs | 3 ++- Git/Sha.hs | 2 +- Git/Tree.hs | 4 ++-- Git/UnionMerge.hs | 2 +- Limit.hs | 2 +- Messages/Internal.hs | 2 +- P2P/Annex.hs | 2 +- Remote/BitTorrent.hs | 2 +- Remote/Ddar.hs | 4 ++-- Remote/GCrypt.hs | 6 +++--- Remote/Helper/Encryptable.hs | 2 +- Remote/Helper/Ssh.hs | 2 +- Remote/HttpAlso.hs | 2 +- Remote/P2P.hs | 2 +- Remote/Rsync.hs | 2 +- Remote/WebDAV.hs | 8 +++---- RemoteDaemon/Core.hs | 2 +- Test.hs | 2 +- Utility/AuthToken.hs | 5 +++-- Utility/Base64.hs | 5 +++-- Utility/Exception.hs | 8 +++++-- Utility/Lsof.hs | 2 +- Utility/SafeOutput.hs | 24 +++++++++++++++++++++ Utility/WebApp.hs | 10 ++++----- doc/todo/terminal_escapes_in_filenames.mdwn | 8 ++++++- git-annex.cabal | 1 + 69 files changed, 142 insertions(+), 103 deletions(-) create mode 100644 Utility/SafeOutput.hs diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 37bf6e3a6b..d3caf08169 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -130,7 +130,7 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha , 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, diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs index 568fd28814..5388c1bfc6 100644 --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -73,7 +73,7 @@ withWorkTree d a = withAltRepo (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 diff --git a/Annex/Import.hs b/Annex/Import.hs index 52c0aa1581..68c8aa8281 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -458,10 +458,10 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec 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 diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 2e45198fe5..17124cdfb2 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -432,7 +432,7 @@ sshOptionsTo remote gc localr ( 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 [] diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs index 07de5744af..fa788f086f 100644 --- a/Assistant/DeleteRemote.hs +++ b/Assistant/DeleteRemote.hs @@ -31,7 +31,7 @@ import qualified Data.Text as T - 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) @@ -57,7 +57,7 @@ removableRemote urlrenderer uuid = getkeys >>= \case 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 diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 46daa33a04..3d3c178f65 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -47,7 +47,7 @@ addRemote :: Annex RemoteName -> Annex Remote 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. -} @@ -94,7 +94,7 @@ initSpecialRemote name remotetype mcreds config = go 0 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 diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs index e87701f32b..ca3be78a5f 100644 --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -34,7 +34,7 @@ makeRepo path bare = ifM (probeRepoExists path) (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 diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index cea2b635b7..69402e2e3d 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -24,11 +24,11 @@ import qualified Data.Text as T - 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. -} diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index c392d54eb8..3f472a5332 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -68,7 +68,7 @@ sshOpt k v = concat ["-o", k, "=", v] {- 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. -} @@ -218,7 +218,7 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do , Param "-f", File $ dir "key" ] unless ok $ - error "ssh-keygen failed" + giveup "ssh-keygen failed" SshKeyPair <$> readFile (dir "key.pub") <*> readFile (dir "key") diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 01f7200801..ab4a9e4720 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -58,7 +58,7 @@ runHandler handler file _filestatus = {- 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. - diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 4c80239d2b..d692a3ffd0 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -53,7 +53,7 @@ runHandler handler file _filestatus = {- 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 diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 5b8a49ebf6..419c133a62 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -205,7 +205,7 @@ upgradeToDistribution newdir cleanup distributionfile = do , 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 @@ -218,7 +218,7 @@ upgradeToDistribution newdir cleanup distributionfile = 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) @@ -227,7 +227,7 @@ upgradeToDistribution newdir cleanup distributionfile = do {- 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 @@ -240,7 +240,7 @@ oldVersionLocation = readProgramFile >>= \case 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. diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 42d904f022..333e13656a 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -34,7 +34,7 @@ notCurrentRepo uuid a = do 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 @@ -45,7 +45,7 @@ getDeleteRepositoryR uuid = notCurrentRepo uuid $ do 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 diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 3e09818936..65da2d588e 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -203,7 +203,7 @@ editForm new (RepoUUID uuid) 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 $ diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 1f01fa9be6..ceff21a3bf 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -216,10 +216,10 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do - 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) diff --git a/Assistant/WebApp/Page.hs b/Assistant/WebApp/Page.hs index 07a33ea7fe..ee7491a688 100644 --- a/Assistant/WebApp/Page.hs +++ b/Assistant/WebApp/Page.hs @@ -67,7 +67,7 @@ customPage' with_longpolling navbaritem content = do 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) diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 6166d04e07..78ece71292 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -229,7 +229,7 @@ sha2Hasher (HashSize hashsize) | 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) @@ -237,13 +237,13 @@ 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) @@ -252,25 +252,25 @@ 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 diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index d937b652c7..3349304fb2 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -25,7 +25,7 @@ run (_remotename:address:[]) = forever $ "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 $ diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index ab557d42ab..b3bb8c3a86 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -313,7 +313,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do 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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 61e7c7de98..a76c54a200 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -148,7 +148,7 @@ checkUrl addunlockedmatcher r o si u = do 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 diff --git a/Command/Fix.hs b/Command/Fix.hs index 83f0515f01..3cfa0d8f39 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -76,7 +76,7 @@ breakHardLink file key obj = do 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 @@ -87,7 +87,7 @@ makeHardLink file key = do 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 diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 2146dadc5f..fcddae4a4d 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -232,7 +232,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio 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 diff --git a/Command/Log.hs b/Command/Log.hs index 2520311ea0..2dcac21cc9 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -281,7 +281,7 @@ parseRawChangeLine = go . words 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 diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 76204609f5..906d4b5dff 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -113,7 +113,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) 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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 2d3854242c..363c44b20c 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -103,7 +103,7 @@ notAnnexed src a = perform :: RawFilePath -> Key -> CommandPerform perform src key = ifM move ( next $ cleanup key - , error "failed" + , giveup "failed" ) where move = checkDiskSpaceToGet key False $ diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 728b16da6d..114c0afcee 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -24,7 +24,7 @@ cmd = noCommit $ 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 diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index 4c0e8b61d5..aaa5c25ad2 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -28,7 +28,7 @@ start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do 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 diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 882bf3e0f3..263278189f 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -44,7 +44,7 @@ perform file key = do else return True if ok then next $ cleanup key - else error "mv failed!" + else giveup "move failed!" cleanup :: Key -> CommandCleanup cleanup key = do diff --git a/Command/Smudge.hs b/Command/Smudge.hs index a5d8871998..ae0b46a33a 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -191,7 +191,7 @@ clean' file mk passthrough discardreststdin emitpointer = 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 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index d9f5931c2d..32f48ab5be 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -152,7 +152,7 @@ encryptionVariants cache dr = [noenc, sharedenc] -- 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. diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 699febbfaa..078f905eee 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -83,7 +83,7 @@ runRequests readh writeh a = do 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 diff --git a/Command/Undo.hs b/Command/Undo.hs index 4f6f42f525..c56606c20d 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.Undo where import Command diff --git a/Command/Unlock.hs b/Command/Unlock.hs index b165025b43..d338c00dcd 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -58,7 +58,7 @@ perform dest key = do 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)) diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 4fe9a0cf16..c6ddc88072 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -17,7 +17,6 @@ import Remote.Web (getWebUrls) 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 diff --git a/Creds.hs b/Creds.hs index 78d38d6648..95124f160d 100644 --- a/Creds.hs +++ b/Creds.hs @@ -150,7 +150,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv 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 diff --git a/Crypto.hs b/Crypto.hs index 41d4789d7f..7f134a3cbc 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -73,7 +73,7 @@ cipherSize = 512 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 diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs index 613a30e508..81f3531891 100644 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -44,7 +44,7 @@ benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do ] ] #else -benchmarkDbs _ = error "not built with criterion, cannot benchmark" +benchmarkDbs _ = giveup "not built with criterion, cannot benchmark" #endif #ifdef WITH_BENCHMARK diff --git a/Database/Handle.hs b/Database/Handle.hs index da7a0e173a..5aea7a75b7 100644 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -84,7 +84,7 @@ queryDb (DbHandle _db _ jobs errvar) a = do 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. - diff --git a/Git.hs b/Git.hs index 5e0b6980b2..e567917ea1 100644 --- a/Git.hs +++ b/Git.hs @@ -68,7 +68,7 @@ repoLocation Repo { location = UnparseableUrl url } = url 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 @@ -78,8 +78,8 @@ repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u 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 @@ -88,7 +88,7 @@ repoWorkTree _ = Nothing {- 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. -} @@ -129,7 +129,7 @@ repoIsLocalUnknown _ = False 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" diff --git a/Git/CatFile.hs b/Git/CatFile.hs index f33ad493b7..daa41ad083 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -120,7 +120,7 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f 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 @@ -144,7 +144,7 @@ readObjectContent h (ParsedResp _ _ size) = do 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. -} diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index e4a7ea9d40..f93c9075cf 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -54,7 +54,7 @@ checkAttrs (h, attrs, currdir) want file = do 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 diff --git a/Git/Construct.hs b/Git/Construct.hs index a64a9d5566..82929d9076 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -86,7 +86,7 @@ fromAbsPath :: RawFilePath -> IO Repo 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. - diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index d57ca385c0..3be5cb980a 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -113,8 +113,8 @@ parseDiffRaw l = go l 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 ++ "\"" -- : SP SP SP SP -- diff --git a/Git/PktLine.hs b/Git/PktLine.hs index a49cfc2b63..95e8af26be 100644 --- a/Git/PktLine.hs +++ b/Git/PktLine.hs @@ -31,6 +31,7 @@ import Text.Printf 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 @@ -96,7 +97,7 @@ encodePktLine b 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 diff --git a/Git/Sha.hs b/Git/Sha.hs index a66c34ee2c..389bcc01a3 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -20,7 +20,7 @@ import Data.Char 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. - diff --git a/Git/Tree.hs b/Git/Tree.hs index 48ed126cfe..8c034be4cd 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -62,7 +62,7 @@ data TreeContent 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 @@ -254,7 +254,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo = 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 diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index ffa5773975..9f738da844 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -78,7 +78,7 @@ doMerge hashhandle ch differ repo streamer = 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 diff --git a/Limit.hs b/Limit.hs index 19a71185e3..f9e91b3aaa 100644 --- a/Limit.hs +++ b/Limit.hs @@ -87,7 +87,7 @@ add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } {- 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 () diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 30cbafc1b0..e88acf041c 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -105,4 +105,4 @@ outputSerialized = id 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 diff --git a/P2P/Annex.hs b/P2P/Annex.hs index 08177bec6e..a3e48085ca 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -225,7 +225,7 @@ runLocal runst runner a = case a of -- 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 diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 39c7786762..a237539904 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -47,7 +47,7 @@ remote = RemoteType , enumerate = list , generate = gen , configParser = mkRemoteConfigParser [] - , setup = error "not supported" + , setup = giveup "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported , thirdPartyPopulated = False diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 75d93e6a18..3fc3fdbafb 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -139,7 +139,7 @@ store ddarrepo = fileStorer $ \k src _p -> do {- 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 @@ -228,7 +228,7 @@ checkKey ddarrepo key = do 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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 57e675e43f..1ab9461e6f 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -197,7 +197,7 @@ rsyncTransport r gc 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) @@ -239,7 +239,7 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c ] (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' @@ -505,7 +505,7 @@ getGCryptId fast r gc | 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) diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 29841b727f..f9625a5623 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -331,4 +331,4 @@ toB64bs = w82s . B.unpack . B64.encode . B.pack . s2w8 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" diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index c71a67ac64..9bd4990650 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -32,7 +32,7 @@ toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (Fi 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 diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs index e77fb9a498..6402867d32 100644 --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -103,7 +103,7 @@ cannotModify = giveup "httpalso special remote is read only" 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) diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 3ab66b5634..959ecbbf58 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -38,7 +38,7 @@ remote = RemoteType , 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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 2fcb965a29..8b14c0b25c 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -179,7 +179,7 @@ rsyncTransport gc url 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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 518e14bfd1..e9e771d754 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -321,7 +321,7 @@ testDav url (Just (u, p)) = do 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. @@ -407,7 +407,7 @@ choke :: IO (Either String a) -> IO a 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 @@ -491,11 +491,11 @@ retrieveLegacyChunked d k p dav = liftIO $ 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 diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index ce29f7f7cc..4ca248e315 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -40,7 +40,7 @@ runInteractive = 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 diff --git a/Test.hs b/Test.hs index b8f4adfc1e..237eba82b9 100644 --- a/Test.hs +++ b/Test.hs @@ -239,7 +239,7 @@ testRemote testvariants remotetype setupremote = 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 diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs index f5e2bfdcbc..116e361bbe 100644 --- a/Utility/AuthToken.hs +++ b/Utility/AuthToken.hs @@ -20,6 +20,7 @@ module Utility.AuthToken ( import qualified Utility.SimpleProtocol as Proto import Utility.Hash +import Utility.Exception import Data.SecureMem import Data.Maybe @@ -79,8 +80,8 @@ genAuthToken len = do 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] diff --git a/Utility/Base64.hs b/Utility/Base64.hs index fec056e3bc..32d9066823 100644 --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -11,6 +11,7 @@ module Utility.Base64 where import Utility.FileSystemEncoding import Utility.QuickCheck +import Utility.Exception import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe @@ -36,12 +37,12 @@ fromB64Maybe' = either (const Nothing) Just . B64.decode 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 diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 4c60eac597..3d1a69912a 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -36,13 +36,17 @@ import System.IO.Error (isDoesNotExistError, ioeGetErrorType) 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 diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 5803dcd7f3..e8569ee023 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -110,4 +110,4 @@ parse s = bundle $ go [] $ lines s splitnull = splitc '\0' - parsefail = error $ "failed to parse lsof output: " ++ show s + parsefail = giveup $ "failed to parse lsof output: " ++ show s diff --git a/Utility/SafeOutput.hs b/Utility/SafeOutput.hs new file mode 100644 index 0000000000..0ca2d87549 --- /dev/null +++ b/Utility/SafeOutput.hs @@ -0,0 +1,24 @@ +{- Safe output to the terminal of possibly attacker-controlled strings, + - avoiding displaying control characters. + - + - Copyright 2023 Joey Hess + - + - 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) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 81bd2d97be..497c2eb1ba 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -87,7 +87,7 @@ getSocket h = do -- 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 @@ -99,7 +99,7 @@ getSocket h = do 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" @@ -108,7 +108,7 @@ getSocket h = do - 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 @@ -129,9 +129,9 @@ webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend) 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 diff --git a/doc/todo/terminal_escapes_in_filenames.mdwn b/doc/todo/terminal_escapes_in_filenames.mdwn index 9d1aa02785..575bcbfd78 100644 --- a/doc/todo/terminal_escapes_in_filenames.mdwn +++ b/doc/todo/terminal_escapes_in_filenames.mdwn @@ -36,7 +36,7 @@ behave more like git. > 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. ---- @@ -59,3 +59,9 @@ out control characters. If such an url even can be parsed? 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? diff --git a/git-annex.cabal b/git-annex.cabal index 160a6c59e9..f249e95af1 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1133,6 +1133,7 @@ Executable git-annex Utility.ResourcePool Utility.Rsync Utility.SafeCommand + Utility.SafeOutput Utility.Scheduled Utility.Scheduled.QuickCheck Utility.Shell -- 2.30.2