skeleton git-lfs special remote

This is a special remote and a git remote at the same time; git can pull
and push to it and git-annex can use it as a special remote.

Remote.Git has to check if it's configured as a git-lfs special remote
and sets it up as one if so.

Object methods not implemented yet.

Remote/Git.hs

@@ -51,6 +51,7 @@ import Remote.Helper.Messages
 import Remote.Helper.ExportImport
 import qualified Remote.Helper.Ssh as Ssh
 import qualified Remote.GCrypt
+import qualified Remote.GitLFS
 import qualified Remote.P2P
 import qualified Remote.Helper.P2P as P2PHelper
 import P2P.Address
@@ -144,6 +145,7 @@ configRead autoinit r = do
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc
 	| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc
+	| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc
 	| otherwise = case repoP2PAddress r of
 		Nothing -> do
 			st <- mkState r u gc

Remote/GitLFS.hs

@@ -0,0 +1,130 @@
+{- Using git-lfs as a remote.
+ -
+ - Copyright 2019 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Remote.GitLFS (remote, gen) where
+
+import Annex.Common
+import Types.Remote
+import Annex.Url
+import Types.Creds
+import qualified Git
+import Config
+import Config.Cost
+import Remote.Helper.Special
+import Remote.Helper.ExportImport
+import Remote.Helper.Git
+import Annex.Ssh
+import Annex.UUID
+import Utility.SshHost
+import qualified Utility.GitLFS as LFS
+
+import Control.Concurrent.STM
+import qualified Data.Map as M
+
+remote :: RemoteType
+remote = RemoteType
+	{ typename = "git-lfs"
+	-- Remote.Git takes care of enumerating git-lfs remotes too,
+	-- and will call our gen on them.
+	, enumerate = const (return [])
+	, generate = gen
+	, setup = mySetup
+	, exportSupported = exportUnsupported
+	, 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)
+	cst <- remoteCost gc expensiveRemoteCost
+	return $ Just $ specialRemote' specialcfg c
+		(simplyPrepare $ store handle)
+		(simplyPrepare $ retrieve handle)
+		(simplyPrepare $ remove handle)
+		(simplyPrepare $ checkKey handle)
+		(this cst)
+  where
+	this cst = Remote
+		{ uuid = u
+		, cost = cst
+		, name = Git.repoDescribe r
+		, storeKey = storeKeyDummy
+		, retrieveKeyFile = retreiveKeyFileDummy
+		, retrieveKeyFileCheap = retrieveCheap
+		-- content stored on git-lfs is hashed with SHA256
+		-- no matter what git-annex key it's for, and the hash
+		-- is checked on download
+		, retrievalSecurityPolicy = RetrievalAllKeysSecure
+		, removeKey = removeKeyDummy
+		, lockContent = Nothing
+		, checkPresent = checkPresentDummy
+		, checkPresentCheap = False
+		, exportActions = exportUnsupported
+		, importActions = importUnsupported
+		, whereisKey = Nothing
+		, remoteFsck = Nothing
+		, repairRepo = Nothing
+		, config = c
+		, getRepo = return r
+		, gitconfig = gc
+		, localpath = Nothing
+		, remotetype = remote
+		, availability = GloballyAvailable
+		, readonly = False
+		-- content cannot be removed from a git-lfs repo
+		, appendonly = True
+		, mkUnavailable = return Nothing
+		, getInfo = gitRepoInfo (this cst)
+		, 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
+		}
+
+mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+mySetup _ mu _ c gc = do
+	u <- maybe (liftIO genUUID) return mu
+
+	let repo = fromMaybe (giveup "Specify url=") $
+		M.lookup "url" c
+	(c', _encsetup) <- encryptionSetup c gc
+
+	-- The repo is not stored in the remote log, because the same
+	-- git-lfs repo can be accessed using different urls by different
+	-- people (eg over ssh or http).
+	--
+	-- Instead, set up remote.name.url to point to the repo,
+	-- (so it's also usable by git as a non-special remote),
+	-- and set remote.name.git-lfs = true
+	let c'' = M.delete "repo" c'
+	gitConfigSpecialRemote u c'' [("git-lfs", "true")]
+	setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) repo
+	return (c'', u)
+
+store :: LFSHandle -> Storer
+store h = fileStorer $ \k src p -> undefined
+
+retrieve :: LFSHandle -> Retriever
+retrieve h = byteRetriever $ \k sink -> undefined
+
+retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
+
+checkKey :: LFSHandle -> CheckPresent
+checkKey h key = undefined
+
+remove :: LFSHandle -> Remover
+remove h key = do
+	warning "git-lfs does not support removing content"
+	return False

Remote/List.hs

@@ -40,6 +40,7 @@ import qualified Remote.Adb
 import qualified Remote.Tahoe
 import qualified Remote.Glacier
 import qualified Remote.Ddar
+import qualified Remote.GitLFS
 import qualified Remote.Hook
 import qualified Remote.External
 
@@ -63,6 +64,7 @@ remoteTypes = map adjustExportImportRemoteType
 	, Remote.Tahoe.remote
 	, Remote.Glacier.remote
 	, Remote.Ddar.remote
+	, Remote.GitLFS.remote
 	, Remote.Hook.remote
 	, Remote.External.remote
 	]

Types/GitConfig.hs

@@ -263,6 +263,7 @@ data RemoteGitConfig = RemoteGitConfig
 	, remoteAnnexAndroidDirectory :: Maybe FilePath
 	, remoteAnnexAndroidSerial :: Maybe String
 	, remoteAnnexGCrypt :: Maybe String
+	, remoteAnnexGitLFS :: Bool
 	, remoteAnnexDdarRepo :: Maybe String
 	, remoteAnnexHookType :: Maybe String
 	, remoteAnnexExternalType :: Maybe String
@@ -321,6 +322,7 @@ extractRemoteGitConfig r remotename = do
 		, remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory"
 		, remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial"
 		, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
+		, remoteAnnexGitLFS = getbool "git-lfs" False
 		, remoteAnnexDdarRepo = getmaybe "ddarrepo"
 		, remoteAnnexHookType = notempty $ getmaybe "hooktype"
 		, remoteAnnexExternalType = notempty $ getmaybe "externaltype"

doc/git-annex.mdwn

@@ -1619,6 +1619,13 @@ Here are all the supported configuration settings.
   If the gcrypt remote is accessible over ssh and has git-annex-shell
   available to manage it, it's set to "shell".
 
+* `remote.<name>.annex-git-lfs`
+
+  Used to identify git-lfs special remotes.
+  Normally this is automatically set up by `git annex initremote`.
+
+  It is set to "true" if this is a git-lfs remote.
+
 * `remote.<name>.annex-hooktype`, `remote.<name>.annex-externaltype`
 
   Used by hook special remotes and external special remotes to record

git-annex.cabal

@@ -931,6 +931,7 @@ Executable git-annex
     Remote.External.Types
     Remote.GCrypt
     Remote.Git
+    Remote.GitLFS
     Remote.Glacier
     Remote.Helper.AWS
     Remote.Helper.Chunked
@@ -1039,6 +1040,7 @@ Executable git-annex
     Utility.FileSystemEncoding
     Utility.Format
     Utility.FreeDesktop
+    Utility.GitLFS
     Utility.Glob
     Utility.Gpg
     Utility.Hash