diff options
-rw-r--r-- | Crypto.hs | 7 | ||||
-rw-r--r-- | Remote/Directory.hs | 48 | ||||
-rw-r--r-- | Remote/Encrypted.hs | 43 |
3 files changed, 83 insertions, 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) diff --git a/Remote/Directory.hs b/Remote/Directory.hs index bb1ef60e4..5ea0a1e6b 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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) diff --git a/Remote/Encrypted.hs b/Remote/Encrypted.hs index ae4044620..2a0fb13bc 100644 --- a/Remote/Encrypted.hs +++ b/Remote/Encrypted.hs @@ -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' |