reorg Remote/*

3 files changed, 192 insertions, 0 deletions

diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
new file mode 100644
index 000000000..04041c655
--- /dev/null
+++ b/Remote/Helper/Encryptable.hs
@@ -0,0 +1,87 @@
+{- common functions for encryptable remotes
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Encryptable where
+
+import qualified Data.Map as M
+import Control.Monad.State (liftIO)
+
+import Types
+import Types.Remote
+import Crypto
+import qualified Annex
+import Messages
+import Config
+
+{- Encryption setup for a remote. The user must specify whether to use
+ - an encryption key, or not encrypt. An encrypted cipher is created, or is
+ - updated to be accessible to an additional encryption key. -}
+encryptionSetup :: RemoteConfig -> Annex RemoteConfig
+encryptionSetup c =
+	case (M.lookup "encryption" c, extractCipher c) of
+		(Nothing, Nothing) -> error "Specify encryption=key or encryption=none"
+		(Just "none", Nothing) -> return c
+		(Just "none", Just _) -> error "Cannot change encryption type of existing remote."
+		(Nothing, Just _) -> return c
+		(Just _, Nothing) -> use "encryption setup" $ genCipher c
+		(Just _, Just v) -> use "encryption updated" $ updateCipher c v
+	where
+		use m a = do
+			cipher <- liftIO a
+			showNote $ m ++ " " ++ describeCipher cipher
+			return $ M.delete "encryption" $ storeCipher c cipher
+
+{- Modifies a Remote to support encryption.
+ -
+ - Two additional functions must be provided by the remote,
+ - to support storing and retrieving encrypted content. -}
+encryptableRemote
+	:: Maybe RemoteConfig
+	-> ((Cipher, Key) -> Key -> Annex Bool)
+	-> ((Cipher, Key) -> FilePath -> Annex Bool)
+	-> Remote Annex 
+	-> Remote Annex
+encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = 
+	r {
+		storeKey = store,
+		retrieveKeyFile = retrieve,
+		removeKey = withkey $ removeKey r,
+		hasKey = withkey $ hasKey r,
+		cost = cost r + encryptedRemoteCostAdj
+	}
+	where
+		store k = cip k >>= maybe
+			(storeKey r k)
+			(`storeKeyEncrypted` k)
+		retrieve k f = cip k >>= maybe
+			(retrieveKeyFile r k f)
+			(`retrieveKeyFileEncrypted` f)
+		withkey a k = cip k >>= maybe (a k) (a . snd)
+		cip = cipherKey c
+
+{- Gets encryption Cipher. The decrypted Cipher is cached in the Annex
+ - state. -}
+remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
+remoteCipher c = maybe expensive cached =<< Annex.getState Annex.cipher
+	where
+		cached cipher = return $ Just cipher
+		expensive = case extractCipher c of
+			Nothing -> return Nothing
+			Just encipher -> do
+				showNote "gpg"
+				cipher <- liftIO $ decryptCipher c encipher
+				Annex.changeState (\s -> s { Annex.cipher = Just cipher })
+				return $ Just cipher
+
+{- Gets encryption Cipher, and encrypted version of Key. -}
+cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
+cipherKey Nothing _ = return Nothing
+cipherKey (Just c) k = remoteCipher c >>= maybe (return Nothing) encrypt
+	where
+		encrypt ciphertext = do
+			k' <- liftIO $ encryptKey ciphertext k
+			return $ Just (ciphertext, k')
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
new file mode 100644
index 000000000..c302a0ff5
--- /dev/null
+++ b/Remote/Helper/Special.hs
@@ -0,0 +1,44 @@
+{- common functions for special remotes
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Special where
+
+import qualified Data.Map as M
+import Data.Maybe
+import Data.String.Utils
+import Control.Monad.State (liftIO)
+
+import Types
+import Types.Remote
+import qualified Git
+import qualified Annex
+import UUID
+import Utility
+
+{- Special remotes don't have a configured url, so Git.Repo does not
+ - automatically generate remotes for them. This looks for a different
+ - configuration key instead.
+ -}
+findSpecialRemotes :: String -> Annex [Git.Repo]
+findSpecialRemotes s = do
+	g <- Annex.gitRepo
+	return $ map construct $ remotepairs g
+	where
+		remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r
+		construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
+		match k _ = startswith "remote." k && endswith (".annex-"++s) k
+
+{- Sets up configuration for a special remote in .git/config. -}
+gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex ()
+gitConfigSpecialRemote u c k v = do
+	g <- Annex.gitRepo
+	liftIO $ do
+		Git.run g "config" [Param (configsetting $ "annex-"++k), Param v]
+		Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
+	where
+		remotename = fromJust (M.lookup "name" c)
+		configsetting s = "remote." ++ remotename ++ "." ++ s
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
new file mode 100644
index 000000000..478b01881
--- /dev/null
+++ b/Remote/Helper/Ssh.hs
@@ -0,0 +1,61 @@
+{- git-annex remote access with ssh
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Ssh where
+
+import Control.Monad.State (liftIO)
+
+import qualified Git
+import Utility
+import Types
+import Config
+
+{- Generates parameters to ssh to a repository's host and run a command.
+ - Caller is responsible for doing any neccessary shellEscaping of the
+ - passed command. -}
+sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+sshToRepo repo sshcmd = do
+	s <- getConfig repo "ssh-options" ""
+	let sshoptions = map Param (words s)
+	let sshport = case Git.urlPort repo of
+		Nothing -> []
+		Just p -> [Param "-p", Param (show p)]
+	let sshhost = Param $ Git.urlHostUser repo
+	return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
+
+{- Generates parameters to run a git-annex-shell command on a remote
+ - repository. -}
+git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
+git_annex_shell r command params
+	| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
+	| Git.repoIsSsh r = do
+		sshparams <- sshToRepo r [Param sshcmd]
+		return $ Just ("ssh", sshparams)
+	| otherwise = return Nothing
+	where
+		dir = Git.workTree r
+		shellcmd = "git-annex-shell"
+		shellopts = Param command : File dir : params
+		sshcmd = shellcmd ++ " " ++ 
+			unwords (map shellEscape $ toCommand shellopts)
+
+{- Uses a supplied function (such as boolSystem) to run a git-annex-shell
+ - command on a remote.
+ -
+ - Or, if the remote does not support running remote commands, returns
+ - a specified error value. -}
+onRemote 
+	:: Git.Repo
+	-> (FilePath -> [CommandParam] -> IO a, a)
+	-> String
+	-> [CommandParam]
+	-> Annex a
+onRemote r (with, errorval) command params = do
+	s <- git_annex_shell r command params
+	case s of
+		Just (c, ps) -> liftIO $ with c ps
+		Nothing -> return errorval