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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{- git-annex-shell main program
-
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module CmdLine.GitAnnexShell where
import Annex.Common
import qualified Git.Construct
import qualified Git.Config
import CmdLine
import CmdLine.GlobalSetter
import Command
import Annex.UUID
import CmdLine.GitAnnexShell.Checks
import CmdLine.GitAnnexShell.Fields
import Remote.GCrypt (getGCryptUUID)
import P2P.Protocol (ServerMode(..))
import qualified Command.ConfigList
import qualified Command.InAnnex
import qualified Command.LockContent
import qualified Command.DropKey
import qualified Command.RecvKey
import qualified Command.SendKey
import qualified Command.TransferInfo
import qualified Command.Commit
import qualified Command.NotifyChanges
import qualified Command.GCryptSetup
import qualified Command.P2PStdIO
import qualified Data.Map as M
cmdsMap :: M.Map ServerMode [Command]
cmdsMap = M.fromList $ map mk
[ (ServeReadOnly, readonlycmds)
, (ServeAppendOnly, appendcmds)
, (ServeReadWrite, allcmds)
]
where
readonlycmds = map addGlobalOptions
[ Command.ConfigList.cmd
, gitAnnexShellCheck Command.InAnnex.cmd
, gitAnnexShellCheck Command.LockContent.cmd
, gitAnnexShellCheck Command.SendKey.cmd
, gitAnnexShellCheck Command.TransferInfo.cmd
, gitAnnexShellCheck Command.NotifyChanges.cmd
-- p2pstdio checks the enviroment variables to
-- determine the security policy to use
, gitAnnexShellCheck Command.P2PStdIO.cmd
]
appendcmds = readonlycmds ++ map addGlobalOptions
[ gitAnnexShellCheck Command.RecvKey.cmd
, gitAnnexShellCheck Command.Commit.cmd
]
allcmds = map addGlobalOptions
[ gitAnnexShellCheck Command.DropKey.cmd
, Command.GCryptSetup.cmd
]
mk (s, l) = (s, map (adddirparam . noMessages) l)
adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
cmdsFor :: ServerMode -> [Command]
cmdsFor = fromMaybe [] . flip M.lookup cmdsMap
cmdsList :: [Command]
cmdsList = concat $ M.elems cmdsMap
addGlobalOptions :: Command -> Command
addGlobalOptions c = c { cmdglobaloptions = globalOptions ++ cmdglobaloptions c }
globalOptions :: [GlobalOption]
globalOptions =
globalSetter checkUUID (strOption
( long "uuid" <> metavar paramUUID
<> help "local repository uuid"
))
: commonGlobalOptions
where
checkUUID expected = getUUID >>= check
where
check u | u == toUUID expected = noop
check NoUUID = checkGCryptUUID expected
check u = unexpectedUUID expected u
checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo
where
check (Just u) | u == toUUID expected = noop
check Nothing = unexpected expected "uninitialized repository"
check (Just u) = unexpectedUUID expected u
unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
unexpected expected s = giveup $
"expected repository UUID " ++ expected ++ " but found " ++ s
run :: [String] -> IO ()
run [] = failure
-- skip leading -c options, passed by eg, ssh
run ("-c":p) = run p
-- a command can be either a builtin or something to pass to git-shell
run c@(cmd:dir:params)
| cmd `elem` builtins = builtin cmd dir params
| otherwise = external c
run 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 = run $ drop 1 $ shellUnEscape cmd
| cmd `elem` builtins = failure
| otherwise = external c
builtins :: [String]
builtins = map cmdname cmdsList
builtin :: String -> String -> [String] -> IO ()
builtin cmd dir params = do
unless (cmd `elem` map cmdname (cmdsFor ServeReadOnly))
checkNotReadOnly
unless (cmd `elem` map cmdname (cmdsFor ServeAppendOnly))
checkNotAppendOnly
checkDirectory $ Just dir
let (params', fieldparams, opts) = partitionParams params
rsyncopts = ("RsyncOptions", unwords opts)
fields = rsyncopts : filter checkField (parseFields fieldparams)
dispatch False False (cmd : params') cmdsList fields mkrepo
"git-annex-shell"
"Restricted login shell for git-annex only SSH access"
where
mkrepo = do
r <- Git.Construct.repoAbsPath (toRawFilePath dir)
>>= Git.Construct.fromAbsPath
Git.Config.read r
`catchIO` \_ -> do
hn <- fromMaybe "unknown" <$> getHostname
giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
external :: [String] -> IO ()
external params = do
{- Normal git-shell commands all have the directory as their last
- parameter. -}
let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params
(params', _, _) = partitionParams params
checkDirectory lastparam
checkNotLimited
unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
giveup "git-shell failed"
{- Split the input list into 3 groups separated with a double dash --.
- Parameters between two -- markers are field settings, in the form:
- field=value field=value
-
- Parameters after the last -- are the command itself and its arguments e.g.,
- rsync --bandwidth=100.
-}
partitionParams :: [String] -> ([String], [String], [String])
partitionParams ps = case segment (== "--") ps of
params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest )
[params] -> (params, [], [])
_ -> ([], [], [])
parseFields :: [String] -> [(String, String)]
parseFields = map (separate (== '='))
{- Only allow known fields to be set, ignore others.
- Make sure that field values make sense. -}
checkField :: (String, String) -> Bool
checkField (field, val)
| field == fieldName remoteUUID = fieldCheck remoteUUID val
| field == fieldName associatedFile = fieldCheck associatedFile val
| field == fieldName unlocked = fieldCheck unlocked val
| field == fieldName direct = fieldCheck direct val
| field == fieldName autoInit = fieldCheck autoInit val
| otherwise = False
failure :: IO ()
failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList
where
h = "git-annex-shell [-c] command [parameters ...] [option ...]"
|
