From 24c1d3fe0b720ad78399284a3645d0bb6dc15b0d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Jul 2014 23:24:27 -0400 Subject: add some more exception handling primitives --- Annex/Exception.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'Annex') diff --git a/Annex/Exception.hs b/Annex/Exception.hs index 41a9ed921..5ecbd28a0 100644 --- a/Annex/Exception.hs +++ b/Annex/Exception.hs @@ -5,12 +5,13 @@ - AnnexState are retained. This works because the Annex monad - internally stores the AnnexState in a MVar. - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} module Annex.Exception ( bracketIO, @@ -19,6 +20,8 @@ module Annex.Exception ( tryAnnexIO, throwAnnex, catchAnnex, + catchNonAsyncAnnex, + tryNonAsyncAnnex, ) where import qualified Control.Monad.Catch as M @@ -48,3 +51,13 @@ throwAnnex = M.throwM {- catch in the Annex monad -} catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a catchAnnex = M.catch + +{- catchs all exceptions except for async exceptions -} +catchNonAsyncAnnex :: Annex a -> (SomeException -> Annex a) -> Annex a +catchNonAsyncAnnex a onerr = a `M.catches` + [ M.Handler (\ (e :: AsyncException) -> throwAnnex e) + , M.Handler (\ (e :: SomeException) -> onerr e) + ] + +tryNonAsyncAnnex :: Annex a -> Annex (Either SomeException a) +tryNonAsyncAnnex a = (Right <$> a) `catchNonAsyncAnnex` (return . Left) -- cgit v1.2.3 From e55bc5640997362f1f77a5423f7556b307377f61 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jul 2014 17:17:41 -0400 Subject: allow Retriever action to update the progress meter Needed for eg, Remote.External. Generally, any Retriever that stores content in a file is responsible for updating the meter, while ones that procude a lazy bytestring cannot update the meter, so are not asked to. --- Annex/Content.hs | 5 ++++- Remote/Directory.hs | 4 ++-- Remote/Helper/Chunked.hs | 33 ++++++++++++++++++++++----------- Remote/Helper/ChunkedEncryptable.hs | 9 +++++++-- Types/StoreRetrieve.hs | 24 +++++++++++------------- 5 files changed, 46 insertions(+), 29 deletions(-) (limited to 'Annex') diff --git a/Annex/Content.hs b/Annex/Content.hs index 8ad3d5e65..6975f322f 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -264,7 +264,10 @@ prepTmp key = do createAnnexDirectory (parentDir tmp) return tmp -{- Creates a temp file, runs an action on it, and cleans up the temp file. -} +{- Creates a temp file for a key, runs an action on it, and cleans up + - the temp file. If the action throws an exception, the temp file is + - left behind, which allows for resuming. + -} withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 9f2775965..37942a295 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -137,8 +137,8 @@ store d chunkconfig k b p = liftIO $ do retrieve :: FilePath -> ChunkConfig -> Preparer Retriever retrieve d (LegacyChunks _) = Legacy.retrieve locations d -retrieve d _ = simplyPrepare $ byteRetriever $ - \k -> liftIO $ L.readFile =<< getLocation d k +retrieve d _ = simplyPrepare $ byteRetriever $ \k -> + liftIO $ L.readFile =<< getLocation d k retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool -- no cheap retrieval possible for chunks diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index ccdd35271..102ced8f4 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -221,7 +221,7 @@ retrieveChunks -> Key -> FilePath -> MeterUpdate - -> (Handle -> MeterUpdate -> L.ByteString -> IO ()) + -> (Handle -> Maybe MeterUpdate -> L.ByteString -> IO ()) -> Annex Bool retrieveChunks retriever u chunkconfig encryptor basek dest basep sink | noChunks chunkconfig = @@ -245,18 +245,18 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink firstavail _ [] = return False firstavail currsize ([]:ls) = firstavail currsize ls firstavail currsize ((k:ks):ls) = do - v <- tryNonAsyncAnnex $ retriever (encryptor k) + let offset = resumeOffset currsize k + let p = maybe basep + (offsetMeterUpdate basep . toBytesProcessed) + offset + v <- tryNonAsyncAnnex $ retriever (encryptor k) p case v of Left e | null ls -> giveup e | otherwise -> firstavail currsize ls Right content -> do - let offset = resumeOffset currsize k - let p = maybe basep - (offsetMeterUpdate basep . toBytesProcessed) - offset bracketIO (maybe opennew openresume offset) hClose $ \h -> do - withBytes content $ liftIO . sink h p + tosink h p content let sz = toBytesProcessed $ fromMaybe 0 $ keyChunkSize k getrest p h sz sz ks @@ -264,13 +264,11 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink getrest _ _ _ _ [] = return True getrest p h sz bytesprocessed (k:ks) = do let p' = offsetMeterUpdate p bytesprocessed - content <- retriever (encryptor k) - withBytes content $ liftIO . sink h p' + tosink h p' =<< retriever (encryptor k) p' getrest p h sz (addBytesProcessed bytesprocessed sz) ks getunchunked = bracketIO opennew hClose $ \h -> do - content <- retriever (encryptor basek) - withBytes content $ liftIO . sink h basep + tosink h basep =<< retriever (encryptor basek) basep return True opennew = openBinaryFile dest WriteMode @@ -282,6 +280,19 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink hSeek h AbsoluteSeek startpoint return h + {- Progress meter updating is a bit tricky: If the Retriever + - populates a file, it is responsible for updating progress + - as the file is being retrieved. + - + - However, if the Retriever generates a lazy ByteString, + - it is not responsible for updating progress (often it cannot). + - Instead, the sink is passed a meter to update as it consumes + - the ByteString. -} + tosink h p (ByteContent b) = liftIO $ + sink h (Just p) b + tosink h _ (FileContent f) = liftIO $ + sink h Nothing =<< L.readFile f + {- Can resume when the chunk's offset is at or before the end of - the dest file. -} resumeOffset :: Maybe Integer -> Key -> Maybe Integer diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs index b851ecd94..024a53309 100644 --- a/Remote/Helper/ChunkedEncryptable.hs +++ b/Remote/Helper/ChunkedEncryptable.hs @@ -14,6 +14,7 @@ module Remote.Helper.ChunkedEncryptable ( Storer, Retriever, simplyPrepare, + ContentSource, checkPrepare, fileStorer, byteStorer, @@ -36,6 +37,8 @@ import Remote.Helper.Encryptable as X import Annex.Content import Annex.Exception +import qualified Data.ByteString.Lazy as L + simplyPrepare :: helper -> Preparer helper simplyPrepare helper _ a = a $ Just helper @@ -101,8 +104,10 @@ chunkedEncryptableRemote c preparestorer prepareretriever baser = encr retrieveChunks retriever (uuid baser) chunkconfig enck k dest p' sink go Nothing = return False - sink h p' b = do - let write = meteredWrite p' h + sink h mp b = do + let write = case mp of + Just p' -> meteredWrite p' h + Nothing -> L.hPut h case enc of Nothing -> write b Just (cipher, _) -> diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs index ccbf99e3f..dfee20758 100644 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -10,8 +10,8 @@ module Types.StoreRetrieve where import Common.Annex +import Annex.Content import Utility.Metered -import Utility.Tmp import qualified Data.ByteString.Lazy as L @@ -30,25 +30,23 @@ 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 -> Annex ContentSource +type Retriever = Key -> MeterUpdate -> Annex ContentSource fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer fileStorer a k (FileContent f) m = a k f m -fileStorer a k (ByteContent b) m = withTmpFile "tmpXXXXXX" $ \f h -> do - liftIO $ do - L.hPut h b - hClose h - a k f m +fileStorer a k (ByteContent b) m = withTmp k $ \tmp -> do + liftIO $ L.writeFile tmp b + a k tmp m byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer byteStorer a k c m = withBytes c $ \b -> a k b m +fileRetriever :: (Key -> MeterUpdate -> Annex FilePath) -> Retriever +fileRetriever a k m = FileContent <$> a k m + +byteRetriever :: (Key -> Annex L.ByteString) -> Retriever +byteRetriever a k _m = ByteContent <$> a k + withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a withBytes (ByteContent b) a = a b withBytes (FileContent f) a = a =<< liftIO (L.readFile f) - -fileRetriever :: (Key -> Annex FilePath) -> Retriever -fileRetriever a k = FileContent <$> a k - -byteRetriever :: (Key -> Annex L.ByteString) -> Retriever -byteRetriever a k = ByteContent <$> a k -- cgit v1.2.3 From a2dfbf18972339929c49cb77e76cf246ada2acdc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Jul 2014 18:40:40 -0400 Subject: better type for Retriever Putting a callback in the Retriever type allows for the callback to remove the retrieved file when it's done with it. I did not really want to make Retriever be fixed to Annex Bool, but when I tried to use Annex a, I got into some type of type mess. --- Annex/Content.hs | 1 + Remote/Helper/Chunked.hs | 25 +++++++++++++++---------- Remote/Helper/ChunkedEncryptable.hs | 37 +++++++++++++++++++++++++++++++++---- Types/StoreRetrieve.hs | 27 ++++----------------------- 4 files changed, 53 insertions(+), 37 deletions(-) (limited to 'Annex') diff --git a/Annex/Content.hs b/Annex/Content.hs index 6975f322f..eb84f2fe9 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -16,6 +16,7 @@ module Annex.Content ( getViaTmpChecked, getViaTmpUnchecked, prepGetViaTmpChecked, + prepTmp, withTmp, checkDiskSpace, moveAnnex, diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 102ced8f4..ae949abc3 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -249,26 +249,28 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink let p = maybe basep (offsetMeterUpdate basep . toBytesProcessed) offset - v <- tryNonAsyncAnnex $ retriever (encryptor k) p - case v of - Left e - | null ls -> giveup e - | otherwise -> firstavail currsize ls - Right content -> do + v <- tryNonAsyncAnnex $ + retriever (encryptor k) p $ \content -> bracketIO (maybe opennew openresume offset) hClose $ \h -> do tosink h p content let sz = toBytesProcessed $ fromMaybe 0 $ keyChunkSize k getrest p h sz sz ks + `catchNonAsyncAnnex` giveup + case v of + Left e + | null ls -> giveup e + | otherwise -> firstavail currsize ls + Right r -> return r getrest _ _ _ _ [] = return True getrest p h sz bytesprocessed (k:ks) = do let p' = offsetMeterUpdate p bytesprocessed - tosink h p' =<< retriever (encryptor k) p' + retriever (encryptor k) p' $ tosink h p' getrest p h sz (addBytesProcessed bytesprocessed sz) ks getunchunked = bracketIO opennew hClose $ \h -> do - tosink h basep =<< retriever (encryptor basek) basep + retriever (encryptor basek) basep $ tosink h basep return True opennew = openBinaryFile dest WriteMode @@ -288,10 +290,13 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink - it is not responsible for updating progress (often it cannot). - Instead, the sink is passed a meter to update as it consumes - the ByteString. -} - tosink h p (ByteContent b) = liftIO $ + tosink h p (ByteContent b) = liftIO $ do sink h (Just p) b - tosink h _ (FileContent f) = liftIO $ + return True + tosink h _ (FileContent f) = liftIO $ do sink h Nothing =<< L.readFile f + nukeFile h + return True {- Can resume when the chunk's offset is at or before the end of - the dest file. -} diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs index 024a53309..550a6934b 100644 --- a/Remote/Helper/ChunkedEncryptable.hs +++ b/Remote/Helper/ChunkedEncryptable.hs @@ -6,8 +6,6 @@ -} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE FlexibleContexts #-} module Remote.Helper.ChunkedEncryptable ( Preparer, @@ -39,17 +37,48 @@ import Annex.Exception import qualified Data.ByteString.Lazy as L +-- Use when nothing needs to be done to prepare a helper. simplyPrepare :: helper -> Preparer helper simplyPrepare helper _ a = a $ Just helper +-- Use to run a check when preparing a helper. checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper checkPrepare checker helper k a = ifM (checker k) ( a (Just helper) , a Nothing ) -{- Modifies a base Remote to support both chunking and encryption. - -} +-- A Storer that expects to be provided with a file containing +-- the content of the key to store. +fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer +fileStorer a k (FileContent f) m = a k f m +fileStorer a k (ByteContent b) m = withTmp k $ \f -> do + liftIO $ L.writeFile f b + a k f m + +-- A Storer that expects to be provided with a L.ByteString of +-- the content to store. +byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer +byteStorer a k c m = withBytes c $ \b -> a k b m + +-- A Retriever that writes the content of a Key to a provided file. +-- It is responsible for updating the progress meter as it retrieves data. +fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever +fileRetriever a k m callback = bracketAnnex (prepTmp k) (liftIO . nukeFile) go + where + go f = do + a f k m + callback (FileContent f) + +-- A Retriever that generates a L.ByteString containing the Key's content. +byteRetriever :: (Key -> Annex L.ByteString) -> Retriever +byteRetriever a k _m callback = callback =<< (ByteContent <$> a k) + +withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a +withBytes (ByteContent b) a = a b +withBytes (FileContent f) a = a =<< liftIO (L.readFile f) + +-- Modifies a base Remote to support both chunking and encryption. chunkedEncryptableRemote :: RemoteConfig -> Preparer Storer diff --git a/Types/StoreRetrieve.hs b/Types/StoreRetrieve.hs index dfee20758..0ee2fd501 100644 --- a/Types/StoreRetrieve.hs +++ b/Types/StoreRetrieve.hs @@ -1,4 +1,4 @@ -{- Types for Storer and Retriever +{- Types for Storer and Retriever actions for remotes. - - Copyright 2014 Joey Hess - @@ -10,7 +10,6 @@ module Types.StoreRetrieve where import Common.Annex -import Annex.Content import Utility.Metered import qualified Data.ByteString.Lazy as L @@ -28,25 +27,7 @@ data ContentSource -- Can throw exceptions. type Storer = Key -> ContentSource -> MeterUpdate -> Annex Bool --- Action that retrieves a Key's content from a remote. +-- Action that retrieves a Key's content from a remote, passing it to a +-- callback. -- Throws exception if key is not present, or remote is not accessible. -type Retriever = Key -> MeterUpdate -> Annex ContentSource - -fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer -fileStorer a k (FileContent f) m = a k f m -fileStorer a k (ByteContent b) m = withTmp k $ \tmp -> do - liftIO $ L.writeFile tmp b - a k tmp m - -byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer -byteStorer a k c m = withBytes c $ \b -> a k b m - -fileRetriever :: (Key -> MeterUpdate -> Annex FilePath) -> Retriever -fileRetriever a k m = FileContent <$> a k m - -byteRetriever :: (Key -> Annex L.ByteString) -> Retriever -byteRetriever a k _m = ByteContent <$> a k - -withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a -withBytes (ByteContent b) a = a b -withBytes (FileContent f) a = a =<< liftIO (L.readFile f) +type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex Bool) -> Annex Bool -- cgit v1.2.3