2024-07-23 18:12:03 +00:00
|
|
|
{- P2P protocol over HTTP, client
|
2024-07-23 17:53:10 +00:00
|
|
|
-
|
|
|
|
- https://git-annex.branchable.com/design/p2p_protocol_over_http/
|
|
|
|
-
|
|
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2024-07-23 18:12:03 +00:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
{-# LANGUAGE DataKinds, TypeApplications #-}
|
2024-07-23 17:53:10 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2024-07-24 13:45:14 +00:00
|
|
|
module P2P.Http.Client (
|
|
|
|
module P2P.Http.Client,
|
|
|
|
Validity(..),
|
|
|
|
) where
|
2024-07-23 17:53:10 +00:00
|
|
|
|
|
|
|
import Types
|
|
|
|
import Annex.Url
|
|
|
|
|
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 22:45:02 +00:00
|
|
|
import qualified Annex
|
2024-07-23 17:53:10 +00:00
|
|
|
import Annex.UUID
|
|
|
|
import Types.Remote
|
2024-07-23 18:12:03 +00:00
|
|
|
import P2P.Http
|
2024-07-23 17:53:10 +00:00
|
|
|
import P2P.Http.Url
|
2024-07-23 18:12:03 +00:00
|
|
|
import Annex.Common
|
|
|
|
import P2P.Protocol hiding (Offset, Bypass, auth)
|
|
|
|
import Annex.Concurrent
|
2024-07-24 13:45:14 +00:00
|
|
|
import Annex.Verify
|
2024-07-23 22:11:15 +00:00
|
|
|
import Utility.Url (BasicAuth(..))
|
2024-07-24 13:45:14 +00:00
|
|
|
import Utility.Metered
|
2024-07-23 22:11:15 +00:00
|
|
|
import qualified Git.Credential as Git
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-23 22:11:15 +00:00
|
|
|
import Servant hiding (BasicAuthData(..))
|
2024-07-23 18:12:03 +00:00
|
|
|
import Servant.Client.Streaming
|
|
|
|
import qualified Servant.Types.SourceT as S
|
2024-07-23 18:58:49 +00:00
|
|
|
import Network.HTTP.Types.Status
|
|
|
|
import Network.HTTP.Client
|
2024-07-23 18:12:03 +00:00
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import qualified Data.ByteString.Lazy.Internal as LI
|
2024-07-23 22:45:02 +00:00
|
|
|
import qualified Data.Map as M
|
2024-07-23 18:12:03 +00:00
|
|
|
import Control.Concurrent.STM
|
|
|
|
import Control.Concurrent.Async
|
|
|
|
import Control.Concurrent
|
|
|
|
import System.IO.Unsafe
|
2024-07-23 17:53:10 +00:00
|
|
|
#endif
|
|
|
|
|
2024-07-23 18:12:03 +00:00
|
|
|
type ClientAction a
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
= ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
2024-07-23 18:58:49 +00:00
|
|
|
-> Annex (Either ClientError a)
|
2024-07-24 12:33:59 +00:00
|
|
|
#else
|
|
|
|
= ()
|
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-23 17:53:10 +00:00
|
|
|
p2pHttpClient
|
|
|
|
:: Remote
|
|
|
|
-> (String -> Annex a)
|
2024-07-23 18:12:03 +00:00
|
|
|
-> ClientAction a
|
2024-07-23 17:53:10 +00:00
|
|
|
-> Annex a
|
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:58:49 +00:00
|
|
|
p2pHttpClient rmt fallback clientaction =
|
2024-07-23 17:53:10 +00:00
|
|
|
case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
|
|
|
|
Nothing -> error "internal"
|
|
|
|
Just baseurl -> do
|
|
|
|
mgr <- httpManager <$> getUrlOptions
|
|
|
|
let clientenv = mkClientEnv mgr baseurl
|
2024-07-23 22:45:02 +00:00
|
|
|
ccv <- Annex.getRead Annex.gitcredentialcache
|
|
|
|
Git.CredentialCache cc <- liftIO $ atomically $
|
|
|
|
readTMVar ccv
|
|
|
|
case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of
|
|
|
|
Nothing -> go clientenv Nothing False Nothing allProtocolVersions
|
|
|
|
Just cred -> go clientenv (Just cred) True (credauth cred) allProtocolVersions
|
2024-07-23 18:58:49 +00:00
|
|
|
where
|
2024-07-23 22:45:02 +00:00
|
|
|
go clientenv mcred credcached mauth (v:vs) = do
|
2024-07-23 18:58:49 +00:00
|
|
|
myuuid <- getUUID
|
|
|
|
res <- clientaction clientenv v
|
|
|
|
(B64UUID (uuid rmt))
|
|
|
|
(B64UUID myuuid)
|
|
|
|
[]
|
2024-07-23 22:11:15 +00:00
|
|
|
mauth
|
2024-07-23 18:58:49 +00:00
|
|
|
case res of
|
2024-07-23 22:11:15 +00:00
|
|
|
Right resp -> do
|
2024-07-23 22:45:02 +00:00
|
|
|
unless credcached $ cachecred mcred
|
2024-07-23 22:11:15 +00:00
|
|
|
return resp
|
2024-07-23 18:58:49 +00:00
|
|
|
Left (FailureResponse _ resp)
|
|
|
|
| statusCode (responseStatusCode resp) == 404 && not (null vs) ->
|
2024-07-23 22:45:02 +00:00
|
|
|
go clientenv mcred credcached mauth vs
|
2024-07-23 22:11:15 +00:00
|
|
|
| statusCode (responseStatusCode resp) == 401 ->
|
|
|
|
case mcred of
|
|
|
|
Nothing -> authrequired clientenv (v:vs)
|
|
|
|
Just cred -> do
|
|
|
|
inRepo $ Git.rejectUrlCredential cred
|
|
|
|
fallback (showstatuscode resp)
|
|
|
|
| otherwise -> fallback (showstatuscode resp)
|
2024-07-23 18:58:49 +00:00
|
|
|
Left (ConnectionError ex) -> case fromException ex of
|
|
|
|
Just (HttpExceptionRequest _ (ConnectionFailure err)) -> fallback $
|
|
|
|
"unable to connect to HTTP server: " ++ show err
|
|
|
|
_ -> fallback (show ex)
|
|
|
|
Left clienterror -> fallback $
|
|
|
|
"git-annex HTTP API server returned an unexpected response: " ++ show clienterror
|
2024-07-23 22:45:02 +00:00
|
|
|
go _ _ _ _ [] = error "internal"
|
2024-07-23 22:11:15 +00:00
|
|
|
|
2024-07-23 22:45:02 +00:00
|
|
|
authrequired clientenv vs = do
|
|
|
|
cred <- prompt $
|
|
|
|
inRepo $ Git.getUrlCredential credentialbaseurl
|
|
|
|
go clientenv (Just cred) False (credauth cred) vs
|
2024-07-23 22:11:15 +00:00
|
|
|
|
|
|
|
showstatuscode resp =
|
|
|
|
show (statusCode (responseStatusCode resp))
|
|
|
|
++ " " ++
|
|
|
|
decodeBS (statusMessage (responseStatusCode resp))
|
|
|
|
|
2024-07-23 22:45:02 +00:00
|
|
|
credentialbaseurl = case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
|
|
|
|
Nothing -> error "internal"
|
|
|
|
Just url -> p2pHttpUrlWithoutUUID url
|
|
|
|
|
|
|
|
credauth cred = do
|
|
|
|
ba <- Git.credentialBasicAuth cred
|
|
|
|
return $ Auth
|
|
|
|
(encodeBS (basicAuthUser ba))
|
|
|
|
(encodeBS (basicAuthPassword ba))
|
|
|
|
|
|
|
|
cachecred mcred = case mcred of
|
|
|
|
Just cred -> do
|
|
|
|
inRepo $ Git.approveUrlCredential cred
|
|
|
|
ccv <- Annex.getRead Annex.gitcredentialcache
|
|
|
|
liftIO $ atomically $ do
|
|
|
|
Git.CredentialCache cc <- takeTMVar ccv
|
|
|
|
putTMVar ccv $ Git.CredentialCache $
|
|
|
|
M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc
|
|
|
|
Nothing -> noop
|
2024-07-23 17:53:10 +00:00
|
|
|
#else
|
2024-07-24 12:33:59 +00:00
|
|
|
runP2PHttpClient rmt fallback () = fallback
|
|
|
|
"This remote uses an annex+http url, but this version of git-annex is not build with support for that."
|
2024-07-23 17:53:10 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
|
|
|
#ifdef WITH_SERVANT
|
2024-07-24 15:03:59 +00:00
|
|
|
-- Downloads and writes to the Handle. If the file already exists, provide
|
|
|
|
-- its starting size, and it will resume from that point. Note that the
|
|
|
|
-- IncrementalVerifier needs to have already been fed the existing content
|
|
|
|
-- of the file.
|
2024-07-23 18:12:03 +00:00
|
|
|
clientGet
|
2024-07-24 13:45:14 +00:00
|
|
|
:: MeterUpdate
|
|
|
|
-> Maybe IncrementalVerifier
|
|
|
|
-> Key
|
|
|
|
-> AssociatedFile
|
2024-07-24 15:03:59 +00:00
|
|
|
-> Handle
|
|
|
|
-> Maybe FileSize
|
2024-07-24 13:45:14 +00:00
|
|
|
-> ClientAction Validity
|
2024-07-24 15:03:59 +00:00
|
|
|
clientGet meterupdate iv k af h startsz clientenv (ProtocolVersion ver) su cu bypass auth = liftIO $ do
|
2024-07-24 13:45:14 +00:00
|
|
|
let offset = fmap (Offset . fromIntegral) startsz
|
|
|
|
withClientM (cli (B64Key k) cu bypass baf offset auth) clientenv $ \case
|
|
|
|
Left err -> return (Left err)
|
2024-07-24 15:03:59 +00:00
|
|
|
Right respheaders -> do
|
|
|
|
b <- S.unSourceT (getResponse respheaders) gather
|
|
|
|
BytesProcessed len <- meteredWrite'
|
|
|
|
meterupdate
|
|
|
|
(writeVerifyChunk iv h) b
|
|
|
|
let DataLength dl = case lookupResponseHeader @DataLengthHeader' respheaders of
|
|
|
|
Header hdr -> hdr
|
|
|
|
_ -> error "missing data length header"
|
|
|
|
return $ Right $
|
|
|
|
if dl == len then Valid else Invalid
|
2024-07-23 18:12:03 +00:00
|
|
|
where
|
|
|
|
cli =case ver of
|
|
|
|
3 -> v3 su V3
|
|
|
|
2 -> v2 su V2
|
|
|
|
1 -> v1 su V1
|
|
|
|
0 -> v0 su V0
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
gather = unsafeInterleaveIO . gather'
|
|
|
|
gather' S.Stop = return LI.Empty
|
|
|
|
gather' (S.Error err) = giveup err
|
|
|
|
gather' (S.Skip s) = gather' s
|
|
|
|
gather' (S.Effect ms) = ms >>= gather'
|
|
|
|
gather' (S.Yield v s) = LI.Chunk v <$> unsafeInterleaveIO (gather' s)
|
2024-07-24 13:45:14 +00:00
|
|
|
|
|
|
|
baf = associatedFileToB64FilePath af
|
|
|
|
#else
|
|
|
|
clientGet _ _ _ = ()
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
|
|
|
clientCheckPresent :: Key -> ClientAction Bool
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
|
|
|
|
liftIO $ withClientM (cli su (B64Key key) cu bypass auth) clientenv $ \case
|
2024-07-23 18:58:49 +00:00
|
|
|
Left err -> return (Left err)
|
|
|
|
Right (CheckPresentResult res) -> return (Right res)
|
2024-07-23 18:12:03 +00:00
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> flip v3 V3
|
|
|
|
2 -> flip v2 V2
|
|
|
|
1 -> flip v1 V1
|
|
|
|
0 -> flip v0 V0
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#else
|
|
|
|
clientCheckPresent _ = ()
|
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientRemove
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64Key
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> IO RemoveResultPlus
|
|
|
|
clientRemove clientenv (ProtocolVersion ver) key su cu bypass auth =
|
|
|
|
withClientM cli clientenv $ \case
|
|
|
|
Left err -> throwM err
|
|
|
|
Right res -> return res
|
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> v3 su V3 key cu bypass auth
|
|
|
|
2 -> v2 su V2 key cu bypass auth
|
|
|
|
1 -> plus <$> v1 su V1 key cu bypass auth
|
|
|
|
0 -> plus <$> v0 su V0 key cu bypass auth
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientRemoveBefore
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64Key
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Timestamp
|
|
|
|
-> Maybe Auth
|
|
|
|
-> IO RemoveResultPlus
|
|
|
|
clientRemoveBefore clientenv (ProtocolVersion ver) key su cu bypass ts auth =
|
|
|
|
withClientM (cli su key cu bypass ts auth) clientenv $ \case
|
|
|
|
Left err -> throwM err
|
|
|
|
Right res -> return res
|
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> flip v3 V3
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientGetTimestamp
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> IO GetTimestampResult
|
|
|
|
clientGetTimestamp clientenv (ProtocolVersion ver) su cu bypass auth =
|
|
|
|
withClientM (cli su cu bypass auth) clientenv $ \case
|
|
|
|
Left err -> throwM err
|
|
|
|
Right res -> return res
|
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> flip v3 V3
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|>
|
|
|
|
v3 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientPut
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64Key
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> Maybe Offset
|
|
|
|
-> AssociatedFile
|
|
|
|
-> FilePath
|
|
|
|
-> FileSize
|
|
|
|
-> Annex Bool
|
|
|
|
-> Annex PutResultPlus
|
|
|
|
clientPut clientenv (ProtocolVersion ver) k su cu bypass auth moffset af contentfile contentfilesize validitycheck = do
|
|
|
|
checkv <- liftIO newEmptyTMVarIO
|
|
|
|
checkresultv <- liftIO newEmptyTMVarIO
|
|
|
|
let checker = do
|
|
|
|
liftIO $ atomically $ takeTMVar checkv
|
|
|
|
validitycheck >>= liftIO . atomically . putTMVar checkresultv
|
|
|
|
checkerthread <- liftIO . async =<< forkState checker
|
|
|
|
v <- liftIO $ withBinaryFile contentfile ReadMode $ \h -> do
|
|
|
|
when (offset /= 0) $
|
|
|
|
hSeek h AbsoluteSeek offset
|
|
|
|
withClientM (cli (stream h checkv checkresultv)) clientenv return
|
|
|
|
case v of
|
|
|
|
Left err -> do
|
|
|
|
void $ liftIO $ atomically $ tryPutTMVar checkv ()
|
|
|
|
join $ liftIO (wait checkerthread)
|
|
|
|
throwM err
|
|
|
|
Right res -> do
|
|
|
|
join $ liftIO (wait checkerthread)
|
|
|
|
return res
|
|
|
|
where
|
|
|
|
stream h checkv checkresultv = S.SourceT $ \a -> do
|
|
|
|
bl <- L.hGetContents h
|
|
|
|
v <- newMVar (0, filter (not . B.null) (L.toChunks bl))
|
|
|
|
a (go v)
|
|
|
|
where
|
|
|
|
go v = S.fromActionStep B.null $ modifyMVar v $ \case
|
|
|
|
(n, (b:[])) -> do
|
|
|
|
let !n' = n + B.length b
|
|
|
|
ifM (checkvalid n')
|
|
|
|
( return ((n', []), b)
|
|
|
|
-- The key's content is invalid, but
|
|
|
|
-- the amount of data is the same as
|
|
|
|
-- the DataLengthHeader indicates.
|
|
|
|
-- Truncate the stream by one byte to
|
|
|
|
-- indicate to the server that it's
|
|
|
|
-- not valid.
|
|
|
|
, return
|
|
|
|
( (n' - 1, [])
|
|
|
|
, B.take (B.length b - 1) b
|
|
|
|
)
|
|
|
|
)
|
|
|
|
(n, []) -> do
|
|
|
|
void $ checkvalid n
|
|
|
|
return ((n, []), mempty)
|
|
|
|
(n, (b:bs)) ->
|
|
|
|
let !n' = n + B.length b
|
|
|
|
in return ((n', bs), b)
|
|
|
|
|
|
|
|
checkvalid n = do
|
|
|
|
void $ liftIO $ atomically $ tryPutTMVar checkv ()
|
|
|
|
valid <- liftIO $ atomically $ readTMVar checkresultv
|
|
|
|
if not valid
|
|
|
|
then return (n /= fromIntegral nlen)
|
|
|
|
else return True
|
|
|
|
|
|
|
|
baf = case af of
|
|
|
|
AssociatedFile Nothing -> Nothing
|
|
|
|
AssociatedFile (Just f) -> Just (B64FilePath f)
|
|
|
|
|
|
|
|
len = DataLength nlen
|
|
|
|
|
|
|
|
nlen = contentfilesize - offset
|
|
|
|
|
|
|
|
offset = case moffset of
|
|
|
|
Nothing -> 0
|
|
|
|
Just (Offset o) -> fromIntegral o
|
|
|
|
|
|
|
|
cli src = case ver of
|
|
|
|
3 -> v3 su V3 len k cu bypass baf moffset src auth
|
|
|
|
2 -> v2 su V2 len k cu bypass baf moffset src auth
|
|
|
|
1 -> plus <$> v1 su V1 len k cu bypass baf moffset src auth
|
|
|
|
0 -> plus <$> v0 su V0 len k cu bypass baf moffset src auth
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientPutOffset
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64Key
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> IO PutOffsetResultPlus
|
|
|
|
clientPutOffset clientenv (ProtocolVersion ver) k su cu bypass auth
|
|
|
|
| ver == 0 = return (PutOffsetResultPlus (Offset 0))
|
|
|
|
| otherwise =
|
|
|
|
withClientM cli clientenv $ \case
|
|
|
|
Left err -> throwM err
|
|
|
|
Right res -> return res
|
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> v3 su V3 k cu bypass auth
|
|
|
|
2 -> v2 su V2 k cu bypass auth
|
|
|
|
1 -> plus <$> v1 su V1 k cu bypass auth
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientLockContent
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> B64Key
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> IO LockResult
|
|
|
|
clientLockContent clientenv (ProtocolVersion ver) k su cu bypass auth =
|
|
|
|
withClientM (cli k cu bypass auth) clientenv $ \case
|
|
|
|
Left err -> throwM err
|
|
|
|
Right res -> return res
|
|
|
|
where
|
|
|
|
cli = case ver of
|
|
|
|
3 -> v3 su V3
|
|
|
|
2 -> v2 su V2
|
|
|
|
1 -> v1 su V1
|
|
|
|
0 -> v0 su V0
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
2024-07-24 12:33:59 +00:00
|
|
|
#endif
|
2024-07-23 18:12:03 +00:00
|
|
|
|
2024-07-24 12:33:59 +00:00
|
|
|
#ifdef WITH_SERVANT
|
2024-07-23 18:12:03 +00:00
|
|
|
clientKeepLocked
|
|
|
|
:: ClientEnv
|
|
|
|
-> ProtocolVersion
|
|
|
|
-> LockID
|
|
|
|
-> B64UUID ServerSide
|
|
|
|
-> B64UUID ClientSide
|
|
|
|
-> [B64UUID Bypass]
|
|
|
|
-> Maybe Auth
|
|
|
|
-> (TMVar Bool -> IO ())
|
|
|
|
-- ^ The TMVar can be filled any number of times with True to send
|
|
|
|
-- repeated keep locked requests, eg to keep a connection alive.
|
|
|
|
-- Once filled with False, the lock will be dropped.
|
|
|
|
-> IO ()
|
|
|
|
clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do
|
|
|
|
keeplocked <- newEmptyTMVarIO
|
|
|
|
tid <- async $ a keeplocked
|
|
|
|
let cli' = cli lckid (Just cu) bypass auth
|
|
|
|
(Just connectionKeepAlive) (Just keepAlive)
|
|
|
|
(S.fromStepT (unlocksender keeplocked))
|
|
|
|
withClientM cli' clientenv $ \case
|
|
|
|
Right (LockResult _ _) ->
|
|
|
|
wait tid
|
|
|
|
Left err -> do
|
|
|
|
wait tid
|
|
|
|
throwM err
|
|
|
|
where
|
|
|
|
unlocksender keeplocked =
|
|
|
|
S.Yield (UnlockRequest False) $ S.Effect $ do
|
|
|
|
return $ S.Effect $ do
|
|
|
|
stilllocked <- liftIO $ atomically $ takeTMVar keeplocked
|
|
|
|
return $ if stilllocked
|
|
|
|
then unlocksender keeplocked
|
|
|
|
else S.Yield (UnlockRequest True) S.Stop
|
|
|
|
|
|
|
|
cli = case ver of
|
|
|
|
3 -> v3 su V3
|
|
|
|
2 -> v2 su V2
|
|
|
|
1 -> v1 su V1
|
|
|
|
0 -> v0 su V0
|
|
|
|
_ -> error "unsupported protocol version"
|
|
|
|
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|>
|
|
|
|
_ :<|> _ :<|> _ :<|> _ :<|>
|
|
|
|
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
|
|
|
|
|
|
|
|
#endif
|