external backends wip

It's able to start them up, the only thing not implemented is generating
and verifying keys. And, the key translation for HasExt.

Annex/Content.hs

@@ -349,12 +349,13 @@ getViaTmpFromDisk rsp v key action = checkallowed $ do
 	-- RetrievalSecurityPolicy would cause verification to always fail.
 	checkallowed a = case rsp of
 		RetrievalAllKeysSecure -> a
-		RetrievalVerifiableKeysSecure
+		RetrievalVerifiableKeysSecure -> ifM (Backend.isVerifiable key)
-			| Backend.isVerifiable key -> a
+			( a
-			| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
+			, ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
 				( a
 				, warnUnverifiableInsecure key >> return False
 				)
+			)
 
 {- Verifies that a file is the expected content of a key.
  -
@@ -373,12 +374,13 @@ getViaTmpFromDisk rsp v key action = checkallowed $ do
 verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool
 verifyKeyContent rsp v verification k f = case (rsp, verification) of
 	(_, Verified) -> return True
-	(RetrievalVerifiableKeysSecure, _)
+	(RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k)
-		| Backend.isVerifiable k -> verify
+		( verify
-		| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
+		, ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
 			( verify
 			, warnUnverifiableInsecure k >> return False
 			)
+		)
 	(_, UnVerified) -> ifM (shouldVerify v)
 		( verify
 		, return True
@@ -391,9 +393,11 @@ verifyKeyContent rsp v verification k f = case (rsp, verification) of
 		Just size -> do
 			size' <- liftIO $ catchDefaultIO 0 $ getFileSize f
 			return (size' == size)
-	verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (fromKey keyVariety k) of
+	verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
 		Nothing -> return True
-		Just verifier -> verifier k f
+		Just b -> case Types.Backend.verifyKeyContent b of
+			Nothing -> return True
+			Just verifier -> verifier k f
 
 warnUnverifiableInsecure :: Key -> Annex ()
 warnUnverifiableInsecure k = warning $ unwords
@@ -512,12 +516,13 @@ moveAnnex key src = ifM (checkSecureHashes' key)
 	alreadyhave = liftIO $ removeFile src
 
 checkSecureHashes :: Key -> Annex (Maybe String)
-checkSecureHashes key
+checkSecureHashes key = ifM (Backend.isCryptographicallySecure key)
-	| Backend.isCryptographicallySecure key = return Nothing
+	( return Nothing
-	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
+	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
 		( return $ Just $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
 		, return Nothing
 		)
+	)
 
 checkSecureHashes' :: Key -> Annex Bool
 checkSecureHashes' key = checkSecureHashes key >>= \case

Annex/ExternalAddonProcess.hs

@@ -13,8 +13,8 @@ import Git.Env
 import Utility.Shell
 import Messages.Progress
 
-import Control.Concurrent.STM
 import Control.Concurrent.Async
+import System.Log.Logger (debugM)
 
 data ExternalAddonProcess = ExternalAddonProcess
 	{ externalSend :: Handle
@@ -23,6 +23,7 @@ data ExternalAddonProcess = ExternalAddonProcess
 	-- immediately.
 	, externalShutdown :: Bool -> IO ()
 	, externalPid :: ExternalAddonPID
+	, externalProgram :: String
 	}
 
 type ExternalAddonPID = Int
@@ -31,8 +32,8 @@ data ExternalAddonStartError
 	= ProgramNotInstalled String
 	| ProgramFailure String
 
-startExternalAddonProcess :: String -> TVar ExternalAddonPID-> Annex (Either ExternalAddonStartError ExternalAddonProcess)
+startExternalAddonProcess :: String -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess)
-startExternalAddonProcess basecmd pidvar = do
+startExternalAddonProcess basecmd pid = do
 	errrelayer <- mkStderrRelayer
 	g <- Annex.gitRepo
 	cmdpath <- liftIO $ searchPath basecmd
@@ -47,16 +48,12 @@ startExternalAddonProcess basecmd pidvar = do
 			}
 		p <- propgit g basep
 		tryNonAsync (createProcess p) >>= \case
-			Right v -> (Right <$> started errrelayer v)
+			Right v -> (Right <$> started cmd errrelayer v)
 				`catchNonAsync` const (runerr cmdpath)
 			Left _ -> runerr cmdpath
 	
-	started errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
+	started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
 		stderrelay <- async $ errrelayer herr
-		pid <- atomically $ do
-			n <- succ <$> readTVar pidvar
-			writeTVar pidvar n
-			return n
 		let shutdown forcestop = do
 			cancel stderrelay
 			if forcestop
@@ -71,8 +68,9 @@ startExternalAddonProcess basecmd pidvar = do
 			, externalReceive = hout
 			, externalPid = pid
 			, externalShutdown = shutdown
+			, externalProgram = cmd
 			}
-	started _ _ = giveup "internal"
+	started _ _ _ = giveup "internal"
 
 	propgit g p = do
 		environ <- propGitEnv g
@@ -85,3 +83,11 @@ startExternalAddonProcess basecmd pidvar = do
 		path <- intercalate ":" <$> getSearchPath
 		return $ Left $ ProgramNotInstalled $
 			"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"
+
+protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO ()
+protocolDebug external sendto line = debugM "external" $ unwords
+	[ externalProgram external ++ 
+		"[" ++ show (externalPid external) ++ "]"
+	, if sendto then "<--" else "-->"
+	, line
+	]

Annex/Transfer.hs

@@ -177,14 +177,15 @@ runTransfer' ignorelock t afile retrydecider transferaction = enteringStage Tran
  - tend to be configured to reject it, so Upload is also prevented.
  -}
 checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v
-checkSecureHashes t a
+checkSecureHashes t a = ifM (isCryptographicallySecure (transferKey t))
-	| isCryptographicallySecure (transferKey t) = a
+	( a
-	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
+	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
 		( do
 			warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"
 			return observeFailure
 		, a
 		)
+	)
   where
 	variety = fromKey keyVariety (transferKey t)
 

Assistant/Upgrade.hs

@@ -117,7 +117,7 @@ distributionDownloadComplete d dest cleanup t
 	| otherwise = cleanup
   where
 	k = mkKey $ const $ distributionKey d
-	fsckit f = case Backend.maybeLookupBackendVariety (fromKey keyVariety k) of
+	fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
 		Nothing -> return $ Just f
 		Just b -> case Types.Backend.verifyKeyContent b of
 			Nothing -> return $ Just f

Backend.hs

@@ -6,12 +6,13 @@
  -}
 
 module Backend (
-	list,
+	builtinList,
 	defaultBackend,
 	genKey,
 	getBackend,
 	chooseBackend,
 	lookupBackendVariety,
+	lookupBuiltinBackendVariety,
 	maybeLookupBackendVariety,
 	isStableKey,
 	isCryptographicallySecure,
@@ -26,16 +27,18 @@ import Types.KeySource
 import qualified Types.Backend as B
 import Utility.Metered
 
--- When adding a new backend, import it here and add it to the list.
+-- When adding a new backend, import it here and add it to the builtinList.
 import qualified Backend.Hash
 import qualified Backend.WORM
 import qualified Backend.URL
+import qualified Backend.External
 
 import qualified Data.Map as M
 import qualified Data.ByteString.Char8 as S8
 
-list :: [Backend]
+{- Build-in backends. Does not include externals. -}
-list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends
+builtinList :: [Backend]
+builtinList = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends
 
 {- Backend to use by default when generating a new key. -}
 defaultBackend :: Annex Backend
@@ -44,9 +47,9 @@ defaultBackend = maybe cache return =<< Annex.getState Annex.backend
 	cache = do
 		n <- maybe (annexBackend <$> Annex.getGitConfig) (return . Just)
 			=<< Annex.getState Annex.forcebackend
-		let b = case n of
+		b <- case n of
 			Just name | valid name -> lookupname name
-			_ -> Prelude.head list
+			_ -> pure (Prelude.head builtinList)
 		Annex.changeState $ \s -> s { Annex.backend = Just b }
 		return b
 	valid name = not (null name)
@@ -72,12 +75,16 @@ genKey source meterupdate preferredbackend = do
 		| otherwise = c
 
 getBackend :: FilePath -> Key -> Annex (Maybe Backend)
-getBackend file k = case maybeLookupBackendVariety (fromKey keyVariety k) of
+getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
 	Just backend -> return $ Just backend
 	Nothing -> do
-		warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ ")"
+		warning $ "skipping " ++ file ++ " (" ++ unknownBackendVarietyMessage (fromKey keyVariety k) ++ ")"
 		return Nothing
 
+unknownBackendVarietyMessage :: KeyVariety -> String
+unknownBackendVarietyMessage v =
+	"unknown backend " ++ decodeBS (formatKeyVariety v)
+
 {- Looks up the backend that should be used for a file.
  - That can be configured on a per-file basis in the gitattributes file,
  - or forced with --backend. -}
@@ -85,29 +92,38 @@ chooseBackend :: FilePath -> Annex (Maybe Backend)
 chooseBackend f = Annex.getState Annex.forcebackend >>= go
   where
 	go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS
-		<$> checkAttr "annex.backend" f
+		=<< checkAttr "annex.backend" f
 	go (Just _) = Just <$> defaultBackend
 
 {- Looks up a backend by variety. May fail if unsupported or disabled. -}
-lookupBackendVariety :: KeyVariety -> Backend
+lookupBackendVariety :: KeyVariety -> Annex Backend
-lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v
+lookupBackendVariety v = fromMaybe (giveup (unknownBackendVarietyMessage v))
-  where
+	<$> maybeLookupBackendVariety v
-	unknown = giveup $ "unknown backend " ++ decodeBS (formatKeyVariety v)
 
-maybeLookupBackendVariety :: KeyVariety -> Maybe Backend
+lookupBuiltinBackendVariety :: KeyVariety -> Backend
-maybeLookupBackendVariety v = M.lookup v varietyMap
+lookupBuiltinBackendVariety v = fromMaybe (giveup (unknownBackendVarietyMessage v)) $
+	maybeLookupBuiltinBackendVariety v
+
+maybeLookupBackendVariety :: KeyVariety -> Annex (Maybe Backend)
+maybeLookupBackendVariety (ExternalKey s hasext) =
+	Just <$> Backend.External.makeBackend s hasext
+maybeLookupBackendVariety v = 
+	pure $ M.lookup v varietyMap
+
+maybeLookupBuiltinBackendVariety :: KeyVariety -> Maybe Backend
+maybeLookupBuiltinBackendVariety v = M.lookup v varietyMap
 
 varietyMap :: M.Map KeyVariety Backend
-varietyMap = M.fromList $ zip (map B.backendVariety list) list
+varietyMap = M.fromList $ zip (map B.backendVariety builtinList) builtinList
 
-isStableKey :: Key -> Bool
+isStableKey :: Key -> Annex Bool
 isStableKey k = maybe False (`B.isStableKey` k) 
-	(maybeLookupBackendVariety (fromKey keyVariety k))
+	<$> maybeLookupBackendVariety (fromKey keyVariety k)
 
-isCryptographicallySecure :: Key -> Bool
+isCryptographicallySecure :: Key -> Annex Bool
 isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k)
-	(maybeLookupBackendVariety (fromKey keyVariety k))
+	<$> maybeLookupBackendVariety (fromKey keyVariety k)
 
-isVerifiable :: Key -> Bool
+isVerifiable :: Key -> Annex Bool
-isVerifiable k = maybe False (isJust . B.verifyKeyContent)
+isVerifiable k = maybe False (isJust . B.verifyKeyContent) 
-	(maybeLookupBackendVariety (fromKey keyVariety k))
+	<$> maybeLookupBackendVariety (fromKey keyVariety k)

Backend/External.hs

@@ -0,0 +1,290 @@
+{- git-annex external backend
+ -
+ - Copyright 2020 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Backend.External (makeBackend) where
+
+import Annex.Common
+import Annex.ExternalAddonProcess
+import Types.Key
+import Types.Backend
+import Types.KeySource
+import Utility.Metered
+import qualified Utility.SimpleProtocol as Proto
+
+import qualified Data.ByteString as S
+import qualified Data.Map.Strict as M
+import Control.Concurrent
+import System.IO.Unsafe (unsafePerformIO)
+
+newtype ExternalBackendName = ExternalBackendName S.ByteString
+	deriving (Show, Eq, Ord)
+
+-- Makes Backend representing an external backend of any type.
+-- If the program is not available or doesn't work, makes a Backend
+-- that cannot generate or verify keys, but that still lets the keys be
+-- basically used.
+makeBackend :: S.ByteString -> HasExt -> Annex Backend
+makeBackend bname hasext = withExternalState ebname $ \st -> do
+	withExternalAddon st (pure unavailbackend) $ \_ext -> do
+		canverify <- handleRequest st CANVERIFY (pure False) $ \case
+			CANVERIFY_YES -> result True
+			CANVERIFY_NO -> result False
+			_ -> Nothing
+		isstable <- handleRequest st ISSTABLE (pure False) $ \case
+			ISSTABLE_YES -> result True
+			ISSTABLE_NO -> result False
+			_ -> Nothing
+		iscryptographicallysecure <- handleRequest st ISCRYPTOGRAPHICALLYSECURE (pure False) $ \case
+			ISCRYPTOGRAPHICALLYSECURE_YES -> result True
+			ISCRYPTOGRAPHICALLYSECURE_NO -> result False
+			_ -> Nothing
+		return $ Backend
+			{ backendVariety = ExternalKey bname hasext
+			, genKey = Just $ genKeyExternal ebname
+			, verifyKeyContent = if canverify
+				then Just $ verifyKeyContentExternal ebname
+				else Nothing
+			, canUpgradeKey = Nothing
+			, fastMigrate = Nothing
+			, isStableKey = const isstable
+			, isCryptographicallySecure = const iscryptographicallysecure
+			}
+  where
+	ebname = ExternalBackendName bname
+	unavailbackend = Backend
+		{ backendVariety = ExternalKey bname hasext
+		, genKey = Nothing
+		, verifyKeyContent = Nothing
+		, canUpgradeKey = Nothing
+		, fastMigrate = Nothing
+		, isStableKey = const False
+		, isCryptographicallySecure = const False
+		}
+
+genKeyExternal :: ExternalBackendName -> KeySource -> MeterUpdate -> Annex Key
+genKeyExternal bname ks p = error "TODO"
+
+verifyKeyContentExternal :: ExternalBackendName -> Key -> FilePath -> Annex Bool
+verifyKeyContentExternal bname k f = error "TODO"
+
+-- State about a running external backend program.
+data ExternalState = ExternalState
+	{ externalAddonProcess :: Either ExternalAddonStartError ExternalAddonProcess
+	}
+
+handleRequest :: ExternalState -> Request -> Annex a -> ResponseHandler a -> Annex a
+handleRequest st req whenunavail responsehandler =
+	withExternalAddon st whenunavail $ \p -> do
+		sendMessage p req
+		receiveResponse p responsehandler (Just . handleAsyncMessage)
+  where
+	handleAsyncMessage (ERROR err) = do
+		warning ("external special remote error: " ++ err)
+		whenunavail
+
+withExternalAddon :: ExternalState -> a -> (ExternalAddonProcess -> a) -> a
+withExternalAddon st whenunavail a = case externalAddonProcess st of
+	Right addon -> a addon
+	Left _ -> whenunavail
+
+sendMessage :: Proto.Sendable m => ExternalAddonProcess -> m -> Annex ()
+sendMessage p m = liftIO $ do
+	protocolDebug p True line
+	hPutStrLn (externalSend p) line
+	hFlush (externalSend p)
+  where
+	line = unwords $ Proto.formatMessage m
+
+{- A response handler can yeild a result, or it can request that another
+ - message be consumed from the external. -}
+data ResponseHandlerResult a
+	= Result a
+	| GetNextMessage (ResponseHandler a)
+
+type ResponseHandler a = Response -> Maybe (Annex (ResponseHandlerResult a))
+
+result :: a -> Maybe (Annex (ResponseHandlerResult a))
+result = Just . return . Result
+
+{- Waits for a message from the external backend, and passes it to the
+ - apppropriate handler. 
+ -
+ - If the handler returns Nothing, this is a protocol error.
+ -}
+receiveResponse
+	:: ExternalAddonProcess
+	-> ResponseHandler a
+	-> (AsyncMessage -> Maybe (Annex a))
+	-> Annex a
+receiveResponse p handleresponse handleasync =
+	go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive p)
+  where
+	go Nothing = protocolError False ""
+	go (Just s) = do
+		liftIO $ protocolDebug p False s
+		case Proto.parseMessage s :: Maybe Response of
+			Just resp -> case handleresponse resp of
+				Nothing -> protocolError True s
+				Just callback -> callback >>= \case
+					Result a -> return a
+					GetNextMessage handleresponse' ->
+						receiveResponse p handleresponse' handleasync
+			Nothing -> case Proto.parseMessage s :: Maybe AsyncMessage of
+				Just msg -> maybe (protocolError True s) id (handleasync msg)
+				Nothing -> protocolError False s
+
+	protocolError parsed s = giveup $ "external backend protocol error, unexpectedly received \"" ++ s ++ "\" " ++
+		if parsed
+			then "(message not allowed at this time)"
+			else "(unable to parse message)"
+
+-- Information about pools of of running external backends that are
+-- available to use is stored in this global.
+{-# NOINLINE poolVar #-}
+poolVar :: MVar (M.Map ExternalBackendName (ExternalAddonPID, [ExternalState]))
+poolVar = unsafePerformIO $ newMVar M.empty
+
+-- Starts a new instance of an external backend.
+-- Does not add it to the poolVar; caller should add it once it's done
+-- using it.
+newExternalState :: ExternalBackendName -> ExternalAddonPID -> Annex ExternalState
+newExternalState (ExternalBackendName name) pid = do
+	st <- startExternalAddonProcess basecmd pid
+	st' <- case st of
+		Left (ProgramNotInstalled msg) -> warnonce msg >> return st
+		Left (ProgramFailure msg) -> warnonce msg >> return st
+		Right p -> do
+			sendMessage p GETVERSION
+			v <- receiveResponse p
+				(\resp -> case resp of
+					VERSION v -> result v
+					_ -> Nothing
+				)
+				(const Nothing)
+			if v `notElem` supportedProtocolVersions
+				then do
+					warnonce (basecmd ++ " uses an unsupported version of the external backend protocol")
+					return $ Left (ProgramFailure "bad protocol version")
+				else return (Right p)
+	return $ ExternalState { externalAddonProcess = st' }
+  where
+	basecmd = "git-annex-backend-X" ++ decodeBS' name
+	warnonce msg = when (pid == 1) $
+		warning msg
+
+-- Runs an action with an ExternalState, starting a new external backend
+-- process if necessary. It is returned to the pool once the action
+-- finishes successfully. On exception, it's shut down.
+withExternalState :: ExternalBackendName -> (ExternalState -> Annex a) -> Annex a
+withExternalState bname a = do
+	st <- get
+	r <- a st `onException` shutdown st
+	put st -- only when no exception is thrown
+	return r
+  where
+	get = do
+		m <- liftIO $ takeMVar poolVar
+		case fromMaybe (1, []) (M.lookup bname m) of
+			(pid, []) -> do
+				let m' = M.insert bname (succ pid, []) m
+				liftIO $ putMVar poolVar m'
+				newExternalState bname pid
+			(pid, (st:rest)) -> do
+				let m' = M.insert bname (pid, rest) m
+				liftIO $ putMVar poolVar m'
+				return st
+	put st = liftIO $ modifyMVar_ poolVar $
+		pure . M.adjust (\(pid, l) -> (pid, st:l)) bname
+	shutdown st = liftIO $
+		withExternalAddon st noop (flip externalShutdown False)
+
+-- This is a key as seen by the protocol consumer. When the "E" variant
+-- of the external backend is in use, it does not include an extension.
+-- And it's assumed not to contain spaces or newlines, or anything besides
+-- ascii alphanumerics, because the protocol does not allow keys containing
+-- such things.
+newtype ProtoKey = ProtoKey Key
+	deriving (Show)
+
+instance Proto.Serializable ProtoKey where
+	serialize (ProtoKey k) = Proto.serialize k
+	deserialize = fmap ProtoKey . Proto.deserialize
+
+data Request
+	= GETVERSION
+	| CANVERIFY
+	| ISSTABLE
+	| ISCRYPTOGRAPHICALLYSECURE
+	| GENKEY FilePath
+	| VERIFYKEYCONTENT ProtoKey FilePath
+	deriving (Show)
+
+data Response
+	= VERSION ProtocolVersion
+	| CANVERIFY_YES
+	| CANVERIFY_NO
+	| ISSTABLE_YES
+	| ISSTABLE_NO
+	| ISCRYPTOGRAPHICALLYSECURE_YES
+	| ISCRYPTOGRAPHICALLYSECURE_NO
+	| GENKEY_SUCCESS ProtoKey
+	| GENKEY_FAILURE ErrorMsg
+	| VERIFYKEYCONTENT_SUCCESS
+	| VERIFYKEYCONTENT_FAILURE
+	| PROGRESS BytesProcessed
+	| DEBUG String
+	deriving (Show)
+
+data AsyncMessage
+	= ERROR ErrorMsg
+	deriving (Show)
+
+type ErrorMsg = String
+
+newtype ProtocolVersion = ProtocolVersion Int
+	deriving (Show, Eq)
+
+supportedProtocolVersions :: [ProtocolVersion]
+supportedProtocolVersions = [ProtocolVersion 1]
+
+instance Proto.Serializable ProtocolVersion where
+	serialize (ProtocolVersion n) = show n
+	deserialize = ProtocolVersion <$$> readish
+
+instance Proto.Sendable AsyncMessage where
+	formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ]
+
+instance Proto.Receivable AsyncMessage where
+	parseCommand "ERROR" = Proto.parse1 ERROR
+	parseCommand _ = Proto.parseFail
+
+instance Proto.Sendable Request where
+	formatMessage GETVERSION = ["GETVERSION"]
+	formatMessage CANVERIFY = ["CANVERIFY"]
+	formatMessage ISSTABLE = ["ISSTABLE"]
+	formatMessage ISCRYPTOGRAPHICALLYSECURE = ["ISCRYPTOGRAPHICALLYSECURE"]
+	formatMessage (GENKEY file) = ["GENKEY", Proto.serialize file]
+	formatMessage (VERIFYKEYCONTENT key file) =
+		["VERIFYKEYCONTENT", Proto.serialize key, Proto.serialize file]
+
+instance Proto.Receivable Response where
+	parseCommand "VERSION" = Proto.parse1 VERSION
+	parseCommand "CANVERIFY-YES" = Proto.parse0 CANVERIFY_YES
+	parseCommand "CANVERIFY-NO" = Proto.parse0 CANVERIFY_NO
+	parseCommand "ISSTABLE-YES" = Proto.parse0 ISSTABLE_YES
+	parseCommand "ISSTABLE-NO" = Proto.parse0 ISSTABLE_NO
+	parseCommand "ISCRYPTOGRAPHICALLYSECURE-YES" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_YES
+	parseCommand "ISCRYPTOGRAPHICALLYSECURE-NO" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_NO
+	parseCommand "GENKEY-SUCCESS" = Proto.parse1 GENKEY_SUCCESS
+	parseCommand "GENKEY-FAILURE" = Proto.parse1 GENKEY_FAILURE
+	parseCommand "VERIFYKEYCONTENT-SUCCESS" = Proto.parse0 VERIFYKEYCONTENT_SUCCESS
+	parseCommand "VERIFYKEYCONTENT-FAILURE" = Proto.parse0 VERIFYKEYCONTENT_FAILURE
+	parseCommand "PROGRESS" = Proto.parse1 PROGRESS
+	parseCommand "DEBUG" = Proto.parse1 DEBUG
+	parseCommand _ = Proto.parseFail

CmdLine/GitAnnex/Options.hs

@@ -440,4 +440,4 @@ completeRemotes = completer $ mkCompleter $ \input -> do
 		
 completeBackends :: HasCompleter f => Mod f a
 completeBackends = completeWith $
-	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.list
+	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.builtinList

Command/Fsck.hs

@@ -199,7 +199,7 @@ performRemote key afile backend numcopies remote =
 
 startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart
 startKey from inc (key, ai) numcopies =
-	case Backend.maybeLookupBackendVariety (fromKey keyVariety key) of
+	Backend.maybeLookupBackendVariety (fromKey keyVariety key) >>= \case
 		Nothing -> stop
 		Just backend -> runFsck inc ai key $
 			case from of
@@ -261,7 +261,7 @@ verifyLocationLog key keystatus ai = do
 	 - insecure hash is present. This should only be able to happen
 	 - if the repository already contained the content before the
 	 - config was set. -}
-	when (present && not (Backend.isCryptographicallySecure key)) $
+	whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
 		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
 			warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
 

Command/Smudge.hs

@@ -131,7 +131,10 @@ clean file = do
 		-- Look up the backend that was used for this file
 		-- before, so that when git re-cleans a file its
 		-- backend does not change.
-		let oldbackend = maybe Nothing (maybeLookupBackendVariety . fromKey keyVariety) oldkey
+		oldbackend <- maybe
+			(pure Nothing)
+			(maybeLookupBackendVariety . fromKey keyVariety)
+			oldkey
 		-- Can't restage associated files because git add
 		-- runs this and has the index locked.
 		let norestage = Restage False

Command/TestRemote.hs

@@ -288,7 +288,7 @@ test runannex mkr mkk =
 			Nothing -> return True
 		runannex a' @? "failed"
 	present r k b = (== Right b) <$> Remote.hasKey r k
-	fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of
+	fsck _ k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
 		Nothing -> return True
 		Just b -> case Types.Backend.verifyKeyContent b of
 			Nothing -> return True

Command/Version.hs

@@ -59,7 +59,8 @@ showPackageVersion = do
 	vinfo "build flags" $ unwords buildFlags
 	vinfo "dependency versions" $ unwords dependencyVersions
 	vinfo "key/value backends" $ unwords $
-		map (decodeBS . formatKeyVariety . B.backendVariety) Backend.list
+		map (decodeBS . formatKeyVariety . B.backendVariety) Backend.builtinList
+		++ ["X*"]
 	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes
 	vinfo "operating system" $ unwords [os, arch]
 	vinfo "supported repository versions" $

Limit.hs

@@ -306,7 +306,7 @@ addSecureHash :: Annex ()
 addSecureHash = addLimit $ Right limitSecureHash
 
 limitSecureHash :: MatchFiles Annex
-limitSecureHash _ = checkKey $ pure . isCryptographicallySecure
+limitSecureHash _ = checkKey isCryptographicallySecure
 
 {- Adds a limit to skip files that are too large or too small -}
 addLargerThan :: String -> Annex ()

Remote/External.hs

@@ -185,7 +185,7 @@ externalSetup _ mu _ c gc = do
 			-- error out if the user provided an unexpected config.
 			_ <- either giveup return . parseRemoteConfig c' 
 				=<< strictRemoteConfigParser external
-			handleRequest external INITREMOTE Nothing $ \resp -> case resp of
+			handleRequest external INITREMOTE Nothing $ \case
 				INITREMOTE_SUCCESS -> result ()
 				INITREMOTE_FAILURE errmsg -> Just $ giveup $
 					respErrorMessage "INITREMOTE" errmsg
@@ -381,7 +381,7 @@ handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key
 handleRequestExport external loc mkreq k mp responsehandler = do
 	withExternalState external $ \st -> do
 		checkPrepared st external
-		sendMessage st external (EXPORT loc)
+		sendMessage st (EXPORT loc)
 	handleRequestKey external mkreq k mp responsehandler
 
 handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a
@@ -392,7 +392,7 @@ handleRequest' st external req mp responsehandler
 	| otherwise = go
   where
 	go = do
-		sendMessage st external req
+		sendMessage st req
 		loop
 	loop = receiveMessage st external responsehandler
 		(\rreq -> Just $ handleRemoteRequest rreq >> loop)
@@ -489,8 +489,8 @@ handleRequest' st external req mp responsehandler
 
 	handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err
 
-	send = sendMessage st external
+	send = sendMessage st
-	senderror = sendMessage st external . ERROR 
+	senderror = sendMessage st . ERROR 
 
 	credstorage setting u = CredPairStorage
 		{ credPairFile = base
@@ -503,9 +503,9 @@ handleRequest' st external req mp responsehandler
 	withurl mk uri = handleRemoteRequest $ mk $
 		setDownloader (show uri) OtherDownloader
 
-sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()
+sendMessage :: Sendable m => ExternalState -> m -> Annex ()
-sendMessage st external m = liftIO $ do
+sendMessage st m = liftIO $ do
-	protocolDebug external st True line
+	protocolDebug (externalAddonProcess st) True line
 	hPutStrLn h line
 	hFlush h
   where
@@ -513,7 +513,7 @@ sendMessage st external m = liftIO $ do
 	h = externalSend (externalAddonProcess st)
 
 {- A response handler can yeild a result, or it can request that another
- - message be consumed from the external result. -}
+ - message be consumed from the external. -}
 data ResponseHandlerResult a
 	= Result a
 	| GetNextMessage (ResponseHandler a)
@@ -539,7 +539,7 @@ receiveMessage st external handleresponse handlerequest handleasync =
   where
 	go Nothing = protocolError False ""
 	go (Just s) = do
-		liftIO $ protocolDebug external st False s
+		liftIO $ protocolDebug (externalAddonProcess st) False s
 		case parseMessage s :: Maybe Response of
 			Just resp -> case handleresponse resp of
 				Nothing -> protocolError True s
@@ -557,14 +557,6 @@ receiveMessage st external handleresponse handlerequest handleasync =
 			then "(command not allowed at this time)"
 			else "(unable to parse command)"
 
-protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
-protocolDebug external st sendto line = debugM "external" $ unwords
-	[ externalRemoteProgram (externalType external) ++ 
-		"[" ++ show (externalPid (externalAddonProcess st)) ++ "]"
-	, if sendto then "<--" else "-->"
-	, line
-	]
-
 {- While the action is running, the ExternalState provided to it will not
  - be available to any other calls.
  -
@@ -600,8 +592,12 @@ withExternalState external a = do
 {- Starts an external remote process running, and checks VERSION and
  - exchanges EXTENSIONS. -}
 startExternal :: External -> Annex ExternalState
-startExternal external =
+startExternal external = do
-	startExternalAddonProcess basecmd (externalLastPid external) >>= \case
+	pid <- liftIO $ atomically $ do
+		n <- succ <$> readTVar (externalLastPid external)
+		writeTVar (externalLastPid external) n
+		return n
+	startExternalAddonProcess basecmd pid >>= \case
 		Left (ProgramFailure err) -> giveup err
 		Left (ProgramNotInstalled err) ->
 			case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of
@@ -626,13 +622,13 @@ startExternal external =
 			startproto st
 			return st
   where
-	basecmd = externalRemoteProgram $ externalType external
+	basecmd = "git-annex-remote-" ++ externalType external
 	startproto st = do
 		receiveMessage st external
 			(const Nothing)
-			(checkVersion st external)
+			(checkVersion st)
 			(const Nothing)
-		sendMessage st external (EXTENSIONS supportedExtensionList)
+		sendMessage st (EXTENSIONS supportedExtensionList)
 		-- It responds with a EXTENSIONS_RESPONSE; that extensions
 		-- list is reserved for future expansion. UNSUPPORTED_REQUEST
 		-- is also accepted.
@@ -650,15 +646,12 @@ stopExternal external = liftIO $ do
 	l <- atomically $ swapTVar (externalState external) []
 	mapM_ (flip (externalShutdown . externalAddonProcess) False) l
 
-externalRemoteProgram :: ExternalType -> String
+checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ())
-externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype
+checkVersion st (VERSION v) = Just $
-
-checkVersion :: ExternalState -> External -> RemoteRequest -> Maybe (Annex ())
-checkVersion st external (VERSION v) = Just $
 	if v `elem` supportedProtocolVersions
 		then noop
-		else sendMessage st external (ERROR "unsupported VERSION")
+		else sendMessage st (ERROR "unsupported VERSION")
-checkVersion _ _ _ = Nothing
+checkVersion _ _ = Nothing
 
 {- If repo has not been prepared, sends PREPARE.
  -

Remote/External/Types.hs

@@ -375,10 +375,6 @@ instance Proto.Serializable Availability where
 	deserialize "LOCAL" = Just LocallyAvailable
 	deserialize _ = Nothing
 
-instance Proto.Serializable BytesProcessed where
-	serialize (BytesProcessed n) = show n
-	deserialize = BytesProcessed <$$> readish
-
 instance Proto.Serializable [(URLString, Size, FilePath)] where
 	serialize = unwords . map go
 	  where

Remote/Helper/Chunked.hs

@@ -120,10 +120,13 @@ storeChunks
 	-> Annex ()
 storeChunks u chunkconfig encryptor k f p storer checker = 
 	case chunkconfig of
-		(UnpaddedChunks chunksize) | isStableKey k -> do
+		(UnpaddedChunks chunksize) -> ifM (isStableKey k)
-			h <- liftIO $ openBinaryFile f ReadMode
+			( do
-			go chunksize h
+				h <- liftIO $ openBinaryFile f ReadMode
-			liftIO $ hClose h
+				go chunksize h
+				liftIO $ hClose h
+			, storer k (FileContent f) p
+			)
 		_ -> storer k (FileContent f) p
   where
 	go chunksize h = do

Remote/Helper/ExportImport.hs

@@ -11,7 +11,6 @@ module Remote.Helper.ExportImport where
 
 import Annex.Common
 import Types.Remote
-import Types.Backend
 import Types.Key
 import Types.ProposedAccepted
 import Backend
@@ -311,8 +310,8 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o
 		db <- getexportdb dbv
 		liftIO $ Export.getExportTree db k
 
-	retrieveKeyFileFromExport dbv k _af dest p
+	retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k)
-		| maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k)) = do
+		( do
 			locs <- getexportlocs dbv k
 			case locs of
 				[] -> ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv)
@@ -322,4 +321,5 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o
 				(l:_) -> do
 					retrieveExport (exportActions r) k l dest p
 					return UnVerified
-		| otherwise = giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"
+		, giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"
+		)

Test/Framework.hs

@@ -581,7 +581,7 @@ backendWORM :: Types.Backend
 backendWORM = backend_ "WORM"
 
 backend_ :: String -> Types.Backend
-backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS
+backend_ = Backend.lookupBuiltinBackendVariety . Types.Key.parseKeyVariety . encodeBS
 
 getKey :: Types.Backend -> FilePath -> IO Types.Key
 getKey b f = case Types.Backend.genKey b of

Types/Key.hs

@@ -1,6 +1,6 @@
 {- git-annex Key data type
  -
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -36,6 +36,7 @@ import qualified Data.Attoparsec.ByteString as A
 import qualified Data.Attoparsec.ByteString.Char8 as A8
 import Utility.FileSystemEncoding
 import Data.List
+import Data.Char
 import System.Posix.Types
 import Foreign.C.Types
 import Data.Monoid
@@ -215,6 +216,8 @@ data KeyVariety
 	| MD5Key HasExt
 	| WORMKey
 	| URLKey
+	-- A key that is handled by some external backend.
+	| ExternalKey S.ByteString HasExt
  	-- Some repositories may contain keys of other varieties,
 	-- which can still be processed to some extent.
 	| OtherKey S.ByteString
@@ -246,6 +249,7 @@ hasExt (SHA1Key (HasExt b)) = b
 hasExt (MD5Key (HasExt b)) = b
 hasExt WORMKey = False
 hasExt URLKey = False
+hasExt (ExternalKey _ (HasExt b)) = b
 hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E'
 
 sameExceptExt :: KeyVariety -> KeyVariety -> Bool
@@ -273,6 +277,7 @@ formatKeyVariety v = case v of
 	MD5Key e -> adde e "MD5"
 	WORMKey -> "WORM"
 	URLKey -> "URL"
+	ExternalKey s e -> adde e ("X" <> s)
 	OtherKey s -> s
   where
 	adde (HasExt False) s = s
@@ -330,10 +335,16 @@ parseKeyVariety "BLAKE2SP224"  = Blake2spKey (HashSize 224) (HasExt False)
 parseKeyVariety "BLAKE2SP224E" = Blake2spKey (HashSize 224) (HasExt True)
 parseKeyVariety "BLAKE2SP256"  = Blake2spKey (HashSize 256) (HasExt False)
 parseKeyVariety "BLAKE2SP256E" = Blake2spKey (HashSize 256) (HasExt True)
-parseKeyVariety "SHA1"        = SHA1Key (HasExt False)
+parseKeyVariety "SHA1"         = SHA1Key (HasExt False)
-parseKeyVariety "SHA1E"       = SHA1Key (HasExt True)
+parseKeyVariety "SHA1E"        = SHA1Key (HasExt True)
-parseKeyVariety "MD5"         = MD5Key (HasExt False)
+parseKeyVariety "MD5"          = MD5Key (HasExt False)
-parseKeyVariety "MD5E"        = MD5Key (HasExt True)
+parseKeyVariety "MD5E"         = MD5Key (HasExt True)
-parseKeyVariety "WORM"        = WORMKey
+parseKeyVariety "WORM"         = WORMKey
-parseKeyVariety "URL"         = URLKey
+parseKeyVariety "URL"          = URLKey
-parseKeyVariety b             = OtherKey b
+parseKeyVariety b
+	| "X" `S.isPrefixOf` b = 
+		let b' = S.tail b
+		in if S.last b' == fromIntegral (ord 'E')
+			then ExternalKey (S.init b') (HasExt True)
+			else ExternalKey b' (HasExt False)
+	| otherwise = OtherKey b

Upgrade/V1.hs

@@ -199,7 +199,7 @@ lookupKey1 file = do
 		Right l -> makekey l
   where
 	getsymlink = takeFileName <$> readSymbolicLink file
-	makekey l = case maybeLookupBackendVariety (fromKey keyVariety k) of
+	makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
 		Nothing -> do
 			unless (null kname || null bname ||
 			        not (isLinkToAnnex (toRawFilePath l))) $

Utility/Metered.hs

@@ -47,6 +47,7 @@ import Utility.Percentage
 import Utility.DataUnits
 import Utility.HumanTime
 import Utility.ThreadScheduler
+import Utility.SimpleProtocol as Proto
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString as S
@@ -439,3 +440,7 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now)
 				Just $ fromDuration $ Duration $
 					(totalsize - new) `div` bytespersecond
 		_ -> Nothing
+
+instance Proto.Serializable BytesProcessed where
+	serialize (BytesProcessed n) = show n
+	deserialize = BytesProcessed <$$> readish

doc/backends.mdwn

@@ -1,11 +1,30 @@
-When a file is annexed, a [[key|internals/key_format]] is generated from its content and/or filesystem
+When a file is annexed, a [[key|internals/key_format]] is generated from
-metadata. The file checked into git symlinks to the key. This key can later
+its content and/or filesystem metadata. The file checked into git symlinks
-be used to retrieve the file's content (its value).
+to the key. This key can later be used to retrieve the file's content (its
+value).
 
-Multiple pluggable key-value backends are supported, and a single repository
+Multiple key-value backends are supported, and a single repository
 can use different ones for different files. 
 
-These are the recommended backends to use.
+## configuring which backend to use
+
+The `annex.backend` git-config setting can be used to configure the
+default backend to use when adding new files.
+
+For finer control of what backend is used when adding different types of
+files, the `.gitattributes` file can be used. The `annex.backend`
+attribute can be set to the name of the backend to use for matching files.
+
+For example, to use the SHA256E backend for sound files, which tend to be
+smallish and might be modified or copied over time,
+while using the WORM backend for everything else, you could set
+in `.gitattributes`:
+
+	* annex.backend=WORM
+	*.mp3 annex.backend=SHA256E
+	*.ogg annex.backend=SHA256E
+
+## recommended backends to use
 
 * `SHA256E` -- The default backend for new files, combines a 256 bit SHA-2
   hash of the file's content with the file's extension. This allows
@@ -38,6 +57,8 @@ These are the recommended backends to use.
   -- Fast [Blake2 hash](https://blake2.net/) variants optimised for 
   8-way CPUs.
 
+## non-cryptograpgically secure backends
+
 The backends below do not guarantee cryptographically that the
 content of an annexed file remains unchanged.
 
@@ -56,9 +77,23 @@ content of an annexed file remains unchanged.
   that may be attached to a key (from any backend) indicating the key's location
   on the web or in one of [[special_remotes]].
 
+## external backends
+
+While most backends are built into git-annex, it also supports external
+backends. These are programs with names like `git-annex-backend-XFOO`,
+which can be provided by others. See [[design/external_backend_protocol]]
+for details about how to write them.
+
+Here's a list of external backends. Edit this page to add yours to the list.
+
+* [[design/external_backend_protocol/git-annex-backend-XFOO]]
+  is a demo program implementing the protocol with a shell script.
+
+## notes
+
 If you want to be able to prove that you're working with the same file
 contents that were checked into a repository earlier, you should avoid
-using the non-cryptographically-secure backends, and will need to use
+using non-cryptographically-secure backends, and will need to use
 signed git commits. See [[tips/using_signed_git_commits]] for details.
 
 Retrieval of WORM and URL from many [[special_remotes]] is prohibited
@@ -68,20 +103,4 @@ Note that the various 512 and 384 length hashes result in long paths,
 which are known to not work on Windows. If interoperability on Windows is a
 concern, avoid those.
 
-The `annex.backend` git-config setting can be used to configure the
-default backend to use when adding new files.
-
-For finer control of what backend is used when adding different types of
-files, the `.gitattributes` file can be used. The `annex.backend`
-attribute can be set to the name of the backend to use for matching files.
-
-For example, to use the SHA256E backend for sound files, which tend to be
-smallish and might be modified or copied over time,
-while using the WORM backend for everything else, you could set
-in `.gitattributes`:
-
-	* annex.backend=WORM
-	*.mp3 annex.backend=SHA256E
-	*.ogg annex.backend=SHA256E
-
 See also: [[git-annex-examinekey]]

doc/design/external_backend_protocol.mdwn

@@ -179,11 +179,8 @@ It's important that two different programs don't use the same name, because
 that would result in bad behavior if the wrong program were used with a
 repository with keys generated by the other program.
 
-Here is a list of programs, to avoid picking the same name. Edit this page
+To avoid picking the same name, there is a list of known external backend
-to add yours to the list.
+programs in [[backends]].
-
-* [[git-annex-backend-XFOO]] is a demo program implementing this protocol
-  with a shell script.
 
 ## signals
 

doc/design/external_backend_protocol/git-annex-backend-XFOO

@@ -7,7 +7,7 @@
 
 set -e
 
-hashfile {
+hashfile () {
 	local contentfile="$1"
 	# could send PROGRESS while doing this, but it's
 	# hard to implement that in shell

git-annex.cabal

@@ -698,7 +698,7 @@ Executable git-annex
     Annex.WorkTree
     Annex.YoutubeDl
     Backend
-    -- Backend.External
+    Backend.External
     Backend.Hash
     Backend.URL
     Backend.Utilities