ProxySelector data type

diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs
index dfd42587bbfd4d09ed1109ea2608a097d159eada..b251641a3c9ee518c3f3dde8e00e20a112c18cd6 100644 (file)
--- a/Command/P2PStdIO.hs
+++ b/Command/P2PStdIO.hs
@@ -74,7 +74,7 @@ performProxy clientuuid servermode remote = do
                        closeRemoteSide remoteside
                        p2pDone
                proxy closer proxyMethods servermode clientside
-                       (const $ return remoteside)
+                       (singleProxySelector remoteside)
                        protocolversion othermsg p2pErrHandler
        withclientversion _ Nothing = p2pDone
 

diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs
index e4101177e0d5dd31f0ec7bfbfef396af75ab3353..a255a1af814714b98730ab16d1012ac33e108b64 100644 (file)
--- a/P2P/Proxy.hs
+++ b/P2P/Proxy.hs
@@ -50,6 +50,28 @@ closeRemoteSide remoteside =
                Just (_, _, closer) -> closer
                Nothing -> return ()
 
+{- Selects what remotes to proxy to for top-level P2P protocol
+ - actions.
+ - -}
+data ProxySelector = ProxySelector
+       { proxyCHECKPRESENT :: Key -> Annex RemoteSide
+       , proxyLOCKCONTENT :: Key -> Annex RemoteSide
+       , proxyUNLOCKCONTENT :: Annex RemoteSide
+       , proxyREMOVE :: Key -> Annex RemoteSide
+       , proxyGET :: Key -> Annex RemoteSide
+       , proxyPUT :: Key -> Annex RemoteSide
+       }
+
+singleProxySelector :: RemoteSide -> ProxySelector
+singleProxySelector r = ProxySelector
+       { proxyCHECKPRESENT = const (pure r)
+       , proxyLOCKCONTENT = const (pure r)
+       , proxyUNLOCKCONTENT = pure r
+       , proxyREMOVE = const (pure r)
+       , proxyGET = const (pure r)
+       , proxyPUT = const (pure r)
+       }
+
 {- To keep this module limited to P2P protocol actions,
  - all other actions that a proxy needs to do are provided
  - here. -}
@@ -113,13 +135,13 @@ proxy
        -> ProxyMethods
        -> ServerMode
        -> ClientSide
-       -> (Message -> Annex RemoteSide)
+       -> ProxySelector
        -> ProtocolVersion
        -> Maybe Message
        -- ^ non-VERSION message that was received from the client when
        -- negotiating protocol version, and has not been responded to yet
        -> ProtoErrorHandled r
-proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) getremoteside protocolversion othermessage protoerrhandler = do
+proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) proxyselector protocolversion othermessage protoerrhandler = do
        case othermessage of
                Nothing -> protoerrhandler proxynextclientmessage $ 
                        client $ net $ sendMessage $ VERSION protocolversion
@@ -138,24 +160,24 @@ proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) getr
 
        proxyclientmessage Nothing = proxydone
        proxyclientmessage (Just message) = case message of
-               CHECKPRESENT _ -> do
-                       remoteside <- getremoteside message
+               CHECKPRESENT k -> do
+                       remoteside <- proxyCHECKPRESENT proxyselector k
                        proxyresponse remoteside message (const proxynextclientmessage)
-               LOCKCONTENT _ -> do
-                       remoteside <- getremoteside message
+               LOCKCONTENT k -> do
+                       remoteside <- proxyLOCKCONTENT proxyselector k
                        proxyresponse remoteside message (const proxynextclientmessage)
                UNLOCKCONTENT -> do
-                       remoteside <- getremoteside message
+                       remoteside <- proxyUNLOCKCONTENT proxyselector
                        proxynoresponse remoteside message proxynextclientmessage
                REMOVE k -> do
-                       remoteside <- getremoteside message
+                       remoteside <- proxyREMOVE proxyselector k
                        servermodechecker checkREMOVEServerMode $
                                handleREMOVE remoteside k message
-               GET _ _ _ -> do
-                       remoteside <- getremoteside message
+               GET _ _ k -> do
+                       remoteside <- proxyGET proxyselector k
                        handleGET remoteside message
                PUT _ k -> do
-                       remoteside <- getremoteside message
+                       remoteside <- proxyPUT proxyselector k
                        servermodechecker checkPUTServerMode $
                                handlePUT remoteside k message
                -- These messages involve the git repository, not the