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, 67 insertions, 0 deletions

diff --git a/CmdLine/GitAnnexShell/Checks.hs b/CmdLine/GitAnnexShell/Checks.hs
new file mode 100644
index 000000000..5513d69cd
--- /dev/null
+++ b/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."