diff --git a/exes/MirrorClient.hs b/exes/MirrorClient.hs index 7008ea0e3..c4ef1cf9c 100644 --- a/exes/MirrorClient.hs +++ b/exes/MirrorClient.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Main (main) where -- stdlib @@ -212,8 +214,9 @@ mirrorPackage verbosity opts sourceRepo targetRepo pkginfo = do notifyResponse (GetPackageFailed theError pkgid) Nothing -> do notifyResponse GetPackageOk - liftIO $ sanitiseTarball verbosity (stateDir opts) locTgz - uploadPackage targetRepo (mirrorUploaders opts) pkginfo locCab locTgz + mirrorHandle (\(e :: SomeException) -> liftIO $ putStrLn $ "An error occurred: " <> show e) $ do + liftIO $ sanitiseTarball verbosity (stateDir opts) locTgz + uploadPackage targetRepo (mirrorUploaders opts) pkginfo locCab locTgz removeTempFiles :: MirrorSession () removeTempFiles = liftIO $ handle ignoreDoesNotExist $ do diff --git a/src/Distribution/Client/Mirror/Session.hs b/src/Distribution/Client/Mirror/Session.hs index 9d63f9c96..ed1fb8545 100644 --- a/src/Distribution/Client/Mirror/Session.hs +++ b/src/Distribution/Client/Mirror/Session.hs @@ -19,6 +19,7 @@ module Distribution.Client.Mirror.Session ( , Unlift(..) , askUnlift , mirrorFinally + , mirrorHandle -- * Errors , MirrorError(..) , Entity(..) @@ -222,6 +223,11 @@ mirrorFinally a b = do run <- askUnlift liftIO $ unlift run a `finally` unlift run b +mirrorHandle :: Exception e => (e -> MirrorSession a) -> MirrorSession a -> MirrorSession a +mirrorHandle k m = do + run <- askUnlift + liftIO $ handle (\e -> unlift run $ k e) $ unlift run m + mirrorAskHttpLib :: MirrorSession Sec.HttpLib mirrorAskHttpLib = MirrorSession $ do MirrorInternalEnv{..} <- ask