diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index 51f992cb91..0c55f09a3b 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -110,9 +110,12 @@ seek o = getAnnexWorkerPool $ \workerpool -> where go workerpool servinguuids acquireconn = liftIO $ do authenv <- getAuthEnv - st <- mkP2PHttpServerState acquireconn workerpool $ + st <- mkPerRepoServerState acquireconn workerpool $ mkGetServerMode authenv o - let mst = M.fromList $ zip servinguuids (repeat st) + let mst = P2PHttpServerState + { servedRepos = M.fromList $ + zip servinguuids (repeat st) + } let settings = Warp.setPort port $ Warp.setHost host $ Warp.defaultSettings case (certFileOption o, privateKeyFileOption o) of diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs index c119cc79ba..207c168fa5 100644 --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -40,16 +40,15 @@ 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 :: M.Map UUID P2PHttpServerState -> Application +p2pHttpApp :: P2PHttpServerState -> Application p2pHttpApp = serve p2pHttpAPI . serveP2pHttp -serveP2pHttp :: M.Map UUID P2PHttpServerState -> Server P2PHttpAPI +serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI serveP2pHttp st = serveGet st :<|> serveGet st @@ -92,7 +91,7 @@ serveP2pHttp st :<|> serveGetGeneric st serveGetGeneric - :: M.Map UUID P2PHttpServerState + :: P2PHttpServerState -> B64UUID ServerSide -> B64Key -> Maybe (B64UUID ClientSide) @@ -110,7 +109,7 @@ serveGetGeneric st su@(B64UUID u) k mcu bypass = serveGet :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -223,7 +222,7 @@ serveGet mst su apiver (B64Key k) cu bypass baf startat sec auth = do serveCheckPresent :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -241,7 +240,7 @@ serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do serveRemove :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> (RemoveResultPlus -> t) -> B64UUID ServerSide -> v @@ -263,7 +262,7 @@ serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do serveRemoveBefore :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -286,7 +285,7 @@ serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do serveGetTimestamp :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> B64UUID ClientSide @@ -305,7 +304,7 @@ serveGetTimestamp st su apiver cu bypass sec auth = do servePut :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -397,7 +396,7 @@ servePut mst resultmangle su apiver _datapresent (DataLength len) k cu bypass ba closeP2PConnection conn servePutAction - :: (P2PConnectionPair, P2PHttpServerState) + :: (P2PConnectionPair, PerRepoServerState) -> B64Key -> Maybe B64FilePath -> (P2P.Protocol.Offset -> Proto (Maybe [UUID])) @@ -422,7 +421,7 @@ servePutResult resultmangle res = case res of servePut' :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -440,7 +439,7 @@ servePut' st resultmangle su v = servePut st resultmangle su v Nothing servePutOffset :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> (PutOffsetResultPlus -> t) -> B64UUID ServerSide -> v @@ -464,7 +463,7 @@ servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do serveLockContent :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -501,7 +500,7 @@ serveLockContent mst su apiver (B64Key k) cu bypass sec auth = do serveKeepLocked :: APIVersion v - => M.Map UUID P2PHttpServerState + => P2PHttpServerState -> B64UUID ServerSide -> v -> LockID diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index a9df861220..e3fabdd990 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -44,6 +44,10 @@ import Control.Concurrent.Async import Data.Time.Clock.POSIX data P2PHttpServerState = P2PHttpServerState + { servedRepos :: M.Map UUID PerRepoServerState + } + +data PerRepoServerState = PerRepoServerState { acquireP2PConnection :: AcquireP2PConnection , annexWorkerPool :: AnnexWorkerPool , getServerMode :: GetServerMode @@ -62,8 +66,8 @@ data ServerMode } | CannotServeRequests -mkP2PHttpServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO P2PHttpServerState -mkP2PHttpServerState acquireconn annexworkerpool getservermode = P2PHttpServerState +mkPerRepoServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO PerRepoServerState +mkPerRepoServerState acquireconn annexworkerpool getservermode = PerRepoServerState <$> pure acquireconn <*> pure annexworkerpool <*> pure getservermode @@ -75,7 +79,7 @@ data ActionClass = ReadAction | WriteAction | RemoveAction | LockAction withP2PConnection :: APIVersion v => v - -> M.Map UUID P2PHttpServerState + -> P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -83,7 +87,7 @@ withP2PConnection -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> ((P2PConnectionPair, P2PHttpServerState) -> Handler (Either ProtoFailure a)) + -> ((P2PConnectionPair, PerRepoServerState) -> Handler (Either ProtoFailure a)) -> Handler a withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams connaction = withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction' @@ -96,7 +100,7 @@ withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams conna withP2PConnection' :: APIVersion v => v - -> M.Map UUID P2PHttpServerState + -> P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -104,7 +108,7 @@ withP2PConnection' -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> ((P2PConnectionPair, P2PHttpServerState) -> Handler a) + -> ((P2PConnectionPair, PerRepoServerState) -> Handler a) -> Handler a withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction = do (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams @@ -114,7 +118,7 @@ withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams conn getP2PConnection :: APIVersion v => v - -> M.Map UUID P2PHttpServerState + -> P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -122,7 +126,7 @@ getP2PConnection -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> Handler (P2PConnectionPair, P2PHttpServerState) + -> Handler (P2PConnectionPair, PerRepoServerState) getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams = checkAuthActionClass mst su sec auth actionclass go where @@ -143,15 +147,15 @@ getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams = } checkAuthActionClass - :: M.Map UUID P2PHttpServerState + :: P2PHttpServerState -> B64UUID ServerSide -> IsSecure -> Maybe Auth -> ActionClass - -> (P2PHttpServerState -> P2P.ServerMode -> Handler a) + -> (PerRepoServerState -> P2P.ServerMode -> Handler a) -> Handler a checkAuthActionClass mst su sec auth actionclass go = - case M.lookup (fromB64UUID su) mst of + case M.lookup (fromB64UUID su) (servedRepos mst) of Just st -> select st Nothing -> throwError err404 where @@ -493,13 +497,13 @@ mkLocker lock unlock = do wait locktid return Nothing -storeLock :: LockID -> Locker -> P2PHttpServerState -> IO () +storeLock :: LockID -> Locker -> PerRepoServerState -> IO () storeLock lckid locker st = atomically $ do m <- takeTMVar (openLocks st) let !m' = M.insert lckid locker m putTMVar (openLocks st) m' -keepingLocked :: LockID -> P2PHttpServerState -> IO () +keepingLocked :: LockID -> PerRepoServerState -> IO () keepingLocked lckid st = do m <- atomically $ readTMVar (openLocks st) case M.lookup lckid m of @@ -508,7 +512,7 @@ keepingLocked lckid st = do atomically $ void $ tryPutTMVar (lockerTimeoutDisable locker) () -dropLock :: LockID -> P2PHttpServerState -> IO () +dropLock :: LockID -> PerRepoServerState -> IO () dropLock lckid st = do v <- atomically $ do m <- takeTMVar (openLocks st) @@ -532,7 +536,7 @@ getAnnexWorkerPool a = startConcurrency transferStages $ Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads." Just wp -> a wp -inAnnexWorker :: P2PHttpServerState -> Annex a -> IO (Either SomeException a) +inAnnexWorker :: PerRepoServerState -> Annex a -> IO (Either SomeException a) inAnnexWorker st = inAnnexWorker' (annexWorkerPool st) inAnnexWorker' :: AnnexWorkerPool -> Annex a -> IO (Either SomeException a)