2010-12-30 20:52:24 +00:00
|
|
|
{- git-annex-shell main program
|
|
|
|
-
|
|
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
import System.Environment
|
2011-10-06 23:11:30 +00:00
|
|
|
import System.Console.GetOpt
|
2010-12-30 20:52:24 +00:00
|
|
|
|
2011-10-05 20:02:51 +00:00
|
|
|
import Common.Annex
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git
|
2010-12-30 20:52:24 +00:00
|
|
|
import CmdLine
|
|
|
|
import Command
|
2011-10-15 21:47:03 +00:00
|
|
|
import Annex.UUID
|
2010-12-30 20:52:24 +00:00
|
|
|
|
2010-12-31 00:08:22 +00:00
|
|
|
import qualified Command.ConfigList
|
|
|
|
import qualified Command.InAnnex
|
2010-12-30 20:52:24 +00:00
|
|
|
import qualified Command.DropKey
|
2010-12-31 17:39:30 +00:00
|
|
|
import qualified Command.RecvKey
|
|
|
|
import qualified Command.SendKey
|
2010-12-30 20:52:24 +00:00
|
|
|
|
2011-10-15 23:06:35 +00:00
|
|
|
cmds_readonly :: [Command]
|
|
|
|
cmds_readonly = concat
|
2011-10-29 19:19:05 +00:00
|
|
|
[ Command.ConfigList.def
|
|
|
|
, Command.InAnnex.def
|
|
|
|
, Command.SendKey.def
|
2010-12-30 20:52:24 +00:00
|
|
|
]
|
2011-10-15 23:06:35 +00:00
|
|
|
|
|
|
|
cmds_notreadonly :: [Command]
|
|
|
|
cmds_notreadonly = concat
|
2011-10-29 19:19:05 +00:00
|
|
|
[ Command.RecvKey.def
|
|
|
|
, Command.DropKey.def
|
2011-10-15 23:06:35 +00:00
|
|
|
]
|
|
|
|
|
|
|
|
cmds :: [Command]
|
|
|
|
cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
|
2010-12-31 00:08:22 +00:00
|
|
|
where
|
|
|
|
adddirparam c = c { cmdparams = "DIRECTORY " ++ cmdparams c }
|
2010-12-30 20:52:24 +00:00
|
|
|
|
2011-10-06 23:11:30 +00:00
|
|
|
options :: [OptDescr (Annex ())]
|
2011-10-15 23:06:35 +00:00
|
|
|
options = commonOptions ++
|
|
|
|
[ Option [] ["uuid"] (ReqArg check paramUUID) "repository uuid"
|
|
|
|
]
|
2011-10-06 23:11:30 +00:00
|
|
|
where
|
|
|
|
check expected = do
|
2011-10-11 18:43:45 +00:00
|
|
|
u <- getUUID
|
2011-10-06 23:11:30 +00:00
|
|
|
when (u /= expected) $ error $
|
|
|
|
"expected repository UUID " ++ expected
|
|
|
|
++ " but found UUID " ++ u
|
|
|
|
|
2010-12-30 20:52:24 +00:00
|
|
|
header :: String
|
2011-05-22 00:18:35 +00:00
|
|
|
header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]"
|
2010-12-30 20:52:24 +00:00
|
|
|
|
|
|
|
main :: IO ()
|
2011-06-30 17:22:10 +00:00
|
|
|
main = main' =<< getArgs
|
2010-12-31 00:08:22 +00:00
|
|
|
|
|
|
|
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)
|
2011-01-30 16:01:56 +00:00
|
|
|
| cmd `elem` builtins = builtin cmd dir params
|
2010-12-31 00:08:22 +00:00
|
|
|
| otherwise = external c
|
|
|
|
main' c@(cmd:_)
|
2011-01-01 00:33:43 +00:00
|
|
|
-- Handle the case of being the user's login shell. It will be passed
|
|
|
|
-- a single string containing all the real parameters.
|
2011-01-27 21:58:30 +00:00
|
|
|
| "git-annex-shell " `isPrefixOf` cmd = main' $ drop 1 $ shellUnEscape cmd
|
2011-01-30 16:01:56 +00:00
|
|
|
| cmd `elem` builtins = failure
|
2010-12-31 00:08:22 +00:00
|
|
|
| otherwise = external c
|
|
|
|
|
|
|
|
builtins :: [String]
|
|
|
|
builtins = map cmdname cmds
|
|
|
|
|
|
|
|
builtin :: String -> String -> [String] -> IO ()
|
2011-10-15 23:06:35 +00:00
|
|
|
builtin cmd dir params = do
|
|
|
|
checkNotReadOnly cmd
|
2011-06-02 06:40:43 +00:00
|
|
|
Git.repoAbsPath dir >>= Git.repoFromAbsPath >>=
|
2011-10-06 23:11:30 +00:00
|
|
|
dispatch (cmd : filterparams params) cmds options header
|
2010-12-31 00:08:22 +00:00
|
|
|
|
|
|
|
external :: [String] -> IO ()
|
2011-10-15 23:06:35 +00:00
|
|
|
external params = do
|
|
|
|
checkNotLimited
|
2011-05-17 07:10:13 +00:00
|
|
|
unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $
|
2010-12-31 00:08:22 +00:00
|
|
|
error "git-shell failed"
|
|
|
|
|
2011-01-01 00:33:43 +00:00
|
|
|
-- 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
|
|
|
|
|
2010-12-31 00:08:22 +00:00
|
|
|
failure :: IO ()
|
2011-10-06 23:11:30 +00:00
|
|
|
failure = error $ "bad parameters\n\n" ++ usage header cmds options
|
2011-10-15 23:06:35 +00:00
|
|
|
|
|
|
|
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
|