more lambda-case conversion
This commit is contained in:
parent
936d50310d
commit
fc845e6530
29 changed files with 137 additions and 199 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue