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:
parent
f5af470875
commit
1d263e1e7e
8 changed files with 68 additions and 55 deletions
15
Crypto.hs
15
Crypto.hs
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -31,6 +31,7 @@ module Utility.Process (
|
|||
stdinHandle,
|
||||
stdoutHandle,
|
||||
stderrHandle,
|
||||
bothHandles,
|
||||
processHandle,
|
||||
devNull,
|
||||
) where
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue