From 254073569f27a607b7b458c9f42921defa71e140 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 20 Nov 2024 12:51:25 -0400 Subject: [PATCH] p2pHttpApp with a map of UUIDs to server states This is early groundwork for making p2phttp support serving multiple repositories from a single daemon. So far only 1 repository is served still. And this commit breaks support for proxying! --- Command/P2PHttp.hs | 20 ++++++----- P2P/Http/Server.hs | 86 +++++++++++++++++++++++----------------------- P2P/Http/State.hs | 55 +++++++++++++++-------------- 3 files changed, 85 insertions(+), 76 deletions(-) diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index e4ebfc3bec..ec37bf6d0a 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -16,6 +16,7 @@ import P2P.Http.Server import P2P.Http.Url import qualified P2P.Protocol as P2P import Utility.Env +import Annex.UUID import Servant import qualified Network.Wai.Handler.Warp as Warp @@ -102,24 +103,27 @@ optParser _ = Options )) seek :: Options -> CommandSeek -seek o = getAnnexWorkerPool $ \workerpool -> - withP2PConnections workerpool - (fromMaybe 1 $ proxyConnectionsOption o) - (fromMaybe 1 $ clusterJobsOption o) - (go workerpool) +seek o = do + u <- getUUID + getAnnexWorkerPool $ \workerpool -> + withP2PConnections workerpool + (fromMaybe 1 $ proxyConnectionsOption o) + (fromMaybe 1 $ clusterJobsOption o) + (go u workerpool) where - go workerpool acquireconn = liftIO $ do + go u workerpool acquireconn = liftIO $ do authenv <- getAuthEnv st <- mkP2PHttpServerState acquireconn workerpool $ mkGetServerMode authenv o + let mst = M.singleton u st let settings = Warp.setPort port $ Warp.setHost host $ Warp.defaultSettings case (certFileOption o, privateKeyFileOption o) of - (Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp st) + (Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mst) (Just certfile, Just privatekeyfile) -> do let tlssettings = Warp.tlsSettingsChain certfile (chainFileOption o) privatekeyfile - Warp.runTLS tlssettings settings (p2pHttpApp st) + Warp.runTLS tlssettings settings (p2pHttpApp mst) _ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS." port = maybe diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs index eaf87f36b4..c119cc79ba 100644 --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -40,15 +40,16 @@ import qualified Servant.Types.SourceT as S import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as LI +import qualified Data.Map as M import Control.Concurrent.Async import Control.Concurrent import System.IO.Unsafe import Data.Either -p2pHttpApp :: P2PHttpServerState -> Application +p2pHttpApp :: M.Map UUID P2PHttpServerState -> Application p2pHttpApp = serve p2pHttpAPI . serveP2pHttp -serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI +serveP2pHttp :: M.Map UUID P2PHttpServerState -> Server P2PHttpAPI serveP2pHttp st = serveGet st :<|> serveGet st @@ -91,7 +92,7 @@ serveP2pHttp st :<|> serveGetGeneric st serveGetGeneric - :: P2PHttpServerState + :: M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> B64Key -> Maybe (B64UUID ClientSide) @@ -109,7 +110,7 @@ serveGetGeneric st su@(B64UUID u) k mcu bypass = serveGet :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -120,8 +121,8 @@ serveGet -> IsSecure -> Maybe Auth -> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString)) -serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do - conn <- getP2PConnection apiver st cu su bypass sec auth ReadAction id +serveGet mst su apiver (B64Key k) cu bypass baf startat sec auth = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth ReadAction id bsv <- liftIO newEmptyTMVarIO endv <- liftIO newEmptyTMVarIO validityv <- liftIO newEmptyTMVarIO @@ -222,7 +223,7 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do serveCheckPresent :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -233,14 +234,14 @@ serveCheckPresent -> Handler CheckPresentResult serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id - $ \conn -> liftIO $ proxyClientNetProto conn $ checkPresent k + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ checkPresent k case res of Right b -> return (CheckPresentResult b) Left err -> throwError $ err500 { errBody = encodeBL err } serveRemove :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> (RemoveResultPlus -> t) -> B64UUID ServerSide -> v @@ -252,7 +253,7 @@ serveRemove -> Handler t serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ remove Nothing k case res of (Right b, plusuuids) -> return $ resultmangle $ @@ -262,7 +263,7 @@ serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do serveRemoveBefore :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -274,7 +275,7 @@ serveRemoveBefore -> Handler RemoveResultPlus serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ removeBeforeRemoteEndTime ts k case res of @@ -285,7 +286,7 @@ serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do serveGetTimestamp :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> B64UUID ClientSide @@ -295,7 +296,7 @@ serveGetTimestamp -> Handler GetTimestampResult serveGetTimestamp st su apiver cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn getTimestamp case res of Right ts -> return $ GetTimestampResult (Timestamp ts) @@ -304,7 +305,7 @@ serveGetTimestamp st su apiver cu bypass sec auth = do servePut :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -319,28 +320,28 @@ servePut -> IsSecure -> Maybe Auth -> Handler t -servePut st resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do - res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction +servePut mst resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do + res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction (\cst -> cst { connectionWaitVar = False }) (liftIO . protoaction) servePutResult resultmangle res where - protoaction conn = servePutAction st conn k baf $ \_offset -> do + protoaction conn = servePutAction conn k baf $ \_offset -> do net $ sendMessage DATA_PRESENT checkSuccessPlus -servePut st resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do +servePut mst resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do validityv <- liftIO newEmptyTMVarIO let validitycheck = local $ runValidityCheck $ liftIO $ atomically $ readTMVar validityv tooshortv <- liftIO newEmptyTMVarIO content <- liftIO $ S.unSourceT stream (gather validityv tooshortv) - res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction - (\cst -> cst { connectionWaitVar = False }) $ \conn -> do + res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction + (\cst -> cst { connectionWaitVar = False }) $ \(conn, st) -> do liftIO $ void $ async $ checktooshort conn tooshortv - liftIO (protoaction conn content validitycheck) + liftIO (protoaction conn st content validitycheck) servePutResult resultmangle res where - protoaction conn content validitycheck = - servePutAction st conn k baf $ \offset' -> + protoaction conn st content validitycheck = + servePutAction (conn, st) k baf $ \offset' -> let offsetdelta = offset' - offset in case compare offset' offset of EQ -> sendContent' nullMeterUpdate (Len len) @@ -396,13 +397,12 @@ servePut st resultmangle su apiver _datapresent (DataLength len) k cu bypass baf closeP2PConnection conn servePutAction - :: P2PHttpServerState - -> P2PConnectionPair + :: (P2PConnectionPair, P2PHttpServerState) -> B64Key -> Maybe B64FilePath -> (P2P.Protocol.Offset -> Proto (Maybe [UUID])) -> IO (Either SomeException (Either ProtoFailure (Maybe [UUID]))) -servePutAction st conn (B64Key k) baf a = inAnnexWorker st $ +servePutAction (conn, st) (B64Key k) baf a = inAnnexWorker st $ enteringStage (TransferStage Download) $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ put' k af a @@ -422,7 +422,7 @@ servePutResult resultmangle res = case res of servePut' :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -440,7 +440,7 @@ servePut' st resultmangle su v = servePut st resultmangle su v Nothing servePutOffset :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> (PutOffsetResultPlus -> t) -> B64UUID ServerSide -> v @@ -452,7 +452,7 @@ servePutOffset -> Handler t servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth WriteAction - (\cst -> cst { connectionWaitVar = False }) $ \conn -> + (\cst -> cst { connectionWaitVar = False }) $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ getPutOffset k af case res of Right offset -> return $ resultmangle $ @@ -464,7 +464,7 @@ servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do serveLockContent :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -473,8 +473,8 @@ serveLockContent -> IsSecure -> Maybe Auth -> Handler LockResult -serveLockContent st su apiver (B64Key k) cu bypass sec auth = do - conn <- getP2PConnection apiver st cu su bypass sec auth LockAction id +serveLockContent mst su apiver (B64Key k) cu bypass sec auth = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth LockAction id let lock = do lockresv <- newEmptyTMVarIO unlockv <- newEmptyTMVarIO @@ -501,7 +501,7 @@ serveLockContent st su apiver (B64Key k) cu bypass sec auth = do serveKeepLocked :: APIVersion v - => P2PHttpServerState + => M.Map UUID P2PHttpServerState -> B64UUID ServerSide -> v -> LockID @@ -513,15 +513,15 @@ serveKeepLocked -> Maybe KeepAlive -> S.SourceT IO UnlockRequest -> Handler LockResult -serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do - checkAuthActionClass st sec auth LockAction $ \_ -> do +serveKeepLocked mst su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do + checkAuthActionClass mst su sec auth LockAction $ \st _ -> do liftIO $ keepingLocked lckid st - _ <- liftIO $ S.unSourceT unlockrequeststream go + _ <- liftIO $ S.unSourceT unlockrequeststream (go st) return (LockResult False Nothing) where - go S.Stop = dropLock lckid st - go (S.Error _err) = dropLock lckid st - go (S.Skip s) = go s - go (S.Effect ms) = ms >>= go - go (S.Yield (UnlockRequest False) s) = go s - go (S.Yield (UnlockRequest True) _) = dropLock lckid st + go st S.Stop = dropLock lckid st + go st (S.Error _err) = dropLock lckid st + go st (S.Skip s) = go st s + go st (S.Effect ms) = ms >>= go st + go st (S.Yield (UnlockRequest False) s) = go st s + go st (S.Yield (UnlockRequest True) _) = dropLock lckid st diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index 302880b931..24d430957e 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -75,7 +75,7 @@ data ActionClass = ReadAction | WriteAction | RemoveAction | LockAction withP2PConnection :: APIVersion v => v - -> P2PHttpServerState + -> M.Map UUID P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -83,10 +83,10 @@ withP2PConnection -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> (P2PConnectionPair -> Handler (Either ProtoFailure a)) + -> ((P2PConnectionPair, P2PHttpServerState) -> Handler (Either ProtoFailure a)) -> Handler a -withP2PConnection apiver st cu su bypass sec auth actionclass fconnparams connaction = - withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction' +withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams connaction = + withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction' where connaction' conn = connaction conn >>= \case Right r -> return r @@ -96,7 +96,7 @@ withP2PConnection apiver st cu su bypass sec auth actionclass fconnparams connac withP2PConnection' :: APIVersion v => v - -> P2PHttpServerState + -> M.Map UUID P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -104,17 +104,17 @@ withP2PConnection' -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> (P2PConnectionPair -> Handler a) + -> ((P2PConnectionPair, P2PHttpServerState) -> Handler a) -> Handler a -withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction = do - conn <- getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams - connaction conn +withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams + connaction (conn, st) `finally` liftIO (releaseP2PConnection conn) getP2PConnection :: APIVersion v => v - -> P2PHttpServerState + -> M.Map UUID P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -122,16 +122,16 @@ getP2PConnection -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> Handler P2PConnectionPair -getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams = - checkAuthActionClass st sec auth actionclass go + -> Handler (P2PConnectionPair, P2PHttpServerState) +getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams = + checkAuthActionClass mst su sec auth actionclass go where - go servermode = liftIO (acquireP2PConnection st cp) >>= \case + go st servermode = liftIO (acquireP2PConnection st cp) >>= \case Left (ConnectionFailed err) -> throwError err502 { errBody = encodeBL err } Left TooManyConnections -> throwError err503 - Right v -> return v + Right v -> return (v, st) where cp = fconnparams $ ConnectionParams { connectionProtocolVersion = protocolVersion apiver @@ -143,29 +143,34 @@ getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams = } checkAuthActionClass - :: P2PHttpServerState + :: M.Map UUID P2PHttpServerState + -> B64UUID ServerSide -> IsSecure -> Maybe Auth -> ActionClass - -> (P2P.ServerMode -> Handler a) + -> (P2PHttpServerState -> P2P.ServerMode -> Handler a) -> Handler a -checkAuthActionClass st sec auth actionclass go = - case (sm, actionclass) of +checkAuthActionClass mst su sec auth actionclass go = + case M.lookup (fromB64UUID su) mst of + Just st -> select st + Nothing -> throwError err404 + where + select st = case (sm, actionclass) of (ServerMode { serverMode = P2P.ServeReadWrite }, _) -> - go P2P.ServeReadWrite + go st P2P.ServeReadWrite (ServerMode { unauthenticatedLockingAllowed = True }, LockAction) -> - go P2P.ServeReadOnly + go st P2P.ServeReadOnly (ServerMode { serverMode = P2P.ServeAppendOnly }, RemoveAction) -> throwError $ forbiddenWithoutAuth sm (ServerMode { serverMode = P2P.ServeAppendOnly }, _) -> - go P2P.ServeAppendOnly + go st P2P.ServeAppendOnly (ServerMode { serverMode = P2P.ServeReadOnly }, ReadAction) -> - go P2P.ServeReadOnly + go st P2P.ServeReadOnly (ServerMode { serverMode = P2P.ServeReadOnly }, _) -> throwError $ forbiddenWithoutAuth sm (CannotServeRequests, _) -> throwError basicAuthRequired - where - sm = getServerMode st sec auth + where + sm = getServerMode st sec auth forbiddenAction :: ServerError forbiddenAction = err403