started wiring p2phttp into Remote.Git

but we have a cycle, ugh

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index d642cac286370108eb0834da46d6ffd065b3f3d3..65aecff526dbb3dc8b477b983878c3a0373a25bc 100644 (file)
--- 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 a1f568437120ca6abee86d58467534718f257984..f77886b060a2a4f65de553e6474535452be65d5b 100644 (file)
--- 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 (file)
index 0000000..afa8c09
--- /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 <id@joeyh.name>
+ -
+ - 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 593a930b9802f6144e324a0cb7fd2ba4df86d274..88bfc1998ee4506fd81e2ff88ee124e2c427ce60 100644 (file)
--- 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 06116a38a7e4c94f7bc00ff9c02f2bcc7a102298..a4dfd353ac6101ac45825fe5978b9af5e321afe8 100644 (file)
--- 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