diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index 0c55f09a3b..5246b09302 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -16,6 +16,10 @@ import P2P.Http.Server import P2P.Http.Url import qualified P2P.Protocol as P2P import Utility.Env +import Annex.UUID +import qualified Git +import qualified Git.Construct +import qualified Annex import Servant import qualified Network.Wai.Handler.Warp as Warp @@ -25,10 +29,12 @@ import qualified Data.Map as M import Data.String cmd :: Command -cmd = noMessages $ withAnnexOptions [jobsOption] $ - command "p2phttp" SectionPlumbing - "communicate in P2P protocol over http" - paramNothing (seek <$$> optParser) +cmd = withAnnexOptions [jobsOption] $ + noMessages $ dontCheck repoExists $ + noRepo (startIO <$$> optParser) $ + command "p2phttp" SectionPlumbing + "communicate in P2P protocol over http" + paramNothing (startAnnex <$$> optParser) data Options = Options { portOption :: Maybe PortNumber @@ -44,6 +50,7 @@ data Options = Options , wideOpenOption :: Bool , proxyConnectionsOption :: Maybe Integer , clusterJobsOption :: Maybe Int + , directoryOption :: [FilePath] } optParser :: CmdParamsDesc -> Parser Options @@ -100,22 +107,41 @@ optParser _ = Options ( long "clusterjobs" <> metavar paramNumber <> help "number of concurrent node accesses per connection" )) + <*> many (strOption + ( long "directory" <> metavar paramPath + <> help "serve repositories in subdirectories of a directory" + )) -seek :: Options -> CommandSeek -seek o = getAnnexWorkerPool $ \workerpool -> - withP2PConnections workerpool - (fromMaybe 1 $ proxyConnectionsOption o) - (fromMaybe 1 $ clusterJobsOption o) - (go workerpool) - where - go workerpool servinguuids acquireconn = liftIO $ do +startAnnex :: Options -> Annex () +startAnnex o + | null (directoryOption o) = ifM ((/=) NoUUID <$> getUUID) + ( do + authenv <- liftIO getAuthEnv + st <- mkServerState o authenv + liftIO $ runServer o st + -- Run in a git repository that is not a git-annex repository. + , liftIO $ startIO o + ) + | otherwise = liftIO $ startIO o + +-- TODO --jobs option only available to startAnnex, not here, need +-- to parse it into Options for this command. +startIO :: Options -> IO () +startIO o + | null (directoryOption o) = + giveup "Use the --directory option to specify which git-annex repositories to serve." + | otherwise = do authenv <- getAuthEnv - st <- mkPerRepoServerState acquireconn workerpool $ - mkGetServerMode authenv o - let mst = P2PHttpServerState - { servedRepos = M.fromList $ - zip servinguuids (repeat st) - } + repos <- findRepos o + sts <- forM repos $ \r -> do + strd <- Annex.new r + Annex.eval strd $ mkServerState o authenv + runServer o (mconcat sts) + +runServer :: Options -> P2PHttpServerState -> IO () +runServer o mst = go `finally` serverShutdownCleanup mst + where + go = do let settings = Warp.setPort port $ Warp.setHost host $ Warp.defaultSettings case (certFileOption o, privateKeyFileOption o) of @@ -125,7 +151,6 @@ seek o = getAnnexWorkerPool $ \workerpool -> certfile (chainFileOption o) privatekeyfile Warp.runTLS tlssettings settings (p2pHttpApp mst) _ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS." - port = maybe (fromIntegral defaultP2PHttpProtocolPort) fromIntegral @@ -135,6 +160,14 @@ seek o = getAnnexWorkerPool $ \workerpool -> fromString (bindOption o) +mkServerState :: Options -> M.Map Auth P2P.ServerMode -> Annex P2PHttpServerState +mkServerState o authenv = + getAnnexWorkerPool $ + mkP2PHttpServerState + (mkGetServerMode authenv o) + (fromMaybe 1 $ proxyConnectionsOption o) + (fromMaybe 1 $ clusterJobsOption o) + mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode mkGetServerMode _ o _ Nothing | wideOpenOption o = ServerMode @@ -201,3 +234,11 @@ getAuthEnv = do case M.lookup user permmap of Nothing -> (auth, P2P.ServeReadWrite) Just perms -> (auth, perms) + +findRepos :: Options -> IO [Git.Repo] +findRepos o = do + files <- map toRawFilePath . concat + <$> mapM dirContents (directoryOption o) + map Git.Construct.newFrom . catMaybes + <$> mapM Git.Construct.checkForRepo files + diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index e3fabdd990..3a15b3e902 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -42,11 +42,28 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Control.Concurrent.Async import Data.Time.Clock.POSIX +import qualified Data.Semigroup as Sem +import Prelude data P2PHttpServerState = P2PHttpServerState { servedRepos :: M.Map UUID PerRepoServerState + , serverShutdownCleanup :: IO () } +instance Monoid P2PHttpServerState where + mempty = P2PHttpServerState + { servedRepos = mempty + , serverShutdownCleanup = noop + } + +instance Sem.Semigroup P2PHttpServerState where + a <> b = P2PHttpServerState + { servedRepos = servedRepos a <> servedRepos b + , serverShutdownCleanup = do + serverShutdownCleanup a + serverShutdownCleanup b + } + data PerRepoServerState = PerRepoServerState { acquireP2PConnection :: AcquireP2PConnection , annexWorkerPool :: AnnexWorkerPool @@ -213,13 +230,13 @@ type AcquireP2PConnection = ConnectionParams -> IO (Either ConnectionProblem P2PConnectionPair) -withP2PConnections - :: AnnexWorkerPool +mkP2PHttpServerState + :: GetServerMode -> ProxyConnectionPoolSize -> ClusterConcurrency - -> ([UUID] -> AcquireP2PConnection -> Annex a) - -> Annex a -withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do + -> AnnexWorkerPool + -> Annex P2PHttpServerState +mkP2PHttpServerState getservermode proxyconnectionpoolsize clusterconcurrency workerpool = do enableInteractiveBranchAccess myuuid <- getUUID myproxies <- M.lookup myuuid <$> getProxies @@ -233,7 +250,11 @@ withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do liftIO $ atomically $ putTMVar endv () liftIO $ wait asyncservicer let servinguuids = myuuid : map proxyRemoteUUID (maybe [] S.toList myproxies) - a servinguuids (acquireconn reqv) `finally` endit + st <- liftIO $ mkPerRepoServerState (acquireconn reqv) workerpool getservermode + return $ P2PHttpServerState + { servedRepos = M.fromList $ zip servinguuids (repeat st) + , serverShutdownCleanup = endit + } where acquireconn reqv connparams = do respvar <- newEmptyTMVarIO diff --git a/doc/git-annex-p2phttp.mdwn b/doc/git-annex-p2phttp.mdwn index 821503e533..4dd7869c92 100644 --- a/doc/git-annex-p2phttp.mdwn +++ b/doc/git-annex-p2phttp.mdwn @@ -41,10 +41,10 @@ convenient way to download the content of any key, by using the path * `--directory=path` - Serve each git-annex repository found in a directory. This does not - recurse into subdirectories. + Serve each git-annex repository found in immediate + subdirectories of a directory. - This option can be provided more than once to serve serveral directories + This option can be provided more than once to serve several directories full of git-annex repositories. New git-annex repositories can be added to the directory, and will be