diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index d642cac286..65aecff526 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -182,18 +182,6 @@ testKeepLocked = do _ <- getLine atomically $ writeTMVar keeplocked False -testCheckPresent = do - mgr <- httpManager <$> getUrlOptions - burl <- liftIO $ parseBaseUrl "http://localhost:8080/" - res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl) - (P2P.ProtocolVersion 3) - (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String))) - (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) - (B64UUID (toUUID ("cu" :: String))) - [] - Nothing - liftIO $ print res - testGet = do mgr <- httpManager <$> getUrlOptions burl <- liftIO $ parseBaseUrl "http://localhost:8080/" diff --git a/P2P/Http.hs b/P2P/Http.hs index a1f5684371..f77886b060 100644 --- a/P2P/Http.hs +++ b/P2P/Http.hs @@ -342,16 +342,16 @@ serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do Left err -> throwError $ err500 { errBody = encodeBL err } clientCheckPresent - :: ClientEnv + :: B64Key + -> ClientEnv -> ProtocolVersion - -> B64Key -> B64UUID ServerSide -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth - -> IO Bool -clientCheckPresent clientenv (ProtocolVersion ver) key su cu bypass auth = - withClientM (cli su key cu bypass auth) clientenv $ \case + -> Annex Bool +clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth = + liftIO $ withClientM (cli su key cu bypass auth) clientenv $ \case Left err -> throwM err Right (CheckPresentResult res) -> return res where diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs new file mode 100644 index 0000000000..afa8c09ca0 --- /dev/null +++ b/P2P/Http/Client.hs @@ -0,0 +1,52 @@ +{- P2P protocol over HTTP, running client actions + - + - https://git-annex.branchable.com/design/p2p_protocol_over_http/ + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module P2P.Http.Client where + +import Types +import Annex.Url + +#ifdef WITH_SERVANT +import Annex.UUID +import Types.Remote +import P2P.Protocol (ProtocolVersion(..)) +import P2P.Http.Types +import P2P.Http.Url +import Servant.Client +#endif + +p2pHttpClient + :: Remote + -> (String -> Annex a) +#ifdef WITH_SERVANT + -> (ClientEnv -> ProtocolVersion -> B64UUID ServerSide -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> Annex a) +#endif + -> Annex a +#ifdef WITH_SERVANT +p2pHttpClient rmt fallback httpaction = + case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of + Nothing -> error "internal" + Just baseurl -> do + myuuid <- getUUID + mgr <- httpManager <$> getUrlOptions + let clientenv = mkClientEnv mgr baseurl + -- TODO: try other protocol versions + -- TODO: authentication + -- TODO: catch 404 etc + httpaction clientenv + (ProtocolVersion 3) + (B64UUID (uuid rmt)) + (B64UUID myuuid) + [] + Nothing +#else +runP2PHttpClient rmt fallback = fallback "This remote uses an annex+http url, but this version of git-annex is not build with support for that." +#endif diff --git a/Remote/Git.hs b/Remote/Git.hs index 593a930b98..88bfc1998e 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -59,6 +59,10 @@ import qualified Remote.P2P import qualified Remote.Helper.P2P as P2PHelper import P2P.Address import P2P.Http.Url +import P2P.Http.Client +#ifdef WITH_SERVANT +import P2P.Http +#endif import Annex.Path import Creds import Types.NumCopies @@ -104,17 +108,21 @@ list autoinit = do proxied <- listProxied proxies rs' return (proxied++rs') where - annexurl r = remoteConfig r "annexurl" tweakurl c r = do let n = fromJust $ Git.remoteName r - case M.lookup (annexurl r) c of - Just url | not (isP2PHttpProtocolUrl (Git.fromConfigValue url)) -> + case getAnnexUrl r c of + Just url | not (isP2PHttpProtocolUrl url) -> inRepo $ \g -> Git.Construct.remoteNamed n $ - Git.Construct.fromRemoteLocation - (Git.fromConfigValue url) + Git.Construct.fromRemoteLocation url False g _ -> return r +getAnnexUrl :: Git.Repo -> M.Map Git.ConfigKey Git.ConfigValue -> Maybe String +getAnnexUrl r c = Git.fromConfigValue <$> M.lookup (annexUrlConfigKey r) c + +annexUrlConfigKey :: Git.Repo -> Git.ConfigKey +annexUrlConfigKey r = remoteConfig r "annexurl" + isGitRemoteAnnex :: Git.Repo -> Bool isGitRemoteAnnex r = "annex::" `isPrefixOf` Git.repoLocation r @@ -163,24 +171,43 @@ enableRemote Nothing _ = giveup "unable to enable git remote with no specified u - done each time git-annex is run in a way that uses remotes, unless - annex-checkuuid is false. - - - Conversely, the config of an URL remote is only read when there is no - - cached UUID value. -} + - An annex+http remote's UUID is part of the url, + - so the config does not have to be read, but it is verified that + - it matches the cached UUID. + - + - The config of other URL remotes is only read when there is no + - cached UUID value. + -} configRead :: Bool -> Git.Repo -> Annex Git.Repo configRead autoinit r = do gc <- Annex.getRemoteGitConfig r hasuuid <- (/= NoUUID) <$> getRepoUUID r annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc) - case (repoCheap r, annexignore, hasuuid) of - (_, True, _) -> return r - (True, _, _) + c <- fromRepo Git.config + case (repoCheap r, annexignore, hasuuid, p2pHttpUUID =<< parseP2PHttpUrl =<< getAnnexUrl r c) of + (_, True, _, _) -> return r + (True, _, _, _) | remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r hasuuid | otherwise -> return r - (False, _, False) -> configSpecialGitRemotes r >>= \case + (_, _, _, Just p2phttpuuid) -> getRepoUUID r >>= \case + u@(UUID {}) + | u == p2phttpuuid -> return r + | otherwise -> do + warning $ UnquotedString $ unwords + [ "Repository", Git.repoDescribe r + , "has different UUIDS in" + , Git.fromConfigKey (annexUrlConfigKey r) + , "and" + , Git.fromConfigKey (configRepoUUID r) + ] + return r + NoUUID -> storeUpdatedRemote $ + liftIO $ setUUID r p2phttpuuid + (False, _, False, _) -> configSpecialGitRemotes r >>= \case Nothing -> tryGitConfigRead autoinit r False Just r' -> return r' _ -> return r - gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs -- Remote.GitLFS may be used with a repo that is also encrypted @@ -408,10 +435,15 @@ inAnnex rmt st key = do inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool inAnnex' repo rmt st@(State connpool duc _ _ _) key + | isP2PHttp rmt = checkp2phttp | Git.repoIsHttp repo = checkhttp | Git.repoIsUrl repo = checkremote | otherwise = checklocal where + checkp2phttp = p2pHttpClient rmt giveup +#ifdef WITH_SERVANT + (clientCheckPresent key) +#endif checkhttp = do gc <- Annex.getGitConfig Url.withUrlOptionsPromptingCreds $ \uo -> @@ -926,3 +958,7 @@ listProxied proxies rs = concat <$> mapM go rs | Git.GCrypt.isEncrypted r = False | Git.repoIsLocal r || Git.repoIsLocalUnknown r = False | otherwise = isNothing (repoP2PAddress r) + +isP2PHttp :: Remote -> Bool +isP2PHttp = isJust . remoteAnnexP2PHttpUrl . gitconfig + diff --git a/git-annex.cabal b/git-annex.cabal index 06116a38a7..a4dfd353ac 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -895,6 +895,7 @@ Executable git-annex P2P.Address P2P.Annex P2P.Auth + P2P.Http.Client P2P.Http.Url P2P.IO P2P.Protocol