diff options
| -rw-r--r-- | Crypto.hs | 15 | ||||
| -rw-r--r-- | Remote/Directory.hs | 6 | ||||
| -rw-r--r-- | Remote/Directory/LegacyChunked.hs | 2 | ||||
| -rw-r--r-- | Remote/Helper/Chunked.hs | 28 | ||||
| -rw-r--r-- | Types/StoreRetrieve.hs | 22 | ||||
| -rw-r--r-- | Utility/Gpg.hs | 36 | ||||
| -rw-r--r-- | Utility/Process.hs | 1 | ||||
| -rw-r--r-- | Utility/Tmp.hs | 13 |
8 files changed, 68 insertions, 55 deletions
@@ -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"] diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 5d8a040d4..9f2775965 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index af846a2e6..312119f4e 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -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 diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 70e541cce..ccdd35271 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -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 diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs index 2520d6309..ccbf99e3f 100644 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -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 diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index a00bf99da..410259b11 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -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 diff --git a/Utility/Process.hs b/Utility/Process.hs index 1f722af81..e25618eba 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ module Utility.Process ( stdinHandle, stdoutHandle, stderrHandle, + bothHandles, processHandle, devNull, ) where diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index bed30bb4d..7da5cc284 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -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 |