GIT_ANNEX_SHELL_APPENDONLY

Makes it allow writes, but not deletion of annexed content. Note that
securing pushes to the git repository is left up to the user.

This commit was sponsored by Jack Hill on Patreon.

CHANGELOG

@@ -21,6 +21,9 @@ git-annex (6.20180510) UNRELEASED; urgency=medium
     from the above migrate bug, or to add missing size information
     (a long ago transition), or because of a few other past key related
     bugs.
+  * git-annex-shell: GIT_ANNEX_SHELL_APPENDONLY makes it allow writes,
+    but not deletion of annexed content. Note that securing pushes to
+    the git repository is left up to the user.
 
  -- Joey Hess <id@joeyh.name>  Mon, 14 May 2018 13:42:41 -0400
 

CmdLine/GitAnnexShell.hs

@@ -17,6 +17,7 @@ import Annex.UUID
 import CmdLine.GitAnnexShell.Checks
 import CmdLine.GitAnnexShell.Fields
 import Remote.GCrypt (getGCryptUUID)
+import P2P.Protocol (ServerMode(..))
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
@@ -30,39 +31,44 @@ import qualified Command.NotifyChanges
 import qualified Command.GCryptSetup
 import qualified Command.P2PStdIO
 
-cmds_readonly :: [Command]
-cmds_readonly =
-	[ Command.ConfigList.cmd
-	, gitAnnexShellCheck Command.InAnnex.cmd
-	, gitAnnexShellCheck Command.LockContent.cmd
-	, gitAnnexShellCheck Command.SendKey.cmd
-	, gitAnnexShellCheck Command.TransferInfo.cmd
-	, gitAnnexShellCheck Command.NotifyChanges.cmd
+import qualified Data.Map as M
+
+cmdsMap :: M.Map ServerMode [Command]
+cmdsMap = M.fromList $ map mk
+	[ (ServeReadOnly, readonlycmds)
+	, (ServeAppendOnly, appendcmds)
+	, (ServeReadWrite, allcmds)
 	]
-
-cmds_notreadonly :: [Command]
-cmds_notreadonly =
-	[ gitAnnexShellCheck Command.RecvKey.cmd
-	, gitAnnexShellCheck Command.DropKey.cmd
-	, gitAnnexShellCheck Command.Commit.cmd
-	, Command.GCryptSetup.cmd
-	]
-
--- Commands that can operate readonly or not; they use checkNotReadOnly.
-cmds_readonly_capable :: [Command]
-cmds_readonly_capable =
-	[ gitAnnexShellCheck Command.P2PStdIO.cmd
-	]
-
-cmds_readonly_safe :: [Command]
-cmds_readonly_safe = cmds_readonly ++ cmds_readonly_capable
-
-cmds :: [Command]
-cmds = map (adddirparam . noMessages)
-	(cmds_readonly ++ cmds_notreadonly ++ cmds_readonly_capable)
   where
+	readonlycmds = 
+		[ Command.ConfigList.cmd
+		, gitAnnexShellCheck Command.InAnnex.cmd
+		, gitAnnexShellCheck Command.LockContent.cmd
+		, gitAnnexShellCheck Command.SendKey.cmd
+		, gitAnnexShellCheck Command.TransferInfo.cmd
+		, gitAnnexShellCheck Command.NotifyChanges.cmd
+		-- p2pstdio checks the enviroment variables to
+		-- determine the security policy to use
+		, gitAnnexShellCheck Command.P2PStdIO.cmd
+		]
+	appendcmds = readonlycmds ++
+		[ gitAnnexShellCheck Command.RecvKey.cmd
+		, gitAnnexShellCheck Command.Commit.cmd
+		]
+	allcmds =
+		[ gitAnnexShellCheck Command.DropKey.cmd
+		, Command.GCryptSetup.cmd
+		]
+
+	mk (s, l) = (s, map (adddirparam . noMessages) l)
 	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
 
+cmdsFor :: ServerMode -> [Command]
+cmdsFor = fromMaybe [] . flip M.lookup cmdsMap
+
+cmdsList :: [Command]
+cmdsList = concat $ M.elems cmdsMap
+
 globalOptions :: [GlobalOption]
 globalOptions = 
 	globalSetter checkUUID (strOption
@@ -101,17 +107,19 @@ run c@(cmd:_)
 	| otherwise = external c
 
 builtins :: [String]
-builtins = map cmdname cmds
+builtins = map cmdname cmdsList
 
 builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
-	unless (cmd `elem` map cmdname cmds_readonly_safe)
+	unless (cmd `elem` map cmdname (cmdsFor ServeReadOnly))
 		checkNotReadOnly
+	unless (cmd `elem` map cmdname (cmdsFor ServeAppendOnly))
+		checkNotAppendOnly
 	checkDirectory $ Just dir
 	let (params', fieldparams, opts) = partitionParams params
 	    rsyncopts = ("RsyncOptions", unwords opts)
 	    fields = rsyncopts : filter checkField (parseFields fieldparams)
-	dispatch False (cmd : params') cmds globalOptions fields mkrepo
+	dispatch False (cmd : params') cmdsList globalOptions fields mkrepo
 		"git-annex-shell"
 		"Restricted login shell for git-annex only SSH access"
   where
@@ -161,6 +169,6 @@ checkField (field, val)
 	| otherwise = False
 
 failure :: IO ()
-failure = giveup $ "bad parameters\n\n" ++ usage h cmds
+failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList
   where
 	h = "git-annex-shell [-c] command [parameters ...] [option ...]"

CmdLine/GitAnnexShell/Checks.hs

@@ -26,6 +26,12 @@ readOnlyEnv = "GIT_ANNEX_SHELL_READONLY"
 checkNotReadOnly :: IO ()
 checkNotReadOnly = checkEnv readOnlyEnv
 
+appendOnlyEnv :: String
+appendOnlyEnv = "GIT_ANNEX_SHELL_APPENDONLY"
+
+checkNotAppendOnly :: IO ()
+checkNotAppendOnly = checkEnv appendOnlyEnv
+
 checkEnv :: String -> IO ()
 checkEnv var = checkEnvSet var >>= \case
 	False -> noop

Command/P2PStdIO.hs

@@ -26,10 +26,13 @@ seek _ = giveup "missing UUID parameter"
 
 start :: UUID -> CommandStart
 start theiruuid = do
-	servermode <- liftIO $ 
-		Checks.checkEnvSet Checks.readOnlyEnv >>= return . \case
-			True -> P2P.ServeReadOnly
-			False -> P2P.ServeReadWrite
+	servermode <- liftIO $ do
+		ro <- Checks.checkEnvSet Checks.readOnlyEnv
+		ao <- Checks.checkEnvSet Checks.appendOnlyEnv
+		return $ case (ro, ao) of
+			(True, _) -> P2P.ServeReadOnly
+			(False, True) -> P2P.ServeAppendOnly
+			(False, False) -> P2P.ServeReadWrite
 	myuuid <- getUUID
 	conn <- stdioP2PConnection <$> Annex.gitRepo
 	let server = do

P2P/Protocol.hs

@@ -411,13 +411,21 @@ serveAuth myuuid = serverLoop handler
 				return ServerContinue
 	handler _ = return ServerUnexpected
 
-data ServerMode = ServeReadOnly | ServeReadWrite
+data ServerMode
+	= ServeReadOnly
+	-- ^ Allow reading, but not writing.
+	| ServeAppendOnly
+	-- ^ Allow reading, and storing new objects, but not deleting objects.
+	| ServeReadWrite
+	-- ^ Full read and write access.
+	deriving (Eq, Ord)
 
 -- | Serve the protocol, with a peer that has authenticated.
 serveAuthed :: ServerMode -> UUID -> Proto ()
 serveAuthed servermode myuuid = void $ serverLoop handler
   where
 	readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied")
+	appendonlyerror = net $ sendMessage (ERROR "this repository is append-only; removal denied")
 	handler (VERSION theirversion) = do
 		let v = min theirversion maxProtocolVersion
 		net $ setProtocolVersion v
@@ -439,22 +447,15 @@ serveAuthed servermode myuuid = void $ serverLoop handler
 		ServeReadWrite -> do
 			sendSuccess =<< local (removeContent key)
 			return ServerContinue
+		ServeAppendOnly -> do
+			appendonlyerror
+			return ServerContinue
 		ServeReadOnly -> do
 			readonlyerror
 			return ServerContinue
 	handler (PUT af key) = case servermode of
-		ServeReadWrite -> do
-			have <- local $ checkContentPresent key
-			if have
-				then net $ sendMessage ALREADY_HAVE
-				else do
-					let sizer = tmpContentSize key
-					let storer = \o l b v -> unVerified $
-						storeContent key af o l b v
-					(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM
-					when ok $
-						local $ setPresent key myuuid
-			return ServerContinue
+		ServeReadWrite -> handleput af key
+		ServeAppendOnly -> handleput af key
 		ServeReadOnly -> do
 			readonlyerror
 			return ServerContinue
@@ -467,6 +468,10 @@ serveAuthed servermode myuuid = void $ serverLoop handler
 		let goahead = net $ relayService service
 		case (servermode, service) of
 			(ServeReadWrite, _) -> goahead
+			(ServeAppendOnly, UploadPack) -> goahead
+			-- git protocol could be used to overwrite
+			-- refs or something, so don't allow
+			(ServeAppendOnly, ReceivePack) -> readonlyerror
 			(ServeReadOnly, UploadPack) -> goahead
 			(ServeReadOnly, ReceivePack) -> readonlyerror
 		-- After connecting to git, there may be unconsumed data
@@ -479,6 +484,19 @@ serveAuthed servermode myuuid = void $ serverLoop handler
 		return ServerContinue
 	handler _ = return ServerUnexpected
 
+	handleput af key = do
+		have <- local $ checkContentPresent key
+		if have
+			then net $ sendMessage ALREADY_HAVE
+			else do
+				let sizer = tmpContentSize key
+				let storer = \o l b v -> unVerified $
+					storeContent key af o l b v
+				(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM
+				when ok $
+					local $ setPresent key myuuid
+		return ServerContinue
+
 sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool
 sendContent key af offset@(Offset n) p = go =<< local (contentSize key)
   where

doc/git-annex-shell.mdwn

@@ -139,6 +139,19 @@ changed.
 
   If set, disallows running git-shell to handle unknown commands.
 
+* GIT_ANNEX_SHELL_APPENDONLY
+
+  If set, allows data to be written to the git-annex repository,
+  but does not allow data to be removed from it.
+
+  Note that this does not prevent passing commands on to git-shell,
+  so you will have to separately configure git to reject pushes that
+  overwrite branches or are otherwise not appends. The git pre-receive
+  hook may be useful for accomplishing this.
+
+  It's a good idea to enable annex.securehashesonly in a repository
+  that's set up this way.
+
 * GIT_ANNEX_SHELL_DIRECTORY
 
   If set, git-annex-shell will refuse to run commands that do not operate

doc/todo/append-only_mode.mdwn

@@ -26,3 +26,22 @@ it wouldn't overwrite an existing bit of content without first doing a
 checksum?
 
 Thanks! -- [[anarcat]]
+
+> Good idea.. Implemented. 
+> 
+> I'm not entirely happy with the name, but could not think of
+> a better one.
+> 
+> Yes, `recvkey` will never overwrite content already in the annex,
+> and unless you turn off annex.verify, hashes will also be checked
+> before letting anything into the annex.
+> 
+> Of course, if non-hashed keys are used, and an object has not
+> reached the repository yet from a trusted source, an attacker
+> could slip in something malicious without being noticed.
+> Setting annex.securehashesonly would be a good idea to prevent this.
+> 
+> p2pstdio implements the same security policies as the rest of
+> git-annex-shell.
+> 
+> --[[Joey]]