git-annex-shell: Don't let configlist auto-init repository when in readonly mode.

This was potentially a hole in the readonly mode armor even before my last
commit. If the user could push a git-annex branch to a repo, they could get
git-annex-shell to initialize the repo. After my last commit, the user
didn't even need to be allowed to push a branch to init the repo, so
this hole certianly needs to be closed now.

CmdLine/GitAnnexShell.hs

@@ -7,8 +7,6 @@
 
 module CmdLine.GitAnnexShell where
 
-import System.Environment
-
 import Common.Annex
 import qualified Git.Construct
 import qualified Git.Config
@@ -16,11 +14,9 @@ import CmdLine
 import CmdLine.GlobalSetter
 import Command
 import Annex.UUID
+import CmdLine.GitAnnexShell.Checks
 import CmdLine.GitAnnexShell.Fields
-import Utility.UserInfo
 import Remote.GCrypt (getGCryptUUID)
-import qualified Annex
-import Annex.Init
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
@@ -96,7 +92,8 @@ builtins = map cmdname cmds
 
 builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
-	checkNotReadOnly cmd
+	unless (cmd `elem` map cmdname cmds_readonly)
+		checkNotReadOnly
 	checkDirectory $ Just dir
 	let (params', fieldparams, opts) = partitionParams params
 	    rsyncopts = ("RsyncOptions", unwords opts)
@@ -153,57 +150,3 @@ failure :: IO ()
 failure = error $ "bad parameters\n\n" ++ usage h cmds
   where
 	h = "git-annex-shell [-c] command [parameters ...] [option ...]"
-
-checkNotLimited :: IO ()
-checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
-
-checkNotReadOnly :: String -> IO ()
-checkNotReadOnly cmd
-	| cmd `elem` map cmdname cmds_readonly = noop
-	| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"
-
-checkDirectory :: Maybe FilePath -> IO ()
-checkDirectory mdir = do
-	v <- catchMaybeIO $ getEnv "GIT_ANNEX_SHELL_DIRECTORY"
-	case (v, mdir) of
-		(Nothing, _) -> noop
-		(Just d, Nothing) -> req d Nothing
-		(Just d, Just dir)
-			|  d `equalFilePath` dir -> noop
-			| otherwise -> do
-				home <- myHomeDir
-				d' <- canondir home d
-				dir' <- canondir home dir
-				if d' `equalFilePath` dir'
-					then noop
-					else req d' (Just dir')
-  where
-	req d mdir' = error $ unwords 
-		[ "Only allowed to access"
-		, d
-		, maybe "and could not determine directory from command line" ("not " ++) mdir'
-		]
-
-	{- A directory may start with ~/ or in some cases, even /~/,
-	 - or could just be relative to home, or of course could
-	 - be absolute. -}
-	canondir home d
-		| "~/" `isPrefixOf` d = return d
-		| "/~/" `isPrefixOf` d = return $ drop 1 d
-		| otherwise = relHome $ absPathFrom home d
-
-checkEnv :: String -> IO ()
-checkEnv var = do
-	v <- catchMaybeIO $ getEnv var
-	case v of
-		Nothing -> noop
-		Just "" -> noop
-		Just _ -> error $ "Action blocked by " ++ var
-
-{- Modifies a Command to check that it is run in either a git-annex
- - repository, or a repository with a gcrypt-id set. -}
-gitAnnexShellCheck :: Command -> Command
-gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
-  where
-	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
-		error "Not a git-annex or gcrypt repository."

CmdLine/GitAnnexShell/Checks.hs

@@ -0,0 +1,67 @@
+{- git-annex-shell checks
+ -
+ - Copyright 2012 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine.GitAnnexShell.Checks where
+
+import Common.Annex
+import Command
+import qualified Annex
+import Annex.Init
+import Utility.UserInfo
+import Utility.Env
+
+checkNotLimited :: IO ()
+checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
+
+checkNotReadOnly :: IO ()
+checkNotReadOnly = checkEnv "GIT_ANNEX_SHELL_READONLY"
+
+checkEnv :: String -> IO ()
+checkEnv var = do
+	v <- getEnv var
+	case v of
+		Nothing -> noop
+		Just "" -> noop
+		Just _ -> error $ "Action blocked by " ++ var
+
+checkDirectory :: Maybe FilePath -> IO ()
+checkDirectory mdir = do
+	v <- getEnv "GIT_ANNEX_SHELL_DIRECTORY"
+	case (v, mdir) of
+		(Nothing, _) -> noop
+		(Just d, Nothing) -> req d Nothing
+		(Just d, Just dir)
+			|  d `equalFilePath` dir -> noop
+			| otherwise -> do
+				home <- myHomeDir
+				d' <- canondir home d
+				dir' <- canondir home dir
+				if d' `equalFilePath` dir'
+					then noop
+					else req d' (Just dir')
+  where
+	req d mdir' = error $ unwords 
+		[ "Only allowed to access"
+		, d
+		, maybe "and could not determine directory from command line" ("not " ++) mdir'
+		]
+
+	{- A directory may start with ~/ or in some cases, even /~/,
+	 - or could just be relative to home, or of course could
+	 - be absolute. -}
+	canondir home d
+		| "~/" `isPrefixOf` d = return d
+		| "/~/" `isPrefixOf` d = return $ drop 1 d
+		| otherwise = relHome $ absPathFrom home d
+
+{- Modifies a Command to check that it is run in either a git-annex
+ - repository, or a repository with a gcrypt-id set. -}
+gitAnnexShellCheck :: Command -> Command
+gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
+  where
+	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
+		error "Not a git-annex or gcrypt repository."

Command/ConfigList.hs

@@ -15,6 +15,7 @@ import qualified Annex.Branch
 import qualified Git.Config
 import Remote.GCrypt (coreGCryptId)
 import qualified CmdLine.GitAnnexShell.Fields as Fields
+import CmdLine.GitAnnexShell.Checks
 
 cmd :: Command
 cmd = noCommit $ dontCheck repoExists $
@@ -44,6 +45,7 @@ findOrGenUUID = do
 		then return u
 		else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit))
 			( do
+				liftIO checkNotReadOnly
 				initialize Nothing
 				getUUID
 			, return NoUUID

debian/changelog

@@ -28,6 +28,8 @@ git-annex (5.20150732) UNRELEASED; urgency=medium
     to manually be pushed before using git-annex sync. Note that this
     involved changes to git-annex-shell, so if the remote is using an old
     version, the manual push is still needed.
+  * git-annex-shell: Don't let configlist auto-init repository when in
+    readonly mode.
 
  -- Joey Hess <id@joeyh.name>  Fri, 31 Jul 2015 12:31:39 -0400