git-annex-shell is complete

still not used

7 files changed, 134 insertions, 20 deletions

diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
new file mode 100644
index 000000000..3232010d4
--- /dev/null
+++ b/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
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
new file mode 100644
index 000000000..0ddc0d23b
--- /dev/null
+++ b/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
diff --git a/Options.hs b/Options.hs
index 684aed97d..5f367c9dd 100644
--- a/Options.hs
+++ b/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"
-	  ]
+	]
diff --git a/Remotes.hs b/Remotes.hs
index a775f71d4..ca65c99ff 100644
--- a/Remotes.hs
+++ b/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
diff --git a/RsyncFile.hs b/RsyncFile.hs
new file mode 100644
index 000000000..14f6dc926
--- /dev/null
+++ b/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
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index 492d18446..8783e7f60 100644
--- a/git-annex-shell.hs
+++ b/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 }
diff --git a/git-annex.hs b/git-annex.hs
index 110054fd5..dff67f9d8 100644
--- a/git-annex.hs
+++ b/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