From fc845e6530b62c9647e76e0855b7d4819e7a0005 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 5 Dec 2017 15:00:50 -0400 Subject: [PATCH] more lambda-case conversion --- Annex/Link.hs | 7 +++--- Annex/NumCopies.hs | 15 +++++-------- Annex/Perms.hs | 5 ++--- Annex/SpecialRemote.hs | 3 +-- Annex/Ssh.hs | 11 ++++----- Annex/Transfer.hs | 26 +++++++++------------ Annex/Url.hs | 8 +++---- Annex/WorkTree.hs | 23 +++++++++---------- Annex/YoutubeDl.hs | 24 +++++++++----------- Assistant/MakeRemote.hs | 8 +++---- Assistant/NamedThread.hs | 37 ++++++++++++++---------------- Backend.hs | 3 +-- Backend/Hash.hs | 5 ++--- CmdLine/Action.hs | 12 +++++----- CmdLine/GitAnnexShell/Checks.hs | 10 ++++----- CmdLine/GitRemoteTorAnnex.hs | 16 +++++-------- CmdLine/Seek.hs | 3 +-- Command.hs | 3 +-- Command/Add.hs | 40 ++++++++++++++------------------- Command/AddUrl.hs | 8 +++---- Command/CalcKey.hs | 12 +++++----- Command/CheckPresentKey.hs | 10 ++++----- Command/Config.hs | 5 ++--- Command/Dead.hs | 3 +-- Command/Direct.hs | 6 ++--- Command/EnableRemote.hs | 6 ++--- Command/EnableTor.hs | 3 +-- Command/Fix.hs | 3 +-- Command/Fsck.hs | 21 ++++++++--------- 29 files changed, 137 insertions(+), 199 deletions(-) diff --git a/Annex/Link.hs b/Annex/Link.hs index fcc300beec..e083cfe8c0 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -55,11 +55,10 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks check probefilecontent $ return Nothing where - check getlinktarget fallback = do - v <- liftIO $ catchMaybeIO $ getlinktarget file - case v of + check getlinktarget fallback = + liftIO (catchMaybeIO $ getlinktarget file) >>= \case Just l - | isLinkToAnnex (fromInternalGitPath l) -> return v + | isLinkToAnnex (fromInternalGitPath l) -> return (Just l) | otherwise -> return Nothing Nothing -> fallback diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 5e818fe957..9fea49db65 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -121,24 +121,21 @@ verifyEnoughCopiesToDrop verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = helper [] [] preverified (nub tocheck) where - helper bad missing have [] = do - p <- liftIO $ mkSafeDropProof need have removallock - case p of + helper bad missing have [] = + liftIO (mkSafeDropProof need have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> do notEnoughCopies key need stillhave (skip++missing) bad nolocmsg nodropaction helper bad missing have (c:cs) - | isSafeDrop need have removallock = do - p <- liftIO $ mkSafeDropProof need have removallock - case p of + | isSafeDrop need have removallock = + liftIO (mkSafeDropProof need have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> helper bad missing stillhave (c:cs) | otherwise = case c of UnVerifiedHere -> lockContentShared key contverified - UnVerifiedRemote r -> checkremote r contverified $ do - haskey <- Remote.hasKey r key - case haskey of + UnVerifiedRemote r -> checkremote r contverified $ + Remote.hasKey r key >>= \case Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs Left _ -> helper (r:bad) missing have cs Right False -> helper bad (Remote.uuid r:missing) have cs diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 1ce3429116..93919af86e 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -111,9 +111,8 @@ isContentWritePermOk file = ifM crippledFileSystem go GroupShared = want [ownerWriteMode, groupWriteMode] go AllShared = want writeModes go _ = return True - want wantmode = do - mmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - return $ case mmode of + want wantmode = + liftIO (catchMaybeIO $ fileMode <$> getFileStatus file) >>= return . \case Nothing -> True Just havemode -> havemode == combineModes (havemode:wantmode) diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index c215208db2..23b0f582fd 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -81,8 +81,7 @@ autoEnable = do (Just name, Right t) -> whenM (canenable u) $ do showSideAction $ "Auto enabling special remote " ++ name dummycfg <- liftIO dummyRemoteGitConfig - res <- tryNonAsync $ setup t (Enable c) (Just u) Nothing c dummycfg - case res of + tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case Left e -> warning (show e) Right _ -> return () _ -> return () diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index c3f46b4c13..e3d2c3d8b8 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -101,9 +101,8 @@ sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandPar sshCachingInfo (host, port) = go =<< sshCacheDir where go Nothing = return (Nothing, []) - go (Just dir) = do - r <- liftIO $ bestSocketPath $ dir hostport2socket host port - return $ case r of + go (Just dir) = + liftIO (bestSocketPath $ dir hostport2socket host port) >>= return . \case Nothing -> (Nothing, []) Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile) @@ -190,8 +189,7 @@ prepSocket socketfile gc sshhost sshparams = do liftIO $ createDirectoryIfMissing True $ parentDir socketfile let socketlock = socket2lock socketfile - c <- Annex.getState Annex.concurrency - case c of + Annex.getState Annex.concurrency >>= \case Concurrent {} | annexUUID (remoteGitConfig gc) /= NoUUID -> makeconnection socketlock @@ -267,8 +265,7 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles let lockfile = socket2lock socketfile unlockFile lockfile mode <- annexFileMode - v <- noUmask mode $ tryLockExclusive (Just mode) lockfile - case v of + noUmask mode (tryLockExclusive (Just mode) lockfile) >>= \case Nothing -> noop Just lck -> do forceStopSsh socketfile diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index ccb5409a7b..ad617a7df3 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -92,8 +92,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t prep tfile mode info = catchPermissionDenied (const prepfailed) $ do let lck = transferLockFile tfile createAnnexDirectory $ takeDirectory lck - r <- tryLockExclusive (Just mode) lck - case r of + tryLockExclusive (Just mode) lck >>= \case Nothing -> return (Nothing, True) Just lockhandle -> ifM (checkSaneLock lck lockhandle) ( do @@ -108,8 +107,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t prep tfile _mode info = catchPermissionDenied (const prepfailed) $ do let lck = transferLockFile tfile createAnnexDirectory $ takeDirectory lck - v <- catchMaybeIO $ liftIO $ lockExclusive lck - case v of + catchMaybeIO (liftIO $ lockExclusive lck) >>= \case Nothing -> return (Nothing, False) Just Nothing -> return (Nothing, True) Just (Just lockhandle) -> do @@ -135,17 +133,15 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t dropLock lockhandle void $ tryIO $ removeFile lck #endif - retry oldinfo metervar run = do - v <- tryNonAsync run - case v of - Right b -> return b - Left e -> do - warning (show e) - b <- getbytescomplete metervar - let newinfo = oldinfo { bytesComplete = Just b } - if shouldretry oldinfo newinfo - then retry newinfo metervar run - else return observeFailure + retry oldinfo metervar run = tryNonAsync run >>= \case + Right b -> return b + Left e -> do + warning (show e) + b <- getbytescomplete metervar + let newinfo = oldinfo { bytesComplete = Just b } + if shouldretry oldinfo newinfo + then retry newinfo metervar run + else return observeFailure getbytescomplete metervar | transferDirection t == Upload = liftIO $ readMVar metervar diff --git a/Annex/Url.hs b/Annex/Url.hs index b787ee78c9..f12408a08b 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -31,11 +31,9 @@ getUrlOptions = mkUrlOptions <*> headers <*> options where - headers = do - v <- annexHttpHeadersCommand <$> Annex.getGitConfig - case v of - Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) - Nothing -> annexHttpHeaders <$> Annex.getGitConfig + headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case + Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) + Nothing -> annexHttpHeaders <$> Annex.getGitConfig options = map Param . annexWebOptions <$> Annex.getGitConfig withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index d62e15aee6..4496561c95 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -30,17 +30,15 @@ import qualified Database.Keys.SQL - looking for a pointer to a key in git. -} lookupFile :: FilePath -> Annex (Maybe Key) -lookupFile file = do - mkey <- isAnnexLink file - case mkey of - Just key -> makeret key - Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect) - ( ifM (liftIO $ doesFileExist file) - ( maybe (return Nothing) makeret =<< catKeyFile file - , return Nothing - ) - , return Nothing +lookupFile file = isAnnexLink file >>= \case + Just key -> makeret key + Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect) + ( ifM (liftIO $ doesFileExist file) + ( maybe (return Nothing) makeret =<< catKeyFile file + , return Nothing ) + , return Nothing + ) where makeret = return . Just @@ -84,9 +82,8 @@ scanUnlockedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ do whenM (inAnnex k) $ do f <- fromRepo $ fromTopFilePath tf destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - replaceFile f $ \tmp -> do - r <- linkFromAnnex k tmp destmode - case r of + replaceFile f $ \tmp -> + linkFromAnnex k tmp destmode >>= \case LinkAnnexOk -> return () LinkAnnexNoop -> return () LinkAnnexFailed -> liftIO $ diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index d3803075d6..4a820cedec 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -30,23 +30,20 @@ import Logs.Transfer youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath)) youtubeDl url workdir = ifM (liftIO $ inPath "youtube-dl") ( runcmd >>= \case - Right True -> do - fs <- liftIO $ filterM (doesFileExist) =<< dirContents workdir - case fs of - (f:[]) -> return (Right (Just f)) - [] -> return nofiles - _ -> return (toomanyfiles fs) - Right False -> do - fs <- liftIO $ filterM (doesFileExist) =<< dirContents workdir - if null fs - then return (Right Nothing) - else return (Left "youtube-dl download is incomplete. Run the command again to resume.") + Right True -> workdirfiles >>= \case + (f:[]) -> return (Right (Just f)) + [] -> return nofiles + fs -> return (toomanyfiles fs) + Right False -> workdirfiles >>= \case + [] -> return (Right Nothing) + _ -> return (Left "youtube-dl download is incomplete. Run the command again to resume.") Left msg -> return (Left msg) , return (Right Nothing) ) where nofiles = Left "youtube-dl did not put any media in its work directory, perhaps it's been configured to store files somewhere else?" toomanyfiles fs = Left $ "youtube-dl downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs + workdirfiles = liftIO $ filterM (doesFileExist) =<< dirContents workdir runcmd = youtubeDlMaxSize workdir >>= \case Left msg -> return (Left msg) Right maxsize -> do @@ -96,9 +93,8 @@ youtubeDlMaxSize workdir = ifM (Annex.getState Annex.force) -- Download a media file to a destination, youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool youtubeDlTo key url dest = do - res <- withTmpWorkDir key $ \workdir -> do - dl <- youtubeDl url workdir - case dl of + res <- withTmpWorkDir key $ \workdir -> + youtubeDl url workdir >>= \case Right (Just mediafile) -> do liftIO $ renameFile mediafile dest return (Just True) diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index b98e7f0237..f49237157b 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -79,17 +79,15 @@ initSpecialRemote name remotetype mcreds config = go 0 go :: Int -> Annex RemoteName go n = do let fullname = if n == 0 then name else name ++ show n - r <- Annex.SpecialRemote.findExisting fullname - case r of + Annex.SpecialRemote.findExisting fullname >>= \case Nothing -> setupSpecialRemote fullname remotetype config mcreds (Nothing, R.Init, Annex.SpecialRemote.newConfig fullname) Just _ -> go (n + 1) {- Enables an existing special remote. -} enableSpecialRemote :: SpecialRemoteMaker -enableSpecialRemote name remotetype mcreds config = do - r <- Annex.SpecialRemote.findExisting name - case r of +enableSpecialRemote name remotetype mcreds config = + Annex.SpecialRemote.findExisting name >>= \case Nothing -> error $ "Cannot find a special remote named " ++ name Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 7acb701327..090a3a7cd1 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -35,9 +35,8 @@ import qualified Data.Text as T - Named threads are run by a management thread, so if they crash - an alert is displayed, allowing the thread to be restarted. -} startNamedThread :: UrlRenderer -> NamedThread -> Assistant () -startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do - m <- startedThreads <$> getDaemonStatus - case M.lookup name m of +startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = + M.lookup name . startedThreads <$> getDaemonStatus >>= \case Nothing -> start Just (aid, _) -> do r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ())))) @@ -65,24 +64,22 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do a void $ forkIO $ manager d aid return aid - manager d aid = do - r <- E.try (wait aid) :: IO (Either E.SomeException ()) - case r of - Right _ -> noop - Left e -> do - let msg = unwords - [ fromThreadName $ threadName d - , "crashed:", show e - ] - hPutStrLn stderr msg + manager d aid = (E.try (wait aid) :: IO (Either E.SomeException ())) >>= \case + Right _ -> noop + Left e -> do + let msg = unwords + [ fromThreadName $ threadName d + , "crashed:", show e + ] + hPutStrLn stderr msg #ifdef WITH_WEBAPP - button <- runAssistant d $ mkAlertButton True - (T.pack "Restart Thread") - urlrenderer - (RestartThreadR name) - runAssistant d $ void $ addAlert $ - (warningAlert (fromThreadName name) msg) - { alertButtons = [button] } + button <- runAssistant d $ mkAlertButton True + (T.pack "Restart Thread") + urlrenderer + (RestartThreadR name) + runAssistant d $ void $ addAlert $ + (warningAlert (fromThreadName name) msg) + { alertButtons = [button] } #endif namedThreadId :: NamedThread -> Assistant (Maybe ThreadId) diff --git a/Backend.hs b/Backend.hs index c39141f378..af033a63b6 100644 --- a/Backend.hs +++ b/Backend.hs @@ -52,8 +52,7 @@ defaultBackend = maybe cache return =<< Annex.getState Annex.backend genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) genKey source preferredbackend = do b <- maybe defaultBackend return preferredbackend - r <- B.getKey b source - return $ case r of + B.getKey b source >>= return . \case Nothing -> Nothing Just k -> Just (makesane k, b) where diff --git a/Backend/Hash.hs b/Backend/Hash.hs index a5abc84478..a0a16b74d4 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -176,9 +176,8 @@ hashFile hash file filesize = go hash usehasher hashsize@(HashSize sz) = case shaHasher hashsize filesize of Left sha -> use sha - Right (external, internal) -> do - v <- liftIO $ externalSHA external sz file - case v of + Right (external, internal) -> + liftIO (externalSHA external sz file) >>= \case Right r -> return r Left e -> do warning e diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index b8d0e3a402..2e0bc2ba26 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -186,13 +186,11 @@ allowConcurrentOutput = id onlyActionOn :: Key -> CommandStart -> CommandStart onlyActionOn k a = onlyActionOn' k run where - run = do - -- Run whole action, not just start stage, so other threads - -- block until it's done. - r <- callCommandAction' a - case r of - Nothing -> return Nothing - Just r' -> return $ Just $ return $ Just $ return r' + -- Run whole action, not just start stage, so other threads + -- block until it's done. + run = callCommandAction' a >>= \case + Nothing -> return Nothing + Just r' -> return $ Just $ return $ Just $ return r' onlyActionOn' :: Key -> Annex a -> Annex a onlyActionOn' k a = go =<< Annex.getState Annex.concurrency diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs index 47bc11a767..fcbf14b241 100644 --- a/CmdLine/GitAnnexShell/Checks.hs +++ b/CmdLine/GitAnnexShell/Checks.hs @@ -21,12 +21,10 @@ checkNotReadOnly :: IO () checkNotReadOnly = checkEnv "GIT_ANNEX_SHELL_READONLY" checkEnv :: String -> IO () -checkEnv var = do - v <- getEnv var - case v of - Nothing -> noop - Just "" -> noop - Just _ -> giveup $ "Action blocked by " ++ var +checkEnv var = getEnv var >>= \case + Nothing -> noop + Just "" -> noop + Just _ -> giveup $ "Action blocked by " ++ var checkDirectory :: Maybe FilePath -> IO () checkDirectory mdir = do diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index 5208a47ca3..8a87797559 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -19,14 +19,12 @@ import P2P.Address import P2P.Auth run :: [String] -> IO () -run (_remotename:address:[]) = forever $ do - -- gitremote-helpers protocol - l <- getLine - case l of +run (_remotename:address:[]) = forever $ + getLine >>= \case "capabilities" -> putStrLn "connect" >> ready "connect git-upload-pack" -> go UploadPack "connect git-receive-pack" -> go ReceivePack - _ -> error $ "git-remote-helpers protocol error at " ++ show l + l -> error $ "git-remote-helpers protocol error at " ++ show l where (onionaddress, onionport) | '/' `elem` address = parseAddressPort $ @@ -59,8 +57,6 @@ connectService address port service = do myuuid <- getUUID g <- Annex.gitRepo conn <- liftIO $ connectPeer g (TorAnnex address port) - liftIO $ runNetProto conn $ do - v <- auth myuuid authtoken - case v of - Just _theiruuid -> connect service stdin stdout - Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv + liftIO $ runNetProto conn $ auth myuuid authtoken >>= \case + Just _theiruuid -> connect service stdin stdout + Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 72f1303aff..621f116a07 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -84,8 +84,7 @@ withFilesInRefs a = mapM_ go (l, cleanup) <- inRepo $ LsTree.lsTree r forM_ l $ \i -> do let f = getTopFilePath $ LsTree.file i - v <- catKey (LsTree.sha i) - case v of + catKey (LsTree.sha i) >>= \case Nothing -> noop Just k -> whenM (matcher $ MatchingKey k) $ commandAction $ a f k diff --git a/Command.hs b/Command.hs index 58f57762e3..d1d539f45a 100644 --- a/Command.hs +++ b/Command.hs @@ -68,8 +68,7 @@ noMessages c = c { cmdnomessages = True } {- Undoes noMessages -} allowMessages :: Annex () allowMessages = do - curr <- Annex.getState Annex.output - case outputType curr of + outputType <$> Annex.getState Annex.output >>= \case QuietOutput -> Annex.setOutput NormalOutput _ -> noop Annex.changeState $ \s -> s diff --git a/Command/Add.hs b/Command/Add.hs index d1b2fbc7db..638da101e1 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -98,31 +98,25 @@ start file = do ) where go = ifAnnexed file addpresent add - add = do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file - case ms of - Nothing -> stop - Just s - | not (isRegularFile s) && not (isSymbolicLink s) -> stop - | otherwise -> do - showStart "add" file - next $ if isSymbolicLink s - then next $ addFile file - else perform file + add = liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case + Nothing -> stop + Just s + | not (isRegularFile s) && not (isSymbolicLink s) -> stop + | otherwise -> do + showStart "add" file + next $ if isSymbolicLink s + then next $ addFile file + else perform file addpresent key = ifM versionSupportsUnlockedPointers - ( do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file - case ms of - Just s | isSymbolicLink s -> fixuplink key - _ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key) - ( stop, add ) + ( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case + Just s | isSymbolicLink s -> fixuplink key + _ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key) + ( stop, add ) , ifM isDirect - ( do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file - case ms of - Just s | isSymbolicLink s -> fixuplink key - _ -> ifM (goodContent key file) - ( stop , add ) + ( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case + Just s | isSymbolicLink s -> fixuplink key + _ -> ifM (goodContent key file) + ( stop , add ) , fixuplink key ) ) diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 0e937dc69b..b5ec929a40 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -274,9 +274,8 @@ downloadWeb o url urlinfo file = finishDownloadWith tmp webUUID url file tryyoutubedl tmp = withTmpWorkDir mediakey $ \workdir -> Transfer.notifyTransfer Transfer.Download url $ - Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p -> do - dl <- youtubeDl url workdir - case dl of + Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p -> + youtubeDl url workdir >>= \case Right (Just mediafile) -> do pruneTmpWorkDirBefore tmp (liftIO . nukeFile) let dest = if isJust (fileOption o) @@ -338,8 +337,7 @@ finishDownloadWith tmp u url file = do , contentLocation = tmp , inodeCache = Nothing } - k <- genKey source backend - case k of + genKey source backend >>= \case Nothing -> return Nothing Just (key, _) -> do addWorkTree u url file key (Just tmp) diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs index e018079cb4..57e6f40c96 100644 --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -19,10 +19,8 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $ (batchable run (pure ())) run :: () -> String -> Annex Bool -run _ file = do - mkb <- genKey (KeySource file file Nothing) Nothing - case mkb of - Just (k, _) -> do - liftIO $ putStrLn $ key2file k - return True - Nothing -> return False +run _ file = genKey (KeySource file file Nothing) Nothing >>= \case + Just (k, _) -> do + liftIO $ putStrLn $ key2file k + return True + Nothing -> return False diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs index 4f9b4b1207..6d172b68e0 100644 --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -52,12 +52,10 @@ check ks mr = case mr of k = toKey ks go Nothing [] = return NotPresent go (Just e) [] = return $ CheckFailure e - go olderr (r:rs) = do - v <- Remote.hasKey r k - case v of - Right True -> return Present - Right False -> go olderr rs - Left e -> go (Just e) rs + go olderr (r:rs) = Remote.hasKey r k >>= \case + Right True -> return Present + Right False -> go olderr rs + Left e -> go (Just e) rs exitResult :: Result -> Annex a exitResult Present = liftIO exitSuccess diff --git a/Command/Config.hs b/Command/Config.hs index 47415999d3..a79a4f0772 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -62,9 +62,8 @@ seek (UnsetConfig name) = commandAction $ do unsetGlobalConfig name unsetConfig (ConfigKey name) return True -seek (GetConfig name) = commandAction $ do - mv <- getGlobalConfig name - case mv of +seek (GetConfig name) = commandAction $ + getGlobalConfig name >>= \case Nothing -> stop Just v -> do liftIO $ putStrLn v diff --git a/Command/Dead.hs b/Command/Dead.hs index 385dd6fada..7e329b9dd3 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -34,8 +34,7 @@ seek (DeadKeys ks) = seekActions $ pure $ map startKey ks startKey :: Key -> CommandStart startKey key = do showStart' "dead" (Just $ key2file key) - ls <- keyLocations key - case ls of + keyLocations key >>= \case [] -> next $ performKey key _ -> giveup "This key is still known to be present in some locations; not marking as dead." diff --git a/Command/Direct.hs b/Command/Direct.hs index 20eeef726e..3eeb2df1e4 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -47,13 +47,11 @@ perform = do next cleanup where go = whenAnnexed $ \f k -> do - r <- toDirectGen k f - case r of + toDirectGen k f >>= \case Nothing -> noop Just a -> do showStart "direct" f - r' <- tryNonAsync a - case r' of + tryNonAsync a >>= \case Left e -> warnlocked e Right _ -> showEndOk return Nothing diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index d9993ebc99..e540473c5f 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -68,8 +68,7 @@ startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remo startSpecialRemote name config Nothing = do m <- Annex.SpecialRemote.specialRemoteMap confm <- Logs.Remote.readRemoteLog - v <- Remote.nameToUUID' name - case v of + Remote.nameToUUID' name >>= \case Right u | u `M.member` m -> startSpecialRemote name config $ Just (u, fromMaybe M.empty (M.lookup u confm)) @@ -91,8 +90,7 @@ performSpecialRemote t u oldc c gc = do cleanupSpecialRemote :: UUID -> R.RemoteConfig -> CommandCleanup cleanupSpecialRemote u c = do Logs.Remote.configSet u c - mr <- Remote.byUUID u - case mr of + Remote.byUUID u >>= \case Nothing -> noop Just r -> setRemoteIgnore (R.repo r) False return True diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index 72fa504489..b73d00277d 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -91,8 +91,7 @@ checkHiddenService = bracket setup cleanup go g <- Annex.gitRepo -- Connect but don't bother trying to auth, -- we just want to know if the tor circuit works. - cv <- liftIO $ tryNonAsync $ connectPeer g addr - case cv of + liftIO (tryNonAsync $ connectPeer g addr) >>= \case Left e -> do warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.." liftIO $ threadDelaySeconds (Seconds 2) diff --git a/Command/Fix.hs b/Command/Fix.hs index 5b8630654a..4e8471bcb0 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -82,8 +82,7 @@ makeHardLink :: FilePath -> Key -> CommandPerform makeHardLink file key = do replaceFile file $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - r <- linkFromAnnex key tmp mode - case r of + linkFromAnnex key tmp mode >>= \case LinkAnnexFailed -> error "unable to make hard link" _ -> noop next $ return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs index bc7a29f151..7884f04777 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -103,15 +103,13 @@ checkDeadRepo u = earlyWarning "Warning: Fscking a repository that is currently marked as dead." start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart -start from inc file key = do - v <- Backend.getBackend file key - case v of - Nothing -> stop - Just backend -> do - numcopies <- getFileNumCopies file - case from of - Nothing -> go $ perform key file backend numcopies - Just r -> go $ performRemote key afile backend numcopies r +start from inc file key = Backend.getBackend file key >>= \case + Nothing -> stop + Just backend -> do + numcopies <- getFileNumCopies file + case from of + Nothing -> go $ perform key file backend numcopies + Just r -> go $ performRemote key afile backend numcopies r where go = runFsck inc (mkActionItem afile) key afile = AssociatedFile (Just file) @@ -142,9 +140,8 @@ performRemote key afile backend numcopies remote = dispatch (Left err) = do showNote err return False - dispatch (Right True) = withtmp $ \tmpfile -> do - r <- getfile tmpfile - case r of + dispatch (Right True) = withtmp $ \tmpfile -> + getfile tmpfile >>= \case Nothing -> go True Nothing Just True -> go True (Just tmpfile) Just False -> do