blob: 12cc65e4ddc807832a9822c63ad0cab733daa456 (
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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
{- git-annex-shell main program
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
import System.Environment
import System.Console.GetOpt
import Common.Annex
import qualified Git
import CmdLine
import Command
import Annex.UUID
import qualified Command.ConfigList
import qualified Command.InAnnex
import qualified Command.DropKey
import qualified Command.RecvKey
import qualified Command.SendKey
cmds_readonly :: [Command]
cmds_readonly = concat
[ Command.ConfigList.def
, Command.InAnnex.def
, Command.SendKey.def
]
cmds_notreadonly :: [Command]
cmds_notreadonly = concat
[ Command.RecvKey.def
, Command.DropKey.def
]
cmds :: [Command]
cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
where
adddirparam c = c { cmdparams = "DIRECTORY " ++ cmdparams c }
options :: [OptDescr (Annex ())]
options = commonOptions ++
[ Option [] ["uuid"] (ReqArg check paramUUID) "repository uuid"
]
where
check expected = do
u <- getUUID
when (u /= toUUID expected) $ error $
"expected repository UUID " ++ expected
++ " but found UUID " ++ fromUUID u
header :: String
header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]"
main :: IO ()
main = main' =<< getArgs
main' :: [String] -> IO ()
main' [] = failure
-- skip leading -c options, passed by eg, ssh
main' ("-c":p) = main' p
-- a command can be either a builtin or something to pass to git-shell
main' c@(cmd:dir:params)
| cmd `elem` builtins = builtin cmd dir params
| otherwise = external c
main' c@(cmd:_)
-- Handle the case of being the user's login shell. It will be passed
-- a single string containing all the real parameters.
| "git-annex-shell " `isPrefixOf` cmd = main' $ drop 1 $ shellUnEscape cmd
| cmd `elem` builtins = failure
| otherwise = external c
builtins :: [String]
builtins = map cmdname cmds
builtin :: String -> String -> [String] -> IO ()
builtin cmd dir params = do
checkNotReadOnly cmd
Git.repoAbsPath dir >>= Git.repoFromAbsPath >>=
dispatch (cmd : filterparams params) cmds options header
external :: [String] -> IO ()
external params = do
checkNotLimited
unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $
error "git-shell failed"
-- Drop all args after "--".
-- These tend to be passed by rsync and not useful.
filterparams :: [String] -> [String]
filterparams [] = []
filterparams ("--":_) = []
filterparams (a:as) = a:filterparams as
failure :: IO ()
failure = error $ "bad parameters\n\n" ++ usage header cmds options
checkNotLimited :: IO ()
checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
checkNotReadOnly :: String -> IO ()
checkNotReadOnly cmd
| cmd `elem` map cmdname cmds_readonly = return ()
| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"
checkEnv :: String -> IO ()
checkEnv var = catch check (const $ return ())
where
check = do
val <- getEnv var
when (not $ null val) $
error $ "Action blocked by " ++ var
|
