summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2017-12-05 15:00:50 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2017-12-05 15:00:50 -0400
commit236c467da19f34edb08f124e37fd26eb62c43fcf (patch)
treef4e488f77fb954812e4d48f399fc2ecab072afea
parentf013f71cb5d3f7eee3afb3eb8f01a33206d717c4 (diff)
more lambda-case conversion
-rw-r--r--Annex/Link.hs7
-rw-r--r--Annex/NumCopies.hs15
-rw-r--r--Annex/Perms.hs5
-rw-r--r--Annex/SpecialRemote.hs3
-rw-r--r--Annex/Ssh.hs11
-rw-r--r--Annex/Transfer.hs26
-rw-r--r--Annex/Url.hs8
-rw-r--r--Annex/WorkTree.hs23
-rw-r--r--Annex/YoutubeDl.hs24
-rw-r--r--Assistant/MakeRemote.hs8
-rw-r--r--Assistant/NamedThread.hs37
-rw-r--r--Backend.hs3
-rw-r--r--Backend/Hash.hs5
-rw-r--r--CmdLine/Action.hs12
-rw-r--r--CmdLine/GitAnnexShell/Checks.hs10
-rw-r--r--CmdLine/GitRemoteTorAnnex.hs16
-rw-r--r--CmdLine/Seek.hs3
-rw-r--r--Command.hs3
-rw-r--r--Command/Add.hs40
-rw-r--r--Command/AddUrl.hs8
-rw-r--r--Command/CalcKey.hs12
-rw-r--r--Command/CheckPresentKey.hs10
-rw-r--r--Command/Config.hs5
-rw-r--r--Command/Dead.hs3
-rw-r--r--Command/Direct.hs6
-rw-r--r--Command/EnableRemote.hs6
-rw-r--r--Command/EnableTor.hs3
-rw-r--r--Command/Fix.hs3
-rw-r--r--Command/Fsck.hs21
29 files changed, 137 insertions, 199 deletions
diff --git a/Annex/Link.hs b/Annex/Link.hs
index fcc300bee..e083cfe8c 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 5e818fe95..9fea49db6 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 1ce342911..93919af86 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 c215208db..23b0f582f 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 c3f46b4c1..e3d2c3d8b 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 ccb5409a7..ad617a7df 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 b787ee78c..f12408a08 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 d62e15aee..4496561c9 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 d3803075d..4a820cede 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 b98e7f023..f49237157 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 7acb70132..090a3a7cd 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 c39141f37..af033a63b 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 a5abc8447..a0a16b74d 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 b8d0e3a40..2e0bc2ba2 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 47bc11a76..fcbf14b24 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 5208a47ca..8a8779755 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 72f1303af..621f116a0 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 58f57762e..d1d539f45 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 d1b2fbc7d..638da101e 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 0e937dc69..b5ec929a4 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 e018079cb..57e6f40c9 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 4f9b4b120..6d172b68e 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 47415999d..a79a4f077 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 385dd6fad..7e329b9dd 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 20eeef726..3eeb2df1e 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 d9993ebc9..e540473c5 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 72fa50448..b73d00277 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 5b8630654..4e8471bcb 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 bc7a29f15..7884f0477 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