add git-annex-shell command

This is not yet complete, as it does not allow starting rsync or scp.

.gitignore

@@ -3,6 +3,8 @@ test
 configure
 SysConfig.hs
 git-annex
+git-annex-shell
 git-annex.1
+git-annex-shell.1
 doc/.ikiwiki
 html

CmdLine.hs

@@ -6,14 +6,13 @@
  -}
 
 module CmdLine (
-	cmdLine,
+	dispatch,
 	parseCmd,
 	Option,
 	storeOptBool,
 	storeOptString,
 ) where
 
-import System.Environment
 import System.Console.GetOpt
 import Control.Monad (when)
 import Control.Monad.State (liftIO)
@@ -25,21 +24,11 @@ import Command
 import BackendList
 import Core
 import Upgrade
+import Options
 
-{- Each dashed command-line option results in generation of an action
- - in the Annex monad that performs the necessary setting.
- -}
-type Option = OptDescr (Annex ())
-
-storeOptBool :: FlagName -> Bool -> Annex ()
-storeOptBool name val = Annex.flagChange name $ FlagBool val
-storeOptString :: FlagName -> String -> Annex ()
-storeOptString name val = Annex.flagChange name $ FlagString val
-
-{- It all starts here. -}
-cmdLine :: [Command] -> [Option] -> String -> IO ()
-cmdLine cmds options header = do
-	args <- getArgs
+{- Runs the passed command line. -}
+dispatch :: [String] -> [Command] -> [Option] -> String -> IO ()
+dispatch args cmds options header = do
 	gitrepo <- Git.repoFromCwd
 	state <- Annex.new gitrepo allBackends
 	(actions, state') <- Annex.run state $ parseCmd args header cmds options
@@ -50,24 +39,27 @@ cmdLine cmds options header = do
 parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex [Annex Bool]
 parseCmd argv header cmds options = do
 	(flags, params) <- liftIO $ getopt
-	when (null params) $ error usagemsg
+	when (null params) $ error $ "missing command" ++ usagemsg
 	case lookupCmd (head params) of
-		[] -> error usagemsg
+		[] -> error $ "unknown command" ++ usagemsg
 		[command] -> do
 			_ <- sequence flags
 			prepCmd command (drop 1 params)
 		_ -> error "internal error: multiple matching commands"
 	where
 		getopt = case getOpt Permute options argv of
-			(flags, params, []) -> return (flags, params)
-			(_, _, errs) -> ioError (userError (concat errs ++ usagemsg))
+			(flags, params, []) ->
+				return (flags, params)
+			(_, _, errs) ->
+				ioError (userError (concat errs ++ usagemsg))
 		lookupCmd cmd = filter (\c -> cmd  == cmdname c) cmds
-		usagemsg = usage header cmds options
+		usagemsg = "\n\n" ++ usage header cmds options
 
 {- Usage message with lists of commands and options. -}
 usage :: String -> [Command] -> [Option] -> String
 usage header cmds options =
-	usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
+	usageInfo (header ++ "\n\nOptions:") options ++
+		"\nCommands:\n" ++ cmddescs
 	where
 		cmddescs = unlines $ map (indent . showcmd) cmds
 		showcmd c =

Command/FromKey.hs

@@ -21,7 +21,7 @@ import Core
 import Messages
 
 command :: [Command]
-command = [Command "fromkey" (paramRepeating paramKey) seek
+command = [Command "fromkey" paramPath seek
 	"adds a file using a specific key"]
 
 seek :: [CommandSeek]

Makefile

@@ -2,23 +2,28 @@ PREFIX=/usr
 GHCFLAGS=-O2 -Wall
 GHCMAKE=ghc -odir build -hidir build $(GHCFLAGS) --make
 
-all: git-annex git-annex.1 docs
+bins=git-annex git-annex-shell
+mans=git-annex.1 git-annex-shell.1
+
+all: $(bins) $(mans) docs
 
 SysConfig.hs: configure.hs
 	$(GHCMAKE) configure
 	./configure
 
+$(bins): SysConfig.hs
+	$(GHCMAKE) $@
+
 git-annex.1:
 	./mdwn2man git-annex 1 doc/git-annex.mdwn > git-annex.1
-
-git-annex: SysConfig.hs
-	$(GHCMAKE) git-annex
+git-annex-shell.1:
+	./mdwn2man git-annex 1 doc/git-annex-shell.mdwn > git-annex-shell.1
 
 install: all
 	install -d $(DESTDIR)$(PREFIX)/bin
-	install git-annex $(DESTDIR)$(PREFIX)/bin
+	install $(bins) $(DESTDIR)$(PREFIX)/bin
 	install -d $(DESTDIR)$(PREFIX)/share/man/man1
-	install -m 0644 git-annex.1 $(DESTDIR)$(PREFIX)/share/man/man1
+	install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/share/man/man1
 	install -d $(DESTDIR)$(PREFIX)/share/doc/git-annex
 	if [ -d html ]; then \
 		rsync -a --delete html/ $(DESTDIR)$(PREFIX)/share/doc/git-annex/html/; \
@@ -36,7 +41,7 @@ else
 IKIWIKI=ikiwiki
 endif
 
-docs: git-annex.1
+docs: $(mans)
 	$(IKIWIKI) doc html -v --wikiname git-annex --plugin=goodstuff \
 		--no-usedirs --disable-plugin=openid --plugin=sidebar \
 		--underlaydir=/dev/null --disable-plugin=shortcut \
@@ -44,7 +49,7 @@ docs: git-annex.1
 		--exclude='news/.*'
 
 clean:
-	rm -rf build git-annex git-annex.1 test configure SysConfig.hs
+	rm -rf build $(bins) $(mans) test configure SysConfig.hs
 	rm -rf doc/.ikiwiki html
 
-.PHONY: git-annex test install
+.PHONY: $(bins) test install

Options.hs

@@ -0,0 +1,44 @@
+{- git-annex dashed options
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Options where
+
+import System.Console.GetOpt
+
+import qualified Annex
+import Types
+import Command
+
+{- Each dashed command-line option results in generation of an action
+ - in the Annex monad that performs the necessary setting.
+ -}
+type Option = OptDescr (Annex ())
+
+storeOptBool :: FlagName -> Bool -> Annex ()
+storeOptBool name val = Annex.flagChange name $ FlagBool val
+storeOptString :: FlagName -> String -> Annex ()
+storeOptString name val = Annex.flagChange name $ FlagString val
+
+commonOptions :: [Option]
+commonOptions = [
+	    Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
+		"allow actions that may lose annexed data"
+	  , Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
+		"avoid verbose output"
+	  , Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
+		"allow verbose output"
+	  , Option ['b'] ["backend"] (ReqArg (storeOptString "backend") paramName)
+		"specify default key-value backend to use"
+	  , Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
+		"specify a key to use"
+	  , Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
+		"specify to where to transfer content"
+	  , Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
+		"specify from where to transfer content"
+	  , Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
+		"skip files matching the glob pattern"
+	  ]

doc/git-annex-shell.mdwn

@@ -0,0 +1,63 @@
+# NAME
+
+git-annex-shell - Restricted login shell for git-annex only SSH access
+
+# SYNOPSIS
+
+git-annex-shell -c command [params ...]
+
+# DESCRIPTION
+
+git-annex-shell is a restricted shell, similar to git-shell, which 
+can be used as a login shell for SSH accounts you want to restrict.
+
+# COMMANDS
+
+* git-annex fromkey file
+
+  This can be used to maually set up a file to link to a specified key
+  in the key-value backend. How you determine an existing key in the backend
+  varies. For the URL backend, the key is just a URL to the content.
+
+  Example:
+
+	git annex fromkey --backend=URL --key=http://www.archive.org/somefile somefile
+
+* git-annex dropkey [key ...]
+
+  This drops the annexed data for the specified
+  keys from this repository.
+
+  This can be used to drop content for arbitrary keys, which do not need
+  to have a file in the git repository pointing at them.
+
+  A backend will typically need to be specified with --backend. If none
+  is specified, the first configured backend is used.
+
+* git-annex setkey file
+
+  This sets the annxed data for a key to the content of
+  the specified file, and then removes the file.
+
+  A backend will typically need to be specified with --backend. If none
+  is specified, the first configured backend is used.
+
+Any other command is passed through to git-shell.
+
+# OPTIONS
+
+Same as git-annex or git-shell, depending on the command being run.
+
+# SEE ALSO
+
+[[git-annex]](1)
+
+git-shell(1)
+
+# AUTHOR
+
+Joey Hess <joey@kitenet.net>
+
+<http://git-annex.branchable.com/>
+
+Warning: this page is automatically made into a man page via [mdwn2man](http://git.ikiwiki.info/?p=ikiwiki;a=blob;f=mdwn2man;hb=HEAD).  Edit with care

doc/git-annex.mdwn

@@ -4,7 +4,7 @@ git-annex - manage files with git, without checking their contents in
 
 # SYNOPSIS
 
-git annex subcommand [params ...]
+git annex command [params ...]
 
 # DESCRIPTION
 
@@ -55,13 +55,13 @@ content from the key-value store.
 	# git annex move iso --to=usbdrive
 	move iso/Debian_5.0.iso (moving to usbdrive...) ok
 
-# SUBCOMMANDS
+# COMMANDS
 
 Like many git commands, git-annex can be passed a path that 
 is either a file or a directory. In the latter case it acts on all relevant
 files in the directory.
 
-Many git-annex subcommands will stage changes for later `git commit` by you.
+Many git-annex commands will stage changes for later `git commit` by you.
 
 * add [path ...]
 
@@ -91,7 +91,7 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
 
 * edit [path ...]
 
-  This is an alias for the unlock subcommand. May be easier to remember,
+  This is an alias for the unlock command. May be easier to remember,
   if you think of this as allowing you to edit an annexed file.
 
 * move [path ...]
@@ -122,7 +122,7 @@ Many git-annex subcommands will stage changes for later `git commit` by you.
 
 * fsck [path ...]
 
-  With no parameters, this subcommand checks the whole annex for consistency,
+  With no parameters, this command checks the whole annex for consistency,
   and warns about any problems found.
 
   With parameters, only the specified files are checked.

git-annex-shell.hs

@@ -0,0 +1,52 @@
+{- git-annex-shell main program
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+import System.Console.GetOpt
+import System.Environment
+import Control.Monad (when)
+
+import CmdLine
+import Command
+import Utility
+import Options
+
+import qualified Command.FromKey
+import qualified Command.DropKey
+import qualified Command.SetKey
+
+cmds :: [Command]
+cmds = concat
+	[ Command.FromKey.command
+	, Command.DropKey.command
+	, Command.SetKey.command
+	]
+
+options :: [Option]
+options = [ Option ['c'] ["command"] (NoArg (storeOptBool "command" True))
+		"ignored for compatability with git-shell"
+	  ] ++ commonOptions
+
+header :: String
+header = "Usage:\n" ++
+	"\tgit-annex-shell -c git-annex command [option ..]\n" ++
+	"\tgit-annex-shell -c shellcommand argument"
+
+main :: IO ()
+main = do
+	args <- getArgs
+	-- dispatch git-annex commands to builtin versions,
+	-- and pass everything else to git-shell
+	case args of
+		("git-annex":as) -> builtin as
+		[] -> builtin []
+		_ -> external args
+	where
+		builtin l = dispatch l cmds options header
+		external l = do
+			ret <- boolSystem "git-shell" l
+			when (not ret) $
+				error "git-shell failed"

git-annex.hs

@@ -5,10 +5,11 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-import System.Console.GetOpt
+import System.Environment
 
 import CmdLine
 import Command
+import Options
 
 import qualified Command.Add
 import qualified Command.Unannex
@@ -57,25 +58,7 @@ cmds = concat
 	, Command.Find.command
 	]
 
-options :: [Option]
-options = [
-	    Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
-		"allow actions that may lose annexed data"
-	  , Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
-		"avoid verbose output"
-	  , Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
-		"allow verbose output"
-	  , Option ['b'] ["backend"] (ReqArg (storeOptString "backend") paramName)
-		"specify default key-value backend to use"
-	  , Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
-		"specify a key to use"
-	  , Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
-		"specify to where to transfer content"
-	  , Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
-		"specify from where to transfer content"
-	  , Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
-		"skip files matching the glob pattern"
-	  ]
-
 main :: IO ()
-main = cmdLine cmds options "Usage: git-annex subcommand [option ..]"
+main = do
+	args <- getArgs
+	dispatch args cmds commonOptions "Usage: git-annex command [option ..]"