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.
This commit is contained in:
Joey Hess
parent
7a65df3223
commit
d2769cf795
6 changed files with 140 additions and 119 deletions
116
GitAnnexShell.hs
Normal file
116
GitAnnexShell.hs
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
{- git-annex-shell main program
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module GitAnnexShell where
|
||||
|
||||
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 ..]"
|
||||
|
||||
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 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
|
||||
5
Makefile
5
Makefile
|
|
@ -9,8 +9,8 @@ endif
|
|||
|
||||
GHCMAKE=ghc $(GHCFLAGS) --make
|
||||
|
||||
bins=git-annex git-annex-shell git-union-merge
|
||||
mans=git-annex.1 git-annex-shell.1 git-union-merge.1
|
||||
bins=git-annex
|
||||
mans=git-annex.1 git-annex-shell.1
|
||||
sources=Build/SysConfig.hs Utility/StatFS.hs Utility/Touch.hs
|
||||
|
||||
all=$(bins) $(mans) docs
|
||||
|
|
@ -48,6 +48,7 @@ git-union-merge.1: doc/git-union-merge.mdwn
|
|||
install: all
|
||||
install -d $(DESTDIR)$(PREFIX)/bin
|
||||
install $(bins) $(DESTDIR)$(PREFIX)/bin
|
||||
ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell
|
||||
install -d $(DESTDIR)$(PREFIX)/share/man/man1
|
||||
install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1
|
||||
install -d $(DESTDIR)$(PREFIX)/share/doc/git-annex
|
||||
|
|
|
|||
9
debian/changelog
vendored
9
debian/changelog
vendored
|
|
@ -1,4 +1,4 @@
|
|||
git-annex (3.20120310) UNRELEASED; urgency=low
|
||||
git-annex (3.20120315) unstable; urgency=low
|
||||
|
||||
* fsck: Fix up any broken links and misplaced content caused by the
|
||||
directory hash calculation bug fixed in the last release.
|
||||
|
|
@ -12,12 +12,15 @@ git-annex (3.20120310) UNRELEASED; urgency=low
|
|||
* Added annex.bloomcapacity and annex.bloomaccuracy, which can be
|
||||
adjusted as desired to tune the bloom filter.
|
||||
* status: Display amount of memory used by bloom filter, and
|
||||
detect then it's too small for the number of keys in a repository.
|
||||
detect when it's too small for the number of keys in a repository.
|
||||
* git-annex-shell: Runs hooks/annex-content after content is received
|
||||
or dropped.
|
||||
* Work around a bug in rsync (IMHO) introduced by openSUSE's SIP patch.
|
||||
* 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.
|
||||
|
||||
-- Joey Hess <joeyh@debian.org> Sat, 10 Mar 2012 14:03:22 -0400
|
||||
-- Joey Hess <joeyh@debian.org> Thu, 15 Mar 2012 11:05:28 -0400
|
||||
|
||||
git-annex (3.20120309) unstable; urgency=low
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
Name: git-annex
|
||||
Version: 3.20120310
|
||||
Version: 3.20120315
|
||||
Cabal-Version: >= 1.6
|
||||
License: GPL
|
||||
Maintainer: Joey Hess <joey@kitenet.net>
|
||||
|
|
@ -39,9 +39,6 @@ Executable git-annex-shell
|
|||
Main-Is: git-annex-shell.hs
|
||||
Other-Modules: Utility.StatFS
|
||||
|
||||
Executable git-union-merge
|
||||
Main-Is: git-union-merge.hs
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://git-annex.branchable.com/
|
||||
|
|
|
|||
14
git-annex.hs
14
git-annex.hs
|
|
@ -1,13 +1,21 @@
|
|||
{- git-annex main program stub
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2010,2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
|
||||
import GitAnnex
|
||||
import qualified GitAnnex
|
||||
import qualified GitAnnexShell
|
||||
|
||||
main :: IO ()
|
||||
main = run =<< getArgs
|
||||
main = run =<< getProgName
|
||||
where
|
||||
run n
|
||||
| isshell n = go GitAnnexShell.run
|
||||
| otherwise = go GitAnnex.run
|
||||
isshell n = takeFileName n == "git-annex-shell"
|
||||
go a = a =<< getArgs
|
||||
|
|
|
|||
Loading…
Reference in a new issue