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.

1 files changed, 3 insertions, 60 deletions

diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs
index 170548d1c..59c861582 100644
--- a/CmdLine/GitAnnexShell.hs
+++ b/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."