avoid needing ifdefs when using P2P.Http.Client

This commit is contained in:
Joey Hess 2024-07-24 08:33:59 -04:00
parent b4d749cc91
commit ad945896c9
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 35 additions and 20 deletions

View file

@ -44,6 +44,7 @@ import System.IO.Unsafe
#endif #endif
type ClientAction a type ClientAction a
#ifdef WITH_SERVANT
= ClientEnv = ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> B64UUID ServerSide -> B64UUID ServerSide
@ -51,13 +52,14 @@ type ClientAction a
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> Annex (Either ClientError a) -> Annex (Either ClientError a)
#else
= ()
#endif
p2pHttpClient p2pHttpClient
:: Remote :: Remote
-> (String -> Annex a) -> (String -> Annex a)
#ifdef WITH_SERVANT
-> ClientAction a -> ClientAction a
#endif
-> Annex a -> Annex a
#ifdef WITH_SERVANT #ifdef WITH_SERVANT
p2pHttpClient rmt fallback clientaction = p2pHttpClient rmt fallback clientaction =
@ -132,11 +134,11 @@ p2pHttpClient rmt fallback clientaction =
M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc
Nothing -> noop Nothing -> noop
#else #else
runP2PHttpClient rmt fallback = fallback "This remote uses an annex+http url, but this version of git-annex is not build with support for that." runP2PHttpClient rmt fallback () = fallback
"This remote uses an annex+http url, but this version of git-annex is not build with support for that."
#endif #endif
#ifdef WITH_SERVANT #ifdef WITH_SERVANT
clientGet clientGet
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -154,7 +156,7 @@ clientGet clientenv (ProtocolVersion ver) k su cu bypass af auth dest = do
withClientM (cli k cu bypass af mo auth) clientenv $ \case withClientM (cli k cu bypass af mo auth) clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right respheaders -> do Right respheaders -> do
b <- S.unSourceT (getResponse respheaders) gatherByteString b <- S.unSourceT (getResponse respheaders) gather
liftIO $ withBinaryFile (fromRawFilePath dest) WriteMode $ \h -> do liftIO $ withBinaryFile (fromRawFilePath dest) WriteMode $ \h -> do
case startsz of case startsz of
Just startsz' | startsz' /= 0 -> Just startsz' | startsz' /= 0 ->
@ -183,16 +185,16 @@ clientGet clientenv (ProtocolVersion ver) k su cu bypass af auth dest = do
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
gatherByteString :: S.StepT IO B.ByteString -> IO L.ByteString gather = unsafeInterleaveIO . gather'
gatherByteString = unsafeInterleaveIO . go gather' S.Stop = return LI.Empty
where gather' (S.Error err) = giveup err
go S.Stop = return LI.Empty gather' (S.Skip s) = gather' s
go (S.Error err) = giveup err gather' (S.Effect ms) = ms >>= gather'
go (S.Skip s) = go s gather' (S.Yield v s) = LI.Chunk v <$> unsafeInterleaveIO (gather' s)
go (S.Effect ms) = ms >>= go #endif
go (S.Yield v s) = LI.Chunk v <$> unsafeInterleaveIO (go s)
clientCheckPresent :: Key -> ClientAction Bool clientCheckPresent :: Key -> ClientAction Bool
#ifdef WITH_SERVANT
clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth = clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
liftIO $ withClientM (cli su (B64Key key) cu bypass auth) clientenv $ \case liftIO $ withClientM (cli su (B64Key key) cu bypass auth) clientenv $ \case
Left err -> return (Left err) Left err -> return (Left err)
@ -207,7 +209,11 @@ clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
#else
clientCheckPresent _ = ()
#endif
#ifdef WITH_SERVANT
clientRemove clientRemove
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -232,7 +238,9 @@ clientRemove clientenv (ProtocolVersion ver) key su cu bypass auth =
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientRemoveBefore clientRemoveBefore
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -256,7 +264,9 @@ clientRemoveBefore clientenv (ProtocolVersion ver) key su cu bypass ts auth =
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> _ = client p2pHttpAPI v3 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientGetTimestamp clientGetTimestamp
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -279,7 +289,9 @@ clientGetTimestamp clientenv (ProtocolVersion ver) su cu bypass auth =
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|>
v3 :<|> _ = client p2pHttpAPI v3 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientPut clientPut
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -374,7 +386,9 @@ clientPut clientenv (ProtocolVersion ver) k su cu bypass auth moffset af content
_ :<|> _ :<|>
_ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientPutOffset clientPutOffset
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -404,7 +418,9 @@ clientPutOffset clientenv (ProtocolVersion ver) k su cu bypass auth
_ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientLockContent clientLockContent
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -434,7 +450,9 @@ clientLockContent clientenv (ProtocolVersion ver) k su cu bypass auth =
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
#endif
#ifdef WITH_SERVANT
clientKeepLocked clientKeepLocked
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
@ -487,4 +505,3 @@ clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
#endif #endif
-- ^ WITH_SERVANT

View file

@ -437,10 +437,7 @@ inAnnex' repo rmt st@(State connpool duc _ _ _) key
| Git.repoIsUrl repo = checkremote | Git.repoIsUrl repo = checkremote
| otherwise = checklocal | otherwise = checklocal
where where
checkp2phttp = p2pHttpClient rmt giveup checkp2phttp = p2pHttpClient rmt giveup (clientCheckPresent key)
#ifdef WITH_SERVANT
(clientCheckPresent key)
#endif
checkhttp = do checkhttp = do
gc <- Annex.getGitConfig gc <- Annex.getGitConfig
Url.withUrlOptionsPromptingCreds $ \uo -> Url.withUrlOptionsPromptingCreds $ \uo ->
@ -551,8 +548,6 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do
u <- getUUID u <- getUUID
hardlink <- wantHardLink hardlink <- wantHardLink
let bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
<|> remoteAnnexBwLimit (gitconfig r)
-- run copy from perspective of remote -- run copy from perspective of remote
onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case
Just (object, _sz, check) -> do Just (object, _sz, check) -> do
@ -574,6 +569,9 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc
(Ssh.runProto r connpool (return (False, UnVerified))) (Ssh.runProto r connpool (return (False, UnVerified)))
key file dest meterupdate vc key file dest meterupdate vc
| otherwise = giveup "copying from non-ssh, non-http remote not supported" | otherwise = giveup "copying from non-ssh, non-http remote not supported"
where
bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
<|> remoteAnnexBwLimit (gitconfig r)
copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS