mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

factored out proxyRequest

Browse source 
This will allow the HTTP server to keep a connection to a proxied
remote open, and only enter the Annex monad when handling a client
request.
This commit is contained in:
Joey Hess 2024-07-25 15:00:36 -04:00
parent 3d14e2cf58
commit 7b56fe1350
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 61 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

98
P2P/Proxy.hs
View file

@ -220,66 +220,82 @@ proxy
-- ^ non-VERSION message that was received from the client when -- ^ non-VERSION message that was received from the client when
-- negotiating protocol version, and has not been responded to yet -- negotiating protocol version, and has not been responded to yet
-> ProtoErrorHandled r -> ProtoErrorHandled r
proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clientconn) remoteuuid proxyselector concurrencyconfig (ProtocolVersion protocolversion) othermsg protoerrhandler = do proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clientconn) remoteuuid proxyselector concurrencyconfig protocolversion othermsg protoerrhandler = do
case othermsg of case othermsg of
Nothing -> proxynextclientmessage () Nothing -> proxynextclientmessage ()
Just message -> proxyclientmessage (Just message) Just message -> proxyclientmessage (Just message)
where where
client = liftIO . runNetProto clientrunst clientconn client = liftIO . runNetProto clientrunst clientconn
proxyclientmessage Nothing = proxydone
proxyclientmessage (Just message) = proxyRequest
proxydone proxymethods proxystate servermode
(ClientSide clientrunst clientconn) remoteuuid
proxyselector concurrencyconfig protocolversion
proxynextclientmessage message
protoerrhandler
proxynextclientmessage () = protoerrhandler proxyclientmessage $ proxynextclientmessage () = protoerrhandler proxyclientmessage $
client (net receiveMessage) client (net receiveMessage)
servermodechecker c a = c servermode $ \case {- Handles proxying a single request between the client and remote. -}
Nothing -> a proxyRequest
Just notallowed -> :: Annex r
protoerrhandler proxynextclientmessage $ -> ProxyMethods
client notallowed -> ProxyState
-> ServerMode
proxyclientmessage Nothing = proxydone -> ClientSide
proxyclientmessage (Just message) = case message of -> UUID
-> ProxySelector
-> ConcurrencyConfig
-> ProtocolVersion
-> (() -> Annex r) -- ^ called once the request has been handled
-> Message
-> ProtoErrorHandled r
proxyRequest proxydone proxymethods proxystate servermode (ClientSide clientrunst clientconn) remoteuuid proxyselector concurrencyconfig (ProtocolVersion protocolversion) requestcomplete requestmessage protoerrhandler =
case requestmessage of
CHECKPRESENT k -> proxyCHECKPRESENT proxyselector k >>= \case CHECKPRESENT k -> proxyCHECKPRESENT proxyselector k >>= \case
Just remoteside -> Just remoteside ->
proxyresponse remoteside message proxyresponse remoteside requestmessage
(const proxynextclientmessage) (const requestcomplete)
Nothing -> Nothing ->
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage FAILURE client $ net $ sendMessage FAILURE
LOCKCONTENT k -> proxyLOCKCONTENT proxyselector k >>= \case LOCKCONTENT k -> proxyLOCKCONTENT proxyselector k >>= \case
Just remoteside -> Just remoteside ->
proxyresponse remoteside message proxyresponse remoteside requestmessage
(const proxynextclientmessage) (const requestcomplete)
Nothing -> Nothing ->
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage FAILURE client $ net $ sendMessage FAILURE
UNLOCKCONTENT -> proxyUNLOCKCONTENT proxyselector >>= \case UNLOCKCONTENT -> proxyUNLOCKCONTENT proxyselector >>= \case
Just remoteside -> Just remoteside ->
proxynoresponse remoteside message proxynoresponse remoteside requestmessage
proxynextclientmessage requestcomplete
Nothing -> proxynextclientmessage () Nothing -> requestcomplete ()
REMOVE k -> do REMOVE k -> do
remotesides <- proxyREMOVE proxyselector k remotesides <- proxyREMOVE proxyselector k
servermodechecker checkREMOVEServerMode $ servermodechecker checkREMOVEServerMode $
handleREMOVE remotesides k message handleREMOVE remotesides k requestmessage
REMOVE_BEFORE _ k -> do REMOVE_BEFORE _ k -> do
remotesides <- proxyREMOVE proxyselector k remotesides <- proxyREMOVE proxyselector k
servermodechecker checkREMOVEServerMode $ servermodechecker checkREMOVEServerMode $
handleREMOVE remotesides k message handleREMOVE remotesides k requestmessage
GETTIMESTAMP -> do GETTIMESTAMP -> do
remotesides <- proxyGETTIMESTAMP proxyselector remotesides <- proxyGETTIMESTAMP proxyselector
handleGETTIMESTAMP remotesides handleGETTIMESTAMP remotesides
GET _ _ k -> proxyGET proxyselector k >>= \case GET _ _ k -> proxyGET proxyselector k >>= \case
Just remoteside -> handleGET remoteside message Just remoteside -> handleGET remoteside requestmessage
Nothing -> Nothing ->
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage $ client $ net $ sendMessage $
ERROR "content not present" ERROR "content not present"
PUT paf k -> do PUT paf k -> do
af <- getassociatedfile paf af <- getassociatedfile paf
remotesides <- proxyPUT proxyselector af k remotesides <- proxyPUT proxyselector af k
servermodechecker checkPUTServerMode $ servermodechecker checkPUTServerMode $
handlePUT remotesides k message handlePUT remotesides k requestmessage
BYPASS _ -> proxynextclientmessage () BYPASS _ -> requestcomplete ()
-- These messages involve the git repository, not the -- These messages involve the git repository, not the
-- annex. So they affect the git repository of the proxy, -- annex. So they affect the git repository of the proxy,
-- not the remote. -- not the remote.
@ -312,6 +328,14 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
-- Early messages that the client should not send now. -- Early messages that the client should not send now.
AUTH _ _ -> protoerr AUTH _ _ -> protoerr
VERSION _ -> protoerr VERSION _ -> protoerr
where
client = liftIO . runNetProto clientrunst clientconn
servermodechecker c a = c servermode $ \case
Nothing -> a
Just notallowed ->
protoerrhandler requestcomplete $
client notallowed
-- Send a message to the remote, send its response back to the -- Send a message to the remote, send its response back to the
-- client, and pass it to the continuation. -- client, and pass it to the continuation.
@ -358,7 +382,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
writeTVar (proxyRemoteLatestLocalTimestamp proxystate) writeTVar (proxyRemoteLatestLocalTimestamp proxystate)
Nothing Nothing
proxyresponse remoteside GETTIMESTAMP proxyresponse remoteside GETTIMESTAMP
(const proxynextclientmessage) (const requestcomplete)
-- When there are multiple remotes, reply with our local timestamp, -- When there are multiple remotes, reply with our local timestamp,
-- and do timestamp translation when sending REMOVE-FROM. -- and do timestamp translation when sending REMOVE-FROM.
handleGETTIMESTAMP remotesides = do handleGETTIMESTAMP remotesides = do
@ -374,7 +398,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
remotetimes remotetimes
writeTVar (proxyRemoteLatestLocalTimestamp proxystate) writeTVar (proxyRemoteLatestLocalTimestamp proxystate)
(Just localtime) (Just localtime)
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage (TIMESTAMP localtime) client $ net $ sendMessage (TIMESTAMP localtime)
where where
getremotetimes = forMC concurrencyconfig remotesides $ \r -> getremotetimes = forMC concurrencyconfig remotesides $ \r ->
@ -394,7 +418,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
handleREMOVE [] _ _ = handleREMOVE [] _ _ =
-- When no places are provided to remove from, -- When no places are provided to remove from,
-- don't report a successful remote. -- don't report a successful remote.
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage FAILURE client $ net $ sendMessage FAILURE
handleREMOVE remotesides k message = do handleREMOVE remotesides k message = do
tsm <- liftIO $ readTVarIO $ tsm <- liftIO $ readTVarIO $
@ -427,7 +451,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
let v' = map join v let v' = map join v
let us = concatMap snd $ catMaybes v' let us = concatMap snd $ catMaybes v'
mapM_ (\u -> removedContent proxymethods u k) us mapM_ (\u -> removedContent proxymethods u k) us
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage $ client $ net $ sendMessage $
let nonplussed = all (== remoteuuid) us let nonplussed = all (== remoteuuid) us
|| protocolversion < 2 || protocolversion < 2
@ -443,16 +467,16 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
handleGET remoteside message = getresponse (runRemoteSide remoteside) message $ handleGET remoteside message = getresponse (runRemoteSide remoteside) message $
withDATA (relayGET remoteside) $ \case withDATA (relayGET remoteside) $ \case
ERROR err -> protoerrhandler proxynextclientmessage $ ERROR err -> protoerrhandler requestcomplete $
client $ net $ sendMessage (ERROR err) client $ net $ sendMessage (ERROR err)
_ -> protoerr _ -> protoerr
handlePUT (remoteside:[]) k message handlePUT (remoteside:[]) k message
| Remote.uuid (remote remoteside) == remoteuuid = | Remote.uuid (remote remoteside) == remoteuuid =
getresponse (runRemoteSide remoteside) message $ \resp -> case resp of getresponse (runRemoteSide remoteside) message $ \resp -> case resp of
ALREADY_HAVE -> protoerrhandler proxynextclientmessage $ ALREADY_HAVE -> protoerrhandler requestcomplete $
client $ net $ sendMessage resp client $ net $ sendMessage resp
ALREADY_HAVE_PLUS _ -> protoerrhandler proxynextclientmessage $ ALREADY_HAVE_PLUS _ -> protoerrhandler requestcomplete $
client $ net $ sendMessage resp client $ net $ sendMessage resp
PUT_FROM _ -> PUT_FROM _ ->
getresponse client resp $ getresponse client resp $
@ -461,7 +485,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
(const protoerr) (const protoerr)
_ -> protoerr _ -> protoerr
handlePUT [] _ _ = handlePUT [] _ _ =
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage ALREADY_HAVE client $ net $ sendMessage ALREADY_HAVE
handlePUT remotesides k message = handlePUT remotesides k message =
handlePutMulti remotesides k message handlePutMulti remotesides k message
@ -473,7 +497,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
relayDATACore len (runRemoteSide remoteside) client $ relayDATACore len (runRemoteSide remoteside) client $
relayDATAFinish (runRemoteSide remoteside) client $ relayDATAFinish (runRemoteSide remoteside) client $
relayonemessage client (runRemoteSide remoteside) $ relayonemessage client (runRemoteSide remoteside) $
const proxynextclientmessage const requestcomplete
relayPUT remoteside k len = relayDATAStart (runRemoteSide remoteside) $ relayPUT remoteside k len = relayDATAStart (runRemoteSide remoteside) $
relayDATACore len client (runRemoteSide remoteside) $ relayDATACore len client (runRemoteSide remoteside) $
@ -482,7 +506,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
where where
finished resp () = do finished resp () = do
void $ relayPUTRecord k remoteside resp void $ relayPUTRecord k remoteside resp
proxynextclientmessage () requestcomplete ()
relayPUTRecord k remoteside SUCCESS = do relayPUTRecord k remoteside SUCCESS = do
addedContent proxymethods (Remote.uuid (remote remoteside)) k addedContent proxymethods (Remote.uuid (remote remoteside)) k
@ -515,9 +539,9 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
l <- forMC concurrencyconfig remotesides initiate l <- forMC concurrencyconfig remotesides initiate
if all alreadyhave l if all alreadyhave l
then if protocolversion < 2 then if protocolversion < 2
then protoerrhandler proxynextclientmessage $ then protoerrhandler requestcomplete $
client $ net $ sendMessage ALREADY_HAVE client $ net $ sendMessage ALREADY_HAVE
else protoerrhandler proxynextclientmessage $ else protoerrhandler requestcomplete $
client $ net $ sendMessage $ ALREADY_HAVE_PLUS $ client $ net $ sendMessage $ ALREADY_HAVE_PLUS $
filter (/= remoteuuid) $ filter (/= remoteuuid) $
map (Remote.uuid . remote) (lefts (rights l)) map (Remote.uuid . remote) (lefts (rights l))
@ -619,7 +643,7 @@ proxy proxydone proxymethods proxystate servermode (ClientSide clientrunst clien
Just (Just resp) -> Just (Just resp) ->
relayPUTRecord k r resp relayPUTRecord k r resp
_ -> return Nothing _ -> return Nothing
protoerrhandler proxynextclientmessage $ protoerrhandler requestcomplete $
client $ net $ sendMessage $ client $ net $ sendMessage $
case concat (catMaybes storeduuids) of case concat (catMaybes storeduuids) of
[] -> FAILURE [] -> FAILURE