Merge pull request #198 from haskell-works/newhoggy/catch-log-rethrow…

…-exceptions-during-download

Catch log and rethrow exceptions during download.

.gitignore

@@ -22,3 +22,4 @@ cabal.project.local~
 .ghc.environment.*
 
 .vscode/ipch
+/hie.yaml

src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments    #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
@@ -8,13 +9,17 @@ module HaskellWorks.CabalCache.Concurrent.DownloadQueue
   , runQueue
   ) where
 
-import Control.Monad.IO.Class
+import Control.Monad.Catch    (MonadMask(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Function          ((&))
 import Data.Set               ((\\))
 
 import qualified Control.Concurrent.STM                  as STM
+import qualified Control.Monad.Catch                     as CMC
 import qualified Data.Relation                           as R
 import qualified Data.Set                                as S
 import qualified HaskellWorks.CabalCache.Concurrent.Type as Z
+import qualified System.IO                               as IO
 
 data DownloadStatus = DownloadSuccess | DownloadFailure deriving (Eq, Show)
 
@@ -57,17 +62,20 @@ failDownload Z.DownloadQueue {..} packageId = do
   STM.writeTVar tUploading  $ S.delete packageId uploading
   STM.writeTVar tFailures   $ S.insert packageId failures
 
-runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m ()
+runQueue :: (MonadIO m, MonadMask m) => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m ()
 runQueue downloadQueue f = do
-  maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue
+  maybePackageId <- (liftIO $ STM.atomically $ takeReady downloadQueue)
 
   case maybePackageId of
     Just packageId -> do
       downloadStatus <- f packageId
+        & CMC.handleAll \e -> do
+            liftIO $ IO.hPutStrLn IO.stderr $ "Exception during download: " <> show e
+            liftIO $ IO.hFlush IO.stderr
+            CMC.throwM e
       case downloadStatus of
-        DownloadSuccess -> liftIO $ STM.atomically $ commit downloadQueue packageId
-        DownloadFailure -> liftIO $ STM.atomically $ failDownload downloadQueue packageId
+        DownloadSuccess -> do liftIO $ STM.atomically $ commit downloadQueue packageId
+        DownloadFailure -> do liftIO $ STM.atomically $ failDownload downloadQueue packageId
       runQueue downloadQueue f
 
-    Nothing -> do
-      return ()
+    Nothing -> return ()