started on git-annex-shell cluster support

Works down to P2P protocol.

The question now is, how to handle protocol version negotiation for
clusters? Connecting to each node to find their protocol versions and
using the lowest would be too expensive with a lot of nodes. So it seems
that the cluster needs to pick its own protocol version to use with the
client.

Then it can either negotiate that same version with the nodes when
it comes time to use them, or it can translate between multiple protocol
versions. That seems complicated. Thinking it would be ok to refuse to
use a node if it is not able to negotiate the same protocol version with
it as with the client. That will mean that sometimes need nodes to be
upgraded when upgrading the cluster's proxy. But protocol versions
rarely change.

diff --git a/Annex.hs b/Annex.hs
index 1e3825ad1973618d659faf373ae6b49526f4e616..ca2d83c3a36f8a9de5af2827b38ca732b1b75984 100644 (file)
--- a/Annex.hs
+++ b/Annex.hs
@@ -215,7 +215,7 @@ data AnnexState = AnnexState
        , urloptions :: Maybe UrlOptions
        , insmudgecleanfilter :: Bool
        , getvectorclock :: IO CandidateVectorClock
-       , proxyremote :: Maybe (Types.Remote.RemoteA Annex)
+       , proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex))
        }
 
 newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState

diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs
index 11652e36b826f125da58f91bd222a24fc3cdfbb2..8091260acaf3d4fbaa2b9487a1f6831ad287d795 100644 (file)
--- a/CmdLine/GitAnnexShell.hs
+++ b/CmdLine/GitAnnexShell.hs
@@ -21,6 +21,7 @@ import Remote.GCrypt (getGCryptUUID)
 import P2P.Protocol (ServerMode(..))
 import Git.Types
 import Logs.Proxy
+import Logs.Cluster
 import Logs.UUID
 import Remote
 
@@ -193,21 +194,33 @@ checkProxy remoteuuid ouruuid = M.lookup ouruuid <$> getProxies >>= \case
        Just proxies ->
                case filter (\p -> proxyRemoteUUID p == remoteuuid) (S.toList proxies) of
                        [] -> notconfigured
-                       ps -> do
-                               -- This repository may have multiple
-                               -- remotes that access the same repository.
-                               -- Proxy for the lowest cost one that
-                               -- is configured to be used as a proxy.
-                               rs <- concat . byCost <$> remoteList
-                               let sameuuid r = uuid r == remoteuuid
-                               let samename r p = name r == proxyRemoteName p
-                               case headMaybe (filter (\r -> sameuuid r && any (samename r) ps) rs) of
-                                       Nothing -> notconfigured
-                                       Just r -> do
-                                               Annex.changeState $ \st ->
-                                                       st { Annex.proxyremote = Just r }
-                                               return True
+                       ps -> case mkClusterUUID remoteuuid of
+                               Just cu -> proxyforcluster cu
+                               Nothing -> proxyfor ps
   where
+       -- This repository may have multiple remotes that access the same
+       -- repository. Proxy for the lowest cost one that is configured to
+       -- be used as a proxy.
+       proxyfor ps = do
+               rs <- concat . byCost <$> remoteList
+               let sameuuid r = uuid r == remoteuuid
+               let samename r p = name r == proxyRemoteName p
+               case headMaybe (filter (\r -> sameuuid r && any (samename r) ps) rs) of
+                       Nothing -> notconfigured
+                       Just r -> do
+                               Annex.changeState $ \st ->
+                                       st { Annex.proxyremote = Just (Right r) }
+                               return True
+
+       proxyforcluster cu = do
+               clusters <- getClusters
+               if M.member cu (clusterUUIDs clusters)
+                       then do
+                               Annex.changeState $ \st ->
+                                       st { Annex.proxyremote = Just (Left cu) }
+                               return True
+                       else notconfigured
+
        notconfigured = M.lookup remoteuuid <$> uuidDescMap >>= \case
-               Just desc -> giveup $ "not configured to proxy for repository " ++ (fromUUIDDesc desc)
+               Just desc -> giveup $ "not configured to proxy for repository " ++ fromUUIDDesc desc
                Nothing -> return False

diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs
index 5424df814028158ca2aa5a5b4e654b589b17a877..a2bc93cbc811b993eeaa220916a4b8b112ca3ebc 100644 (file)
--- a/Command/P2PStdIO.hs
+++ b/Command/P2PStdIO.hs
@@ -17,6 +17,7 @@ import Annex.UUID
 import qualified CmdLine.GitAnnexShell.Checks as Checks
 import Remote.Helper.Ssh (openP2PShellConnection', closeP2PShellConnection)
 import Logs.Location
+import Logs.Cluster
 import qualified Remote
 
 import System.IO.Error
@@ -40,8 +41,12 @@ start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do
                        (False, True) -> P2P.ServeAppendOnly
                        (False, False) -> P2P.ServeReadWrite
        Annex.getState Annex.proxyremote >>= \case
-               Nothing -> performLocal theiruuid servermode
-               Just r -> performProxy theiruuid servermode r
+               Nothing ->
+                       performLocal theiruuid servermode
+               Just (Right r) ->
+                       performProxy theiruuid servermode r
+               Just (Left clusteruuid) -> 
+                       performProxyCluster theiruuid clusteruuid servermode
 
 performLocal :: UUID -> P2P.ServerMode -> CommandPerform
 performLocal theiruuid servermode = do
@@ -51,48 +56,60 @@ performLocal theiruuid servermode = do
                P2P.net $ P2P.sendMessage (P2P.AUTH_SUCCESS myuuid)
                P2P.serveAuthed servermode myuuid
        runst <- liftIO $ mkRunState $ Serving theiruuid Nothing
-       runFullProto runst conn server >>= \case
-               Right () -> done
-               -- Avoid displaying an error when the client hung up on us.
-               Left (ProtoFailureIOError e) | isEOFError e -> done
-               Left e -> giveup (describeProtoFailure e)
-  where
-       done = next $ return True
+       p2pErrHandler (const p2pDone) (runFullProto runst conn server)
 
 performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform
 performProxy clientuuid servermode remote = do
-       clientrunst <- liftIO (mkRunState $ Serving clientuuid Nothing)
-       let clientside = ClientSide clientrunst (stdioP2PConnection Nothing)
-       getClientProtocolVersion remote clientside 
+       clientside <- proxyClientSide clientuuid
+       getClientProtocolVersion (Remote.uuid remote) clientside 
                (withclientversion clientside)
-               protoerrhandler
+               p2pErrHandler
   where
        withclientversion clientside (Just (clientmaxversion, othermsg)) = do
-               remoteside <- connectremote clientmaxversion
-               proxy done proxymethods servermode clientside remoteside 
-                       othermsg protoerrhandler
-       withclientversion _ Nothing = done
+               remoteside <- proxySshRemoteSide clientmaxversion remote
+               proxy p2pDone proxymethods servermode clientside remoteside 
+                       othermsg p2pErrHandler
+       withclientversion _ Nothing = p2pDone
        
        proxymethods = ProxyMethods
                { removedContent = \u k -> logChange k u InfoMissing
                , addedContent = \u k -> logChange k u InfoPresent
                }
 
-       -- FIXME: Support special remotes.
-       connectremote clientmaxversion = mkRemoteSide (Remote.uuid remote) $
-               openP2PShellConnection' remote clientmaxversion >>= \case
-                       Just conn@(P2P.IO.OpenConnection (remoterunst, remoteconn, _)) ->
-                               return $ Just 
-                                       ( remoterunst
-                                       , remoteconn
-                                       , void $ liftIO $ closeP2PShellConnection conn
-                                       )
-                       _  -> return Nothing
+performProxyCluster :: UUID -> ClusterUUID -> P2P.ServerMode -> CommandPerform
+performProxyCluster clientuuid clusteruuid servermode = do
+       clientside <- proxyClientSide clientuuid
+       getClientProtocolVersion (fromClusterUUID clusteruuid) clientside 
+               (withclientversion clientside)
+               p2pErrHandler
+  where
+       withclientversion clientside (Just (clientmaxversion, othermsg)) = do
+               giveup "TODO"
+       withclientversion _ Nothing = p2pDone
+
+proxyClientSide :: UUID -> Annex ClientSide
+proxyClientSide clientuuid = do
+       clientrunst <- liftIO (mkRunState $ Serving clientuuid Nothing)
+       return $ ClientSide clientrunst (stdioP2PConnection Nothing)
 
-       protoerrhandler cont a = a >>= \case
-               -- Avoid displaying an error when the client hung up on us.
-               Left (ProtoFailureIOError e) | isEOFError e -> done
-               Left e -> giveup (describeProtoFailure e)
-               Right v -> cont v
-       
-       done = next $ return True
+-- FIXME: Support special remotes.
+proxySshRemoteSide :: P2P.ProtocolVersion -> Remote -> Annex RemoteSide
+proxySshRemoteSide clientmaxversion remote = mkRemoteSide (Remote.uuid remote) $
+       openP2PShellConnection' remote clientmaxversion >>= \case
+               Just conn@(P2P.IO.OpenConnection (remoterunst, remoteconn, _)) ->
+                       return $ Just 
+                               ( remoterunst
+                               , remoteconn
+                               , void $ liftIO $ closeP2PShellConnection conn
+                               )
+               _  -> return Nothing
+
+p2pErrHandler :: (a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform
+p2pErrHandler cont a = a >>= \case
+       -- Avoid displaying an error when the client hung up on us.
+       Left (ProtoFailureIOError e) | isEOFError e -> p2pDone
+       Left e -> giveup (describeProtoFailure e)
+       Right v -> cont v
+
+p2pDone :: CommandPerform
+p2pDone = next $ return True

diff --git a/Logs/Cluster.hs b/Logs/Cluster.hs
index 67bb4a69dac8ddd5a87cfa814efc3601cc983975..584dcb6867855a0d9b20a20cb315d30c871bd46b 100644 (file)
--- a/Logs/Cluster.hs
+++ b/Logs/Cluster.hs
@@ -8,14 +8,10 @@
 {-# LANGUAGE OverloadedStrings, TupleSections #-}
 
 module Logs.Cluster (
-       ClusterUUID,
-       isClusterUUID,
-       fromClusterUUID,
-       ClusterNodeUUID(..),
+       module Types.Cluster,
        getClusters,
        loadClusters,
        recordCluster,
-       Clusters(..)
 ) where
 
 import qualified Annex

diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs
index ca968198572df44fd3528bf1fc5f4b2095070c97..ed668fa7811b7e6f2da41c5b011afc1c5f1443a8 100644 (file)
--- a/P2P/Proxy.hs
+++ b/P2P/Proxy.hs
@@ -12,7 +12,6 @@ module P2P.Proxy where
 import Annex.Common
 import P2P.Protocol
 import P2P.IO
-import qualified Remote
 import Utility.Metered (nullMeterUpdate)
 
 import Control.Concurrent.STM
@@ -60,20 +59,20 @@ type ProtoErrorHandled r =
  - brought up yet.
  -}
 getClientProtocolVersion 
-       :: Remote
+       :: UUID
        -> ClientSide
        -> (Maybe (ProtocolVersion, Maybe Message) -> Annex r)
        -> ProtoErrorHandled r
-getClientProtocolVersion remote (ClientSide clientrunst clientconn) cont protoerrhandler =
-       protoerrhandler cont $ client $ getClientProtocolVersion' remote
+getClientProtocolVersion remoteuuid (ClientSide clientrunst clientconn) cont protoerrhandler =
+       protoerrhandler cont $ client $ getClientProtocolVersion' remoteuuid
   where
        client = liftIO . runNetProto clientrunst clientconn
 
 getClientProtocolVersion'
-       :: Remote
+       :: UUID
        -> Proto (Maybe (ProtocolVersion, Maybe Message))
-getClientProtocolVersion' remote = do
-       net $ sendMessage (AUTH_SUCCESS (Remote.uuid remote))
+getClientProtocolVersion' remoteuuid = do
+       net $ sendMessage (AUTH_SUCCESS remoteuuid)
        msg <- net receiveMessage
        case msg of
                Nothing -> return Nothing