a3c9d06a26
Eventually, git-annex might try running this after making changes to a remote. I have not yet thought of a good way for it to tell which remotes it needs to run it on though. It can't just do it when shutting down a cached ssh connection, because ssh connection caching is optional, and that would not handle local remotes not accessed over ssh either.
117 lines
3.1 KiB
Haskell
117 lines
3.1 KiB
Haskell
{- 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.Construct
|
|
import CmdLine
|
|
import Command
|
|
import Annex.UUID
|
|
import qualified Option
|
|
|
|
import qualified Command.ConfigList
|
|
import qualified Command.InAnnex
|
|
import qualified Command.DropKey
|
|
import qualified Command.RecvKey
|
|
import qualified Command.SendKey
|
|
import qualified Command.Commit
|
|
|
|
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
|
|
, Command.Commit.def
|
|
]
|
|
|
|
cmds :: [Command]
|
|
cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
|
|
where
|
|
adddirparam c = c
|
|
{ cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c
|
|
}
|
|
|
|
options :: [OptDescr (Annex ())]
|
|
options = Option.common ++
|
|
[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "repository uuid"
|
|
]
|
|
where
|
|
checkuuid expected = getUUID >>= check
|
|
where
|
|
check u | u == toUUID expected = return ()
|
|
check NoUUID = unexpected "uninitialized repository"
|
|
check u = unexpected $ "UUID " ++ fromUUID u
|
|
unexpected s = error $
|
|
"expected repository UUID " ++
|
|
expected ++ " but found " ++ s
|
|
|
|
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
|
|
dispatch (cmd : filterparams params) cmds options header $
|
|
Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
|
|
|
|
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 =
|
|
whenM (not . null <$> catchDefaultIO (getEnv var) "") $
|
|
error $ "Action blocked by " ++ var
|