lift types from IO to Annex

Some remotes like External need to run store and retrieve actions in Annex,
not IO. In order to do that lift, I had to dive pretty deep into the
utilities, making Utility.Gpg and Utility.Tmp be partly converted to using
MonadIO, and Control.Monad.Catch for exception handling.

There should be no behavior changes in this commit.

This commit was sponsored by Michael Barabanov.
This commit is contained in:
Joey Hess 2014-07-29 16:22:19 -04:00
parent f5af470875
commit 1d263e1e7e
8 changed files with 68 additions and 55 deletions

View file

@ -3,12 +3,13 @@
- Currently using gpg; could later be modified to support different
- crypto backends if neccessary.
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
module Crypto (
Cipher,
@ -35,6 +36,8 @@ import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.UTF8 (fromString)
import Control.Applicative
import qualified Data.Map as M
import Control.Monad.IO.Class
import Control.Monad.Catch (MonadMask)
import Common.Annex
import qualified Utility.Gpg as Gpg
@ -151,7 +154,7 @@ encryptKey mac c k = stubKey
}
type Feeder = Handle -> IO ()
type Reader a = Handle -> IO a
type Reader m a = Handle -> m a
feedFile :: FilePath -> Feeder
feedFile f h = L.hPut h =<< L.readFile f
@ -159,8 +162,8 @@ feedFile f h = L.hPut h =<< L.readFile f
feedBytes :: L.ByteString -> Feeder
feedBytes = flip L.hPut
readBytes :: (L.ByteString -> IO a) -> Reader a
readBytes a h = L.hGetContents h >>= a
readBytes :: (MonadIO m) => (L.ByteString -> m a) -> Reader m a
readBytes a h = liftIO (L.hGetContents h) >>= a
{- Runs a Feeder action, that generates content that is symmetrically
- encrypted with the Cipher (unless it is empty, in which case
@ -168,7 +171,7 @@ readBytes a h = L.hGetContents h >>= a
- read by the Reader action. Note: For public-key encryption,
- recipients MUST be included in 'params' (for instance using
- 'getGpgEncParams'). -}
encrypt :: [CommandParam] -> Cipher -> Feeder -> Reader a -> IO a
encrypt :: (MonadIO m, MonadMask m) => [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
encrypt params cipher = case cipher of
Cipher{} -> Gpg.feedRead (params ++ Gpg.stdEncryptionParams True) $
cipherPassphrase cipher
@ -177,7 +180,7 @@ encrypt params cipher = case cipher of
{- Runs a Feeder action, that generates content that is decrypted with the
- Cipher (or using a private key if the Cipher is empty), and read by the
- Reader action. -}
decrypt :: Cipher -> Feeder -> Reader a -> IO a
decrypt :: (MonadIO m, MonadMask m) => Cipher -> Feeder -> Reader m a -> m a
decrypt cipher = case cipher of
Cipher{} -> Gpg.feedRead [Param "--decrypt"] $ cipherPassphrase cipher
MacOnlyCipher{} -> Gpg.pipeLazy [Param "--decrypt"]

View file

@ -112,8 +112,8 @@ prepareStore d chunkconfig = checkPrepare
(\k -> checkDiskSpace (Just d) k 0)
(byteStorer $ store d chunkconfig)
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> IO Bool
store d chunkconfig k b p = do
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
store d chunkconfig k b p = liftIO $ do
void $ tryIO $ createDirectoryIfMissing True tmpdir
case chunkconfig of
LegacyChunks chunksize -> Legacy.store chunksize finalizer k b p tmpdir destdir
@ -138,7 +138,7 @@ store d chunkconfig k b p = do
retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
retrieve d (LegacyChunks _) = Legacy.retrieve locations d
retrieve d _ = simplyPrepare $ byteRetriever $
\k -> L.readFile =<< getLocation d k
\k -> liftIO $ L.readFile =<< getLocation d k
retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
-- no cheap retrieval possible for chunks

View file

@ -96,7 +96,7 @@ retrieve locations d basek a = do
tmpdir <- fromRepo $ gitAnnexTmpMiscDir
createAnnexDirectory tmpdir
let tmp = tmpdir </> keyFile basek ++ ".directorylegacy.tmp"
a $ Just $ byteRetriever $ \k -> do
a $ Just $ byteRetriever $ \k -> liftIO $ do
void $ withStoredFiles d locations k $ \fs -> do
forM_ fs $
S.appendFile tmp <=< S.readFile

View file

@ -27,7 +27,6 @@ import Annex.Exception
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Control.Exception
data ChunkConfig
= NoChunks
@ -91,15 +90,14 @@ storeChunks
-> Key
-> FilePath
-> MeterUpdate
-> (Key -> ContentSource -> MeterUpdate -> IO Bool)
-> (Key -> ContentSource -> MeterUpdate -> Annex Bool)
-> (Key -> Annex (Either String Bool))
-> Annex Bool
storeChunks u chunkconfig k f p storer checker =
case chunkconfig of
(UnpaddedChunks chunksize) ->
bracketIO open close (go chunksize)
_ -> showprogress $
liftIO . storer k (FileContent f)
_ -> showprogress $ storer k (FileContent f)
where
showprogress = metered (Just p) k
@ -130,7 +128,7 @@ storeChunks u chunkconfig k f p storer checker =
return True
| otherwise = do
let (chunkkey, chunkkeys') = nextChunkKeyStream chunkkeys
ifM (liftIO $ storer chunkkey (ByteContent chunk) meterupdate')
ifM (storer chunkkey (ByteContent chunk) meterupdate')
( do
let bytesprocessed' = addBytesProcessed bytesprocessed (L.length chunk)
loop bytesprocessed' (splitchunk bs) chunkkeys'
@ -234,20 +232,20 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
const (go =<< chunkKeysOnly u basek)
| otherwise = go =<< chunkKeys u chunkconfig basek
where
go ls = liftIO $ do
currsize <- catchMaybeIO $
go ls = do
currsize <- liftIO $ catchMaybeIO $
toInteger . fileSize <$> getFileStatus dest
let ls' = maybe ls (setupResume ls) currsize
firstavail currsize ls' `catchNonAsync` giveup
firstavail currsize ls' `catchNonAsyncAnnex` giveup
giveup e = do
warningIO (show e)
warning (show e)
return False
firstavail _ [] = return False
firstavail currsize ([]:ls) = firstavail currsize ls
firstavail currsize ((k:ks):ls) = do
v <- tryNonAsync $ retriever (encryptor k)
v <- tryNonAsyncAnnex $ retriever (encryptor k)
case v of
Left e
| null ls -> giveup e
@ -257,8 +255,8 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
let p = maybe basep
(offsetMeterUpdate basep . toBytesProcessed)
offset
bracket (maybe opennew openresume offset) hClose $ \h -> do
withBytes content $ sink h p
bracketIO (maybe opennew openresume offset) hClose $ \h -> do
withBytes content $ liftIO . sink h p
let sz = toBytesProcessed $
fromMaybe 0 $ keyChunkSize k
getrest p h sz sz ks
@ -267,12 +265,12 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
getrest p h sz bytesprocessed (k:ks) = do
let p' = offsetMeterUpdate p bytesprocessed
content <- retriever (encryptor k)
withBytes content $ sink h p'
withBytes content $ liftIO . sink h p'
getrest p h sz (addBytesProcessed bytesprocessed sz) ks
getunchunked = liftIO $ bracket opennew hClose $ \h -> do
getunchunked = bracketIO opennew hClose $ \h -> do
content <- retriever (encryptor basek)
withBytes content $ sink h basep
withBytes content $ liftIO . sink h basep
return True
opennew = openBinaryFile dest WriteMode

View file

@ -26,29 +26,29 @@ data ContentSource
-- Action that stores a Key's content on a remote.
-- Can throw exceptions.
type Storer = Key -> ContentSource -> MeterUpdate -> IO Bool
type Storer = Key -> ContentSource -> MeterUpdate -> Annex Bool
-- Action that retrieves a Key's content from a remote.
-- Throws exception if key is not present, or remote is not accessible.
type Retriever = Key -> IO ContentSource
type Retriever = Key -> Annex ContentSource
fileStorer :: (Key -> FilePath -> MeterUpdate -> IO Bool) -> Storer
fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer
fileStorer a k (FileContent f) m = a k f m
fileStorer a k (ByteContent b) m = do
withTmpFile "tmpXXXXXX" $ \f h -> do
fileStorer a k (ByteContent b) m = withTmpFile "tmpXXXXXX" $ \f h -> do
liftIO $ do
L.hPut h b
hClose h
a k f m
a k f m
byteStorer :: (Key -> L.ByteString -> MeterUpdate -> IO Bool) -> Storer
byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer
byteStorer a k c m = withBytes c $ \b -> a k b m
withBytes :: ContentSource -> (L.ByteString -> IO a) -> IO a
withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a
withBytes (ByteContent b) a = a b
withBytes (FileContent f) a = a =<< L.readFile f
withBytes (FileContent f) a = a =<< liftIO (L.readFile f)
fileRetriever :: (Key -> IO FilePath) -> Retriever
fileRetriever :: (Key -> Annex FilePath) -> Retriever
fileRetriever a k = FileContent <$> a k
byteRetriever :: (Key -> IO L.ByteString) -> Retriever
byteRetriever :: (Key -> Annex L.ByteString) -> Retriever
byteRetriever a k = ByteContent <$> a k

View file

@ -11,14 +11,15 @@ module Utility.Gpg where
import Control.Applicative
import Control.Concurrent
import Control.Monad.IO.Class
import qualified Data.Map as M
import Control.Monad.Catch (bracket, MonadMask)
import Common
import qualified Build.SysConfig as SysConfig
#ifndef mingw32_HOST_OS
import System.Posix.Types
import Control.Exception (bracket)
import System.Path
import Utility.Env
#else
@ -104,18 +105,18 @@ pipeStrict params input = do
-
- Note that to avoid deadlock with the cleanup stage,
- the reader must fully consume gpg's input before returning. -}
feedRead :: [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
feedRead :: (MonadIO m, MonadMask m) => [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
feedRead params passphrase feeder reader = do
#ifndef mingw32_HOST_OS
-- pipe the passphrase into gpg on a fd
(frompipe, topipe) <- createPipe
void $ forkIO $ do
(frompipe, topipe) <- liftIO createPipe
liftIO $ void $ forkIO $ do
toh <- fdToHandle topipe
hPutStrLn toh passphrase
hClose toh
let Fd pfd = frompipe
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
closeFd frompipe `after` go (passphrasefd ++ params)
liftIO (closeFd frompipe) `after` go (passphrasefd ++ params)
#else
-- store the passphrase in a temp file for gpg
withTmpFile "gpg" $ \tmpfile h -> do
@ -128,15 +129,24 @@ feedRead params passphrase feeder reader = do
go params' = pipeLazy params' feeder reader
{- Like feedRead, but without passphrase. -}
pipeLazy :: [CommandParam] -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
pipeLazy params feeder reader = do
params' <- stdParams $ Param "--batch" : params
withBothHandles createProcessSuccess (proc gpgcmd params')
$ \(to, from) -> do
void $ forkIO $ do
feeder to
hClose to
reader from
params' <- liftIO $ stdParams $ Param "--batch" : params
let p = (proc gpgcmd params')
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
}
bracket (setup p) (cleanup p) go
where
setup = liftIO . createProcess
cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid
go p = do
let (to, from) = bothHandles p
liftIO $ void $ forkIO $ do
feeder to
hClose to
reader from
{- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of

View file

@ -31,6 +31,7 @@ module Utility.Process (
stdinHandle,
stdoutHandle,
stderrHandle,
bothHandles,
processHandle,
devNull,
) where

View file

@ -9,11 +9,12 @@
module Utility.Tmp where
import Control.Exception (bracket)
import System.IO
import System.Directory
import Control.Monad.IfElse
import System.FilePath
import Control.Monad.IO.Class
import Control.Monad.Catch (bracket, MonadMask)
import Utility.Exception
import Utility.FileSystemEncoding
@ -42,18 +43,18 @@ viaTmp a file content = bracket setup cleanup use
{- Runs an action with a tmp file located in the system's tmp directory
- (or in "." if there is none) then removes the file. -}
withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a
withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a
withTmpFile template a = do
tmpdir <- catchDefaultIO "." getTemporaryDirectory
tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
withTmpFileIn tmpdir template a
{- Runs an action with a tmp file located in the specified directory,
- then removes the file. -}
withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a
withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
withTmpFileIn tmpdir template a = bracket create remove use
where
create = openTempFile tmpdir template
remove (name, handle) = do
create = liftIO $ openTempFile tmpdir template
remove (name, handle) = liftIO $ do
hClose handle
catchBoolIO (removeFile name >> return True)
use (name, handle) = a name handle