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.

8 files changed, 68 insertions, 55 deletions

diff --git a/Crypto.hs b/Crypto.hs
index 89b47f318..dcefc2959 100644
--- a/Crypto.hs
+++ b/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"]
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