started wiring p2phttp into Remote.Git

but we have a cycle, ugh

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/"

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
+	-> Annex Bool
-clientCheckPresent clientenv (ProtocolVersion ver) key su cu bypass auth =
+clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
-	withClientM (cli su key cu bypass auth) clientenv $ \case
+	liftIO $ withClientM (cli su key cu bypass auth) clientenv $ \case
 		Left err -> throwM err
 		Right (CheckPresentResult res) -> return res
   where

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

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
+		case getAnnexUrl r c of
-			Just url | not (isP2PHttpProtocolUrl (Git.fromConfigValue url)) -> 
+			Just url | not (isP2PHttpProtocolUrl url) -> 
 				inRepo $ \g -> Git.Construct.remoteNamed n $
-					Git.Construct.fromRemoteLocation
+					Git.Construct.fromRemoteLocation url
-						(Git.fromConfigValue 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
+ - An annex+http remote's UUID is part of the url,
- - cached UUID value. -}
+ - 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
+	c <- fromRepo Git.config
-		(_, True, _) -> return r
+	case (repoCheap r, annexignore, hasuuid, p2pHttpUUID =<< parseP2PHttpUrl =<< getAnnexUrl r c) of
-		(True, _, _)
+		(_, 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
+

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