git-annex-shell can now be used as a login shell

Utility.hs

@@ -14,9 +14,13 @@ module Utility (
 	relPathDirToDir,
 	boolSystem,
 	shellEscape,
+	shellUnEscape,
 	unsetFileMode,
 	readMaybe,
-	safeWriteFile
+	safeWriteFile,
+	
+	prop_idempotent_shellescape,
+	prop_idempotent_shellescape_multiword
 ) where
 
 import System.IO
@@ -128,6 +132,29 @@ shellEscape f = "'" ++ escaped ++ "'"
 		-- replace ' with '"'"'
 		escaped = join "'\"'\"'" $ split "'" f
 
+{- Unescapes a set of shellEscaped words or filenames. -}
+shellUnEscape :: String -> [String]
+shellUnEscape [] = []
+shellUnEscape s = word:(shellUnEscape rest)
+	where
+		(word, rest) = findword "" s
+		findword w [] = (w, "")
+		findword w (c:cs)
+			| c == ' ' = (w, cs)
+			| c == '\'' = inquote c w cs
+			| c == '"' = inquote c w cs
+			| otherwise = findword (w++[c]) cs
+		inquote _ w [] = (w, "")
+		inquote q w (c:cs)
+			| c == q = findword w cs
+			| otherwise = inquote q (w++[c]) cs
+
+{- For quickcheck. -}
+prop_idempotent_shellescape :: String -> Bool
+prop_idempotent_shellescape s = [s] == (shellUnEscape $ shellEscape s)
+prop_idempotent_shellescape_multiword :: [String] -> Bool
+prop_idempotent_shellescape_multiword s = s == (shellUnEscape $ unwords $ map shellEscape s)
+
 {- Removes a FileMode from a file.
  - For example, call with otherWriteMode to chmod o-w -}
 unsetFileMode :: FilePath -> FileMode -> IO ()

git-annex-shell.hs

@@ -7,6 +7,7 @@
 
 import System.Environment
 import Control.Monad (when)
+import Data.List
 
 import qualified GitRepo as Git
 import CmdLine
@@ -43,14 +44,14 @@ main' :: [String] -> IO ()
 main' [] = failure
 -- skip leading -c options, passed by eg, ssh
 main' ("-c":p) = main' p
--- Since git-annex explicitly runs git-annex-shell, we will be passed 
--- a redundant "git-annex-shell" parameter when we're the user's login shell.
-main' ("git-annex-shell":p) = main' p
 -- a command can be either a builtin or something to pass to git-shell
 main' c@(cmd:dir:params)
 	| elem cmd 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.
+	| isPrefixOf "git-annex-shell " cmd = main' $ drop 1 $ shellUnEscape cmd
 	| elem cmd builtins = failure
 	| otherwise = external c
 
@@ -60,13 +61,20 @@ builtins = map cmdname cmds
 builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
 	let gitrepo = Git.repoFromPath dir
-	dispatch gitrepo (cmd:params) cmds commonOptions header
+	dispatch gitrepo (cmd:(filterparams params)) cmds commonOptions header
 
 external :: [String] -> IO ()
-external l = do
+external params = do
-	ret <- boolSystem "git-shell" ("-c":l)
+	ret <- boolSystem "git-shell" ("-c":(filterparams params))
 	when (not ret) $
 		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 commonOptions

test.hs

@@ -3,11 +3,14 @@ import Test.HUnit.Tools
 
 import GitRepo
 import Locations
+import Utility
 
 alltests :: [Test]
 alltests = [
 	qctest "prop_idempotent_deencode" prop_idempotent_deencode,
-	qctest "prop_idempotent_fileKey" prop_idempotent_fileKey
+	qctest "prop_idempotent_fileKey" prop_idempotent_fileKey,
+	qctest "prop_idempotent_shellescape" prop_idempotent_shellescape,
+	qctest "prop_idempotent_shellescape_multiword" prop_idempotent_shellescape_multiword
 	]
 
 main :: IO (Counts, Int)