diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-12-05 15:00:50 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-12-05 15:00:50 -0400 |
commit | 236c467da19f34edb08f124e37fd26eb62c43fcf (patch) | |
tree | f4e488f77fb954812e4d48f399fc2ecab072afea /Annex | |
parent | f013f71cb5d3f7eee3afb3eb8f01a33206d717c4 (diff) |
more lambda-case conversion
Diffstat (limited to 'Annex')
-rw-r--r-- | Annex/Link.hs | 7 | ||||
-rw-r--r-- | Annex/NumCopies.hs | 15 | ||||
-rw-r--r-- | Annex/Perms.hs | 5 | ||||
-rw-r--r-- | Annex/SpecialRemote.hs | 3 | ||||
-rw-r--r-- | Annex/Ssh.hs | 11 | ||||
-rw-r--r-- | Annex/Transfer.hs | 26 | ||||
-rw-r--r-- | Annex/Url.hs | 8 | ||||
-rw-r--r-- | Annex/WorkTree.hs | 23 | ||||
-rw-r--r-- | Annex/YoutubeDl.hs | 24 |
9 files changed, 50 insertions, 72 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) |