reorg Remote/*

This commit is contained in:
Joey Hess 2011-08-16 20:49:54 -04:00
parent 4545a0e78c
commit a55faff08f
9 changed files with 15 additions and 15 deletions

View file

@ -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')

44
Remote/Helper/Special.hs Normal file
View file

@ -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

61
Remote/Helper/Ssh.hs Normal file
View file

@ -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