blob: fcbf14b241579d966524cb6c593bbb2d63154c29 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
{- 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 Annex.Common
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 = getEnv var >>= \case
Nothing -> noop
Just "" -> noop
Just _ -> giveup $ "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' = giveup $ 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) $
giveup "Not a git-annex or gcrypt repository."
|
