summaryrefslogtreecommitdiff
path: root/git-annex-shell.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-03-15 12:00:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-03-15 12:00:19 -0400
commitd2769cf7953657ac9ff6ba2acc27cb71a6543c5d (patch)
treecdd718a7accbd26e7544ff96ab26965e98a48cc5 /git-annex-shell.hs
parent7a65df32236df42d49758ee861237613f501e3c2 (diff)
shave some 12 mb from the installed size
* git-annex now behaves as git-annex-shell if symlinked to and run by that name. The Makefile sets this up, saving some 8 mb of installed size. * git-union-merge is a demo program, so it is no longer built by default.
Diffstat (limited to 'git-annex-shell.hs')
-rw-r--r--git-annex-shell.hs110
1 files changed, 3 insertions, 107 deletions
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index 396b7b790..08c1f9664 100644
--- a/git-annex-shell.hs
+++ b/git-annex-shell.hs
@@ -1,117 +1,13 @@
{- git-annex-shell main program
-
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2012 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 ..]"
+import GitAnnexShell
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
+main = run =<< getArgs