lfs endpoint discovery and caching in git-lfs special remote

Git/Url.hs

@@ -11,9 +11,10 @@ module Git.Url (
 	port,
 	hostuser,
 	authority,
+	path,
 ) where
 
-import Network.URI hiding (scheme, authority)
+import Network.URI hiding (scheme, authority, path)
 
 import Common
 import Git.Types
@@ -66,6 +67,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a
 authpart a Repo { location = Url u } = a <$> uriAuthority u
 authpart _ repo = notUrl repo
 
+{- Path part of an URL repo. -}
+path :: Repo -> FilePath
+path Repo { location = Url u } = uriPath u
+path repo = notUrl repo
+
 notUrl :: Repo -> a
 notUrl repo = error $
 	"acting on local git repo " ++ repoDescribe repo ++ " not supported"

Remote/GitLFS.hs

@@ -12,18 +12,23 @@ import Types.Remote
 import Annex.Url
 import Types.Creds
 import qualified Git
+import qualified Git.Types as Git
+import qualified Git.Url
 import Config
 import Config.Cost
 import Remote.Helper.Special
 import Remote.Helper.ExportImport
 import Remote.Helper.Git
+import qualified Remote.Helper.Ssh as Ssh
 import Annex.Ssh
 import Annex.UUID
 import Utility.SshHost
 import qualified Utility.GitLFS as LFS
 
 import Control.Concurrent.STM
+import Data.String
 import qualified Data.Map as M
+import qualified Network.URI as URI
 
 remote :: RemoteType
 remote = RemoteType
@@ -37,11 +42,9 @@ remote = RemoteType
 	, importSupported = importUnsupported
 	}
 
-type LFSHandle = TVar (String, Maybe LFS.Endpoint)
-
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
-	handle <- liftIO $ newTVarIO (lfsrepo, Nothing)
+	handle <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing r gc
 	cst <- remoteCost gc expensiveRemoteCost
 	return $ Just $ specialRemote' specialcfg c
 		(simplyPrepare $ store handle)
@@ -84,9 +87,6 @@ gen r u c gc = do
 		, claimUrl = Nothing
 		, checkUrl = Nothing
 		}
-	lfsrepo = fromMaybe
-		(giveup "remote url is not configured")
-		(M.lookup "url" $ Git.config r)
 	specialcfg = (specialRemoteCfg c)
 		-- chunking would not improve git-lfs
 		{ chunkConfig = NoChunks
@@ -112,19 +112,113 @@ mySetup _ mu _ c gc = do
 	setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) repo
 	return (c'', u)
 
-store :: LFSHandle -> Storer
-store h = fileStorer $ \k src p -> undefined
+data LFSHandle = LFSHandle
+	{ downloadEndpoint :: Maybe LFS.Endpoint
+	, uploadEndpoint :: Maybe LFS.Endpoint
+	, remoteRepo :: Git.Repo
+	, remoteGitConfig :: RemoteGitConfig
+	}
 
-retrieve :: LFSHandle -> Retriever
-retrieve h = byteRetriever $ \k sink -> undefined
+discoverLFSEndpoint :: LFS.TransferRequestOperation -> LFSHandle -> Annex (Maybe LFS.Endpoint)
+discoverLFSEndpoint tro h
+	| Git.repoIsSsh r = gossh
+	| Git.repoIsHttp r = gohttp
+	| otherwise = do
+		warning "git-lfs endpoint has unsupported URI scheme"
+		return Nothing
+  where
+  	r = remoteRepo h
+	lfsrepouri = case Git.location r of
+		Git.Url u -> u
+		_ -> giveup $ "unsupported git-lfs remote location " ++ Git.repoLocation r
+	gohttp = case tro of
+		LFS.RequestDownload -> return $ LFS.guessEndpoint lfsrepouri
+		LFS.RequestUpload -> do
+			-- git-lfs does support storing over http,
+			-- but it would need prompting for http basic
+			-- authentication each time git-annex discovered
+			-- the endpoint.
+			warning "Storing content in git-lfs currently needs a ssh repository url, not http."
+			return Nothing
+	gossh = case mkSshHost <$> Git.Url.hostuser r of
+		Nothing -> do
+			warning "Unable to parse ssh url for git-lfs remote."
+			return Nothing
+		Just (Left err) -> do
+			warning err
+			return Nothing
+		Just (Right hostuser) -> do
+			let port = Git.Url.port r
+			-- Remove leading /~/ from path. That is added when
+			-- converting a scp-style repository location with
+			-- a relative path into an url, and is legal
+			-- according to git-clone(1), but github does not
+			-- support it.
+			let remotepath = if "/~/" `isPrefixOf` Git.Url.path r
+				then drop 3 (Git.Url.path r)
+				else Git.Url.path r
+			let ps = LFS.sshDiscoverEndpointCommand remotepath tro
+			-- Note that no shellEscape is done here, because
+			-- at least github's git-lfs implementation does
+			-- not allow for shell quoting.
+			let remotecmd = unwords ps
+			(sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd
+			liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case
+				Left err -> do
+					warning $ "ssh connection to git-lfs remote failed: " ++ show err
+					return Nothing
+				Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of
+					Nothing -> do
+						warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery"
+						return Nothing
+					Just endpoint -> return (Just endpoint)
+
+-- The endpoint is cached for later use.
+getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
+getLFSEndpoint tro hv = do
+	h <- liftIO $ atomically $ readTVar hv
+	case f h of
+		Just endpoint -> return (Just endpoint)
+		Nothing -> discoverLFSEndpoint tro h >>= \case
+			Just endpoint -> do
+				liftIO $ atomically $ writeTVar hv $
+					case tro of
+						LFS.RequestDownload -> 
+							h { downloadEndpoint = Just endpoint }
+						LFS.RequestUpload ->
+							h { uploadEndpoint = Just endpoint }
+				return (Just endpoint)
+			Nothing -> return Nothing
+  where
+	f = case tro of
+		LFS.RequestDownload -> downloadEndpoint
+		LFS.RequestUpload -> uploadEndpoint
+
+store :: TVar LFSHandle -> Storer
+store h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case
+	Nothing -> return False
+	Just endpoint -> do
+		liftIO $ print ("endpoint", endpoint)
+		return False
+
+retrieve :: TVar LFSHandle -> Retriever
+retrieve h = byteRetriever $ \k sink -> getLFSEndpoint LFS.RequestDownload h >>= \case
+	Nothing -> return False
+	Just endpoint -> do
+		liftIO $ print ("endpoint", endpoint)
+		return False
+
+checkKey :: TVar LFSHandle -> CheckPresent
+checkKey h key = getLFSEndpoint LFS.RequestDownload h >>= \case
+	Nothing -> giveup "unable to connect to git-lfs endpoint"
+	Just endpoint -> do
+		liftIO $ print ("endpoint", endpoint)
+		return False
 
 retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
-checkKey :: LFSHandle -> CheckPresent
-checkKey h key = undefined
-
-remove :: LFSHandle -> Remover
+remove :: TVar LFSHandle -> Remover
 remove h key = do
 	warning "git-lfs does not support removing content"
 	return False

Utility/GitLFS.hs

@@ -14,6 +14,7 @@
 module Utility.GitLFS (
 	-- * transfer requests
 	TransferRequest(..),
+	TransferRequestOperation(..),
 	TransferAdapter(..),
 	TransferRequestObject(..),
 	startTransferRequest,
@@ -303,24 +304,24 @@ parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp
 -- | Guesses the LFS endpoint from the http url of a git remote.
 --
 -- https://github.com/git-lfs/git-lfs/blob/master/docs/api/server-discovery.md
-guessEndpoint :: Url -> Maybe Endpoint
-guessEndpoint remoteurl = do
-	uri <- URI.parseURI (T.unpack remoteurl)
-	let guessedpath
+guessEndpoint :: URI.URI -> Maybe Endpoint
+guessEndpoint uri = case URI.uriScheme uri of
+	"https:" -> Just endpoint
+	"http:" -> Just endpoint
+	_ -> Nothing
+  where
+	endpoint = EndpointURI $ uri
+		{ URI.uriScheme = "https"
+		, URI.uriPath = guessedpath
+		}
+	
+	guessedpath
 		| ".git" `isSuffixOf` URI.uriPath uri =
 			URI.uriPath uri ++ "/info/lfs"
 		| ".git/" `isSuffixOf` URI.uriPath uri =
 			URI.uriPath uri ++ "info/lfs"
 		| otherwise = (droptrailing '/' (URI.uriPath uri)) ++ ".git/info/lfs"
-	let endpoint = EndpointURI $ uri
-		{ URI.uriScheme = "https"
-		, URI.uriPath = guessedpath
-		}
-	case URI.uriScheme uri of
-		"https:" -> Just endpoint
-		"http:" -> Just endpoint
-		_ -> Nothing
-  where
+	
 	droptrailing c = reverse . dropWhile (== c) . reverse
 
 -- | Makes a Request that will start the process of making a transfer to or