reorganize some files and imports

1 files changed, 199 insertions, 0 deletions

diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs
new file mode 100644
index 000000000..c7b5bd1c9
--- /dev/null
+++ b/CmdLine/GitAnnexShell.hs
@@ -0,0 +1,199 @@
+{- git-annex-shell main program
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module CmdLine.GitAnnexShell where
+
+import System.Environment
+import System.Console.GetOpt
+
+import Common.Annex
+import qualified Git.Construct
+import CmdLine
+import Command
+import Annex.UUID
+import Annex (setField)
+import Fields
+import Utility.UserInfo
+import Remote.GCrypt (getGCryptUUID)
+import qualified Annex
+import Init
+
+import qualified Command.ConfigList
+import qualified Command.InAnnex
+import qualified Command.DropKey
+import qualified Command.RecvKey
+import qualified Command.SendKey
+import qualified Command.TransferInfo
+import qualified Command.Commit
+import qualified Command.GCryptSetup
+
+cmds_readonly :: [Command]
+cmds_readonly = concat
+	[ gitAnnexShellCheck Command.ConfigList.def
+	, gitAnnexShellCheck Command.InAnnex.def
+	, gitAnnexShellCheck Command.SendKey.def
+	, gitAnnexShellCheck Command.TransferInfo.def
+	]
+
+cmds_notreadonly :: [Command]
+cmds_notreadonly = concat
+	[ gitAnnexShellCheck Command.RecvKey.def
+	, gitAnnexShellCheck Command.DropKey.def
+	, gitAnnexShellCheck Command.Commit.def
+	, Command.GCryptSetup.def
+	]
+
+cmds :: [Command]
+cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
+  where
+	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
+
+options :: [OptDescr (Annex ())]
+options = commonOptions ++
+	[ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid"
+	]
+  where
+	checkUUID expected = getUUID >>= check
+	  where
+		check u | u == toUUID expected = noop
+		check NoUUID = checkGCryptUUID expected
+		check u = unexpectedUUID expected u
+	checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo
+	  where
+	  	check (Just u) | u == toUUID expected = noop
+		check Nothing = unexpected expected "uninitialized repository"
+		check (Just u) = unexpectedUUID expected u
+	unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u
+	unexpected expected s = error $
+		"expected repository UUID " ++ expected ++ " but found " ++ s
+
+header :: String
+header = "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
+	checkDirectory $ Just dir
+	let (params', fieldparams, opts) = partitionParams params
+	    fields = filter checkField $ parseFields fieldparams
+	    cmds' = map (newcmd $ unwords opts) cmds
+	dispatch False (cmd : params') cmds' options fields header $
+		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
+  where
+	addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k
+	newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) }
+
+external :: [String] -> IO ()
+external params = do
+	{- Normal git-shell commands all have the directory as their last
+	 - parameter. -}
+	let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params
+	    (params', _, _) = partitionParams params
+	checkDirectory lastparam
+	checkNotLimited
+	unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $
+		error "git-shell failed"
+
+{- Split the input list into 3 groups separated with a double dash --.
+ - Parameters between two -- markers are field settings, in the form:
+ - field=value field=value
+ -
+ - Parameters after the last -- are the command itself and its arguments e.g.,
+ - rsync --bandwidth=100.
+ -}
+partitionParams :: [String] -> ([String], [String], [String])
+partitionParams ps = case segment (== "--") ps of
+	params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest )
+	[params] -> (params, [], [])
+	_ -> ([], [], [])
+
+parseFields :: [String] -> [(String, String)]
+parseFields = map (separate (== '='))
+
+{- Only allow known fields to be set, ignore others.
+ - Make sure that field values make sense. -}
+checkField :: (String, String) -> Bool
+checkField (field, value)
+	| field == fieldName remoteUUID = fieldCheck remoteUUID value
+	| field == fieldName associatedFile = fieldCheck associatedFile value
+	| field == fieldName direct = fieldCheck direct value
+	| otherwise = False
+
+failure :: IO ()
+failure = error $ "bad parameters\n\n" ++ usage header cmds
+
+checkNotLimited :: IO ()
+checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED"
+
+checkNotReadOnly :: String -> IO ()
+checkNotReadOnly cmd
+	| cmd `elem` map cmdname cmds_readonly = noop
+	| otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY"
+
+checkDirectory :: Maybe FilePath -> IO ()
+checkDirectory mdir = do
+	v <- catchMaybeIO $ getEnv "GIT_ANNEX_SHELL_DIRECTORY"
+	case (v, mdir) of
+		(Nothing, _) -> noop
+		(Just d, Nothing) -> req d Nothing
+		(Just d, Just dir)
+			|  d `equalFilePath` dir -> noop
+			| otherwise -> do
+				home <- myHomeDir
+				d' <- canondir home d
+				dir' <- canondir home dir
+				if d' `equalFilePath` dir'
+					then noop
+					else req d' (Just dir')
+  where
+	req d mdir' = error $ unwords 
+		[ "Only allowed to access"
+		, d
+		, maybe "and could not determine directory from command line" ("not " ++) mdir'
+		]
+
+	{- A directory may start with ~/ or in some cases, even /~/,
+	 - or could just be relative to home, or of course could
+	 - be absolute. -}
+	canondir home d
+		| "~/" `isPrefixOf` d = return d
+		| "/~/" `isPrefixOf` d = return $ drop 1 d
+		| otherwise = relHome $ absPathFrom home d
+
+checkEnv :: String -> IO ()
+checkEnv var = do
+	v <- catchMaybeIO $ getEnv var
+	case v of
+		Nothing -> noop
+		Just "" -> noop
+		Just _ -> error $ "Action blocked by " ++ var
+
+{- Modifies a Command to check that it is run in either a git-annex
+ - repository, or a repository with a gcrypt-id set. -}
+gitAnnexShellCheck :: [Command] -> [Command]
+gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists
+  where
+	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
+		error "Not a git-annex or gcrypt repository."