git-annex-shell is complete

still not used

Command/RecvKey.hs

@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.RecvKey where
+
+import Control.Monad (when)
+import Control.Monad.State (liftIO)
+import System.Exit
+
+import Command
+import Types
+import Core
+import qualified Backend
+import RsyncFile
+
+command :: [Command]
+command = [Command "recvkey" paramKey seek
+	"runs rsync in server mode to receive content"]
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: CommandStartString
+start keyname = do
+	backends <- Backend.list
+	let key = genKey (head backends) keyname
+	present <- inAnnex key
+	when present $
+		error "key is already present in annex"
+	
+	ok <- getViaTmp key (liftIO . rsyncServerReceive)
+	if ok
+		then return Nothing
+		else liftIO exitFailure

Command/SendKey.hs

@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.SendKey where
+
+import Control.Monad (when)
+import Control.Monad.State (liftIO)
+import System.Exit
+
+import Locations
+import qualified Annex
+import Command
+import Types
+import Core
+import qualified Backend
+import RsyncFile
+
+command :: [Command]
+command = [Command "sendkey" paramKey seek
+	"runs rsync in server mode to send content"]
+
+seek :: [CommandSeek]
+seek = [withKeys start]
+
+start :: CommandStartString
+start keyname = do
+	backends <- Backend.list
+	let key = genKey (head backends) keyname
+	present <- inAnnex key
+	g <- Annex.gitRepo
+	let file = annexLocation g key
+	when present $
+		liftIO $ rsyncServerSend file
+	liftIO exitFailure

Options.hs

@@ -24,21 +24,13 @@ storeOptString :: FlagName -> String -> Annex ()
 storeOptString name val = Annex.flagChange name $ FlagString val
 
 commonOptions :: [Option]
-commonOptions = [
-	    Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
+commonOptions =
+	[ Option ['f'] ["force"] (NoArg (storeOptBool "force" True))
 		"allow actions that may lose annexed data"
-	  , Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
+	, Option ['q'] ["quiet"] (NoArg (storeOptBool "quiet" True))
 		"avoid verbose output"
-	  , Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
+	, Option ['v'] ["verbose"] (NoArg (storeOptBool "quiet" False))
 		"allow verbose output"
-	  , Option ['b'] ["backend"] (ReqArg (storeOptString "backend") paramName)
+	, 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"
-	  ]
+	]

Remotes.hs

@@ -251,7 +251,7 @@ copyToRemote r key file = do
 sshLocation :: Git.Repo -> FilePath -> FilePath
 sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
 
-{- Copies a file from or to a remote, using rsync (when available) or scp. -}
+{- Copies a file from or to a remote, using rsync. -}
 remoteCopyFile :: Bool -> Git.Repo -> String -> String -> Annex Bool
 remoteCopyFile recv r src dest = do
 	showProgress -- make way for progress bar

RsyncFile.hs

@@ -0,0 +1,33 @@
+{- git-annex file copying with rsync
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module RsyncFile where
+
+import Utility
+import System.Posix.Process
+
+{- Runs rsync in server mode to send a file, and exits. -}
+rsyncServerSend :: FilePath -> IO ()
+rsyncServerSend file = rsyncExec $ rsyncServerParams ++ ["--sender", file]
+
+{- Runs rsync in server mode to receive a file. -}
+rsyncServerReceive :: FilePath -> IO Bool
+rsyncServerReceive file = rsync $ rsyncServerParams ++ [file]
+
+rsyncServerParams :: [String]
+rsyncServerParams =
+	[ "--server"
+	, "-p"		-- preserve permissions
+	, "--inplace"	-- allow resuming of transfers of big files
+	, "-e.Lsf", "."	-- other options rsync normally uses in server mode
+	]
+
+rsync :: [String] -> IO Bool
+rsync params = boolSystem "rsync" params 
+
+rsyncExec :: [String] -> IO ()
+rsyncExec params = executeFile "rsync" True params Nothing

git-annex-shell.hs

@@ -17,16 +17,16 @@ import Options
 import qualified Command.ConfigList
 import qualified Command.InAnnex
 import qualified Command.DropKey
---import qualified Command.RecvKey
---import qualified Command.SendKey
+import qualified Command.RecvKey
+import qualified Command.SendKey
 
 cmds :: [Command]
 cmds = map adddirparam $ concat
 	[ Command.ConfigList.command
 	, Command.InAnnex.command
 	, Command.DropKey.command
---	, Command.RecvKey.command
---	, Command.SendKey.command
+	, Command.RecvKey.command
+	, Command.SendKey.command
 	]
 	where
 		adddirparam c = c { cmdparams = "DIRECTORY " ++ cmdparams c }

git-annex.hs

@@ -6,6 +6,7 @@
  -}
 
 import System.Environment
+import System.Console.GetOpt
 
 import qualified GitRepo as Git
 import CmdLine
@@ -59,6 +60,18 @@ cmds = concat
 	, Command.Find.command
 	]
 
+options :: [Option]
+options = commonOptions ++
+	[ 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"
+	]
+
 header :: String
 header = "Usage: git-annex command [option ..]"
 
@@ -66,4 +79,4 @@ main :: IO ()
 main = do
 	args <- getArgs
 	gitrepo <- Git.repoFromCwd
-	dispatch gitrepo args cmds commonOptions header
+	dispatch gitrepo args cmds options header