diff options
author | Joey Hess <joeyh@joeyh.name> | 2015-08-05 14:09:25 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2015-08-05 14:09:25 -0400 |
commit | 593af3d79581a00af7a25897750fc5b1c2e0e0ab (patch) | |
tree | 0a3ee8d1577476d1c38113e696818723b9a972ff /CmdLine/GitAnnexShell.hs | |
parent | a43686b9847c19efebd1f15519083436ac155a8e (diff) |
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.
Diffstat (limited to 'CmdLine/GitAnnexShell.hs')
-rw-r--r-- | CmdLine/GitAnnexShell.hs | 63 |
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." |