full encryption support for directory special remotes
This commit is contained in:
parent
9fe7e6be70
commit
4f9fafa023
3 changed files with 83 additions and 15 deletions
|
@ -9,6 +9,8 @@
|
|||
-}
|
||||
|
||||
module Crypto (
|
||||
Cipher,
|
||||
EncryptedCipher,
|
||||
genCipher,
|
||||
updateCipher,
|
||||
storeCipher,
|
||||
|
@ -133,7 +135,10 @@ gpgRead params = pOpen ReadFromPipe "gpg" (gpgParams params) hGetContentsStrict
|
|||
|
||||
gpgPipeStrict :: [CommandParam] -> String -> IO String
|
||||
gpgPipeStrict params input = do
|
||||
(_, output) <- pipeBoth "gpg" (gpgParams params) input
|
||||
(pid, fromh, toh) <- hPipeBoth "gpg" (gpgParams params)
|
||||
_ <- forkIO $ finally (hPutStr toh input) (hClose toh)
|
||||
output <- hGetContentsStrict fromh
|
||||
forceSuccess pid
|
||||
return output
|
||||
|
||||
gpgPipeBytes :: [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString)
|
||||
|
|
|
@ -7,6 +7,7 @@
|
|||
|
||||
module Remote.Directory (remote) where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import IO
|
||||
import Control.Exception.Extensible (IOException)
|
||||
import qualified Data.Map as M
|
||||
|
@ -27,6 +28,7 @@ import Content
|
|||
import Utility
|
||||
import Remote.Special
|
||||
import Remote.Encrypted
|
||||
import Crypto
|
||||
|
||||
remote :: RemoteType Annex
|
||||
remote = RemoteType {
|
||||
|
@ -37,17 +39,17 @@ remote = RemoteType {
|
|||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
||||
gen r u _ = do
|
||||
gen r u c = do
|
||||
dir <- getConfig r "directory" (error "missing directory")
|
||||
cst <- remoteCost r cheapRemoteCost
|
||||
return $ Remote {
|
||||
uuid = u,
|
||||
cost = cst,
|
||||
name = Git.repoDescribe r,
|
||||
storeKey = store dir,
|
||||
retrieveKeyFile = retrieve dir,
|
||||
removeKey = remove dir,
|
||||
hasKey = checkPresent dir,
|
||||
storeKey = storeKeyEncrypted c $ store dir,
|
||||
retrieveKeyFile = retrieveKeyFileEncrypted c $ retrieve dir,
|
||||
removeKey = removeKeyEncrypted c $ remove dir,
|
||||
hasKey = hasKeyEncrypted c $ checkPresent dir,
|
||||
hasKeyCheap = True,
|
||||
config = Nothing
|
||||
}
|
||||
|
@ -72,25 +74,43 @@ dirKey d k = d </> hashDirMixed k </> f </> f
|
|||
where
|
||||
f = keyFile k
|
||||
|
||||
store :: FilePath -> Key -> Annex Bool
|
||||
store d k = do
|
||||
store :: FilePath -> Key -> Maybe (Cipher, Key) -> Annex Bool
|
||||
store d k c = do
|
||||
g <- Annex.gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
let src = gitAnnexLocation g k
|
||||
liftIO $ catch (copy src) (const $ return False)
|
||||
where
|
||||
dest = dirKey d k
|
||||
dir = parentDir dest
|
||||
copy src = do
|
||||
copy src = case c of
|
||||
Just (cipher, enckey) -> do
|
||||
content <- L.readFile src
|
||||
let dest = dirKey d enckey
|
||||
prep dest
|
||||
withEncryptedContent cipher content $ \s -> do
|
||||
L.writeFile dest s
|
||||
cleanup True dest
|
||||
_ -> do
|
||||
let dest = dirKey d k
|
||||
prep dest
|
||||
ok <- copyFile src dest
|
||||
cleanup ok dest
|
||||
prep dest = liftIO $ do
|
||||
let dir = parentDir dest
|
||||
createDirectoryIfMissing True dir
|
||||
allowWrite dir
|
||||
ok <- copyFile src dest
|
||||
cleanup ok dest = do
|
||||
when ok $ do
|
||||
let dir = parentDir dest
|
||||
preventWrite dest
|
||||
preventWrite dir
|
||||
return ok
|
||||
|
||||
retrieve :: FilePath -> Key -> FilePath -> Annex Bool
|
||||
retrieve d k f = liftIO $ copyFile (dirKey d k) f
|
||||
retrieve :: FilePath -> Key -> FilePath -> Maybe (Cipher, Key) -> Annex Bool
|
||||
retrieve d k f Nothing = liftIO $ copyFile (dirKey d k) f
|
||||
retrieve d k f (Just (cipher, enckey)) =
|
||||
liftIO $ flip catch (const $ return False) $ do
|
||||
content <- L.readFile (dirKey d enckey)
|
||||
withDecryptedContent cipher content $ L.writeFile f
|
||||
return True
|
||||
|
||||
remove :: FilePath -> Key -> Annex Bool
|
||||
remove d k = liftIO $ catch del (const $ return False)
|
||||
|
|
|
@ -13,6 +13,8 @@ import Control.Monad.State (liftIO)
|
|||
import Types
|
||||
import RemoteClass
|
||||
import Crypto
|
||||
import qualified Annex
|
||||
import Messages
|
||||
|
||||
{- 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
|
||||
|
@ -29,3 +31,44 @@ encryptionSetup c =
|
|||
use a = do
|
||||
cipher <- liftIO a
|
||||
return $ M.delete "encryption" $ storeCipher c cipher
|
||||
|
||||
{- Helpers that can be applied to a Remote's normal actions to
|
||||
- add crypto support. -}
|
||||
storeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Maybe (Cipher, Key) -> Annex a) -> Key -> Annex a
|
||||
storeKeyEncrypted c a k = a k =<< cipherKey c k
|
||||
retrieveKeyFileEncrypted :: Maybe RemoteConfig -> (Key -> FilePath -> Maybe (Cipher, Key) -> Annex a) -> Key -> FilePath -> Annex a
|
||||
retrieveKeyFileEncrypted c a k f = a k f =<< cipherKey c k
|
||||
removeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
removeKeyEncrypted = withEncryptedKey
|
||||
hasKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
hasKeyEncrypted = withEncryptedKey
|
||||
|
||||
{- Gets encryption Cipher, and encrypted version of Key.
|
||||
-
|
||||
- The decrypted Cipher is cached in the Annex state. -}
|
||||
cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
|
||||
cipherKey Nothing _ = return Nothing
|
||||
cipherKey (Just c) k = do
|
||||
cache <- Annex.getState Annex.cipher
|
||||
case cache of
|
||||
Just cipher -> ret cipher
|
||||
Nothing -> case extractCipher c of
|
||||
Nothing -> return Nothing
|
||||
Just encipher -> do
|
||||
showNote "getting encryption key"
|
||||
cipher <- liftIO $ decryptCipher c encipher
|
||||
Annex.changeState (\s -> s { Annex.cipher = Just cipher })
|
||||
ret cipher
|
||||
where
|
||||
ret cipher = do
|
||||
k' <- liftIO $ encryptKey cipher k
|
||||
return $ Just (cipher, k')
|
||||
|
||||
{- Passes the encrypted version of the key to the action when encryption
|
||||
- is enabled, and the non-encrypted version otherwise. -}
|
||||
withEncryptedKey :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
|
||||
withEncryptedKey c a k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> a k
|
||||
Just (_, k') -> a k'
|
||||
|
|
Loading…
Reference in a new issue