diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 1d75c20..ee808c1 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -181,13 +181,15 @@ Report bugs at |] -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs no_color <- isJust <$> lookupEnv "NO_COLOR" + liftIO $ hSetBuffering stderr LineBuffering + liftIO $ hSetBuffering logfile LineBuffering let loggerConfig = LoggerConfig { lcPrintDebug = verbose settings , consoleOutter = T.hPutStr stderr , fileOutter = case optCommand of Nuke -> \_ -> pure () - _ -> T.appendFile logfile + _ -> T.hPutStr logfile , fancyColors = not no_color } let leanAppstate = LeanAppState settings dirs keybindings loggerConfig diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 418beb5..fb060ce 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -87,6 +87,8 @@ import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E import qualified Data.Yaml.Aeson as Y +import qualified UnliftIO.Async as Async + @@ -111,6 +113,7 @@ getDownloadsF :: ( FromJSONKey Tool , MonadThrow m , MonadFail m , MonadMask m + , MonadUnliftIO m ) => Excepts '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] @@ -121,12 +124,12 @@ getDownloadsF = do case urlSource of GHCupURL -> liftE $ getBase ghcupURL (OwnSource exts) -> do - ext <- liftE $ mapM (either pure getBase) exts + ext <- Async.mapConcurrently (either pure (liftE . getBase)) exts mergeGhcupInfo ext (OwnSpec av) -> pure av (AddSource exts) -> do base <- liftE $ getBase ghcupURL - ext <- liftE $ mapM (either pure getBase) exts + ext <- Async.mapConcurrently (either pure (liftE . getBase)) exts mergeGhcupInfo (base:ext) where diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 72ba7d3..725c7ed 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -430,6 +430,8 @@ instance HFErrorProject JSONError where eBase _ = 160 eDesc _ = "JSON decoding failed" +instance Exception JSONError + -- | A file that is supposed to exist does not exist -- (e.g. when we use file scheme to "download" something). data FileDoesNotExistError = FileDoesNotExistError FilePath @@ -443,6 +445,8 @@ instance HFErrorProject FileDoesNotExistError where eBase _ = 170 eDesc _ = "A file that is supposed to exist does not exist (oops)" +instance Exception FileDoesNotExistError + -- | The file already exists -- (e.g. when we use isolated installs with the same path). -- (e.g. This is done to prevent any overwriting) @@ -482,6 +486,8 @@ instance HFErrorProject DigestError where eBase _ = 200 eDesc _ = "File digest verification failed" +instance Exception DigestError + -- | File PGP verification failed. data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs) @@ -494,6 +500,8 @@ instance HFErrorProject GPGError where eBase _ = 210 eDesc _ = "File PGP verification failed" +instance Exception GPGError + -- | Unexpected HTTP status. data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString) deriving Show @@ -707,6 +715,8 @@ instance HFErrorProject DownloadFailed where eNum (DownloadFailed xs) = 5000 + eNum xs eDesc _ = "A download failed." +instance Exception DownloadFailed + data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1), Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) => InstallSetError (V xs1) (V xs2) instance Pretty InstallSetError where diff --git a/lib/GHCup/Prelude/Logger.hs b/lib/GHCup/Prelude/Logger.hs index b256cf9..ac01504 100644 --- a/lib/GHCup/Prelude/Logger.hs +++ b/lib/GHCup/Prelude/Logger.hs @@ -34,6 +34,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Prelude hiding ( appendFile ) import System.FilePath +import System.IO import System.IO.Error import Text.Regex.Posix @@ -45,7 +46,7 @@ initGHCupFileLogging :: ( MonadReader env m , HasDirs env , MonadIO m , MonadMask m - ) => m FilePath + ) => m Handle initGHCupFileLogging = do Dirs { logsDir } <- getDirs let logfile = fromGHCupPath logsDir "ghcup.log" @@ -58,4 +59,5 @@ initGHCupFileLogging = do forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) liftIO $ writeFile logfile "" - pure logfile + liftIO $ openFile logfile AppendMode + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index b2c6beb..4bdd0de 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -7,7 +7,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE UndecidableInstances #-} {-| Module : GHCup.Types @@ -28,13 +32,15 @@ module GHCup.Types import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) +import Control.Monad +import Control.Monad.Trans.Class ( lift ) import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Time.Calendar ( Day ) import Data.Text ( Text ) import Data.Versions -import GHC.IO.Exception ( ExitCode ) +import GHC.IO.Exception ( ExitCode, IOException(..) ) import Optics ( makeLenses ) import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import URI.ByteString @@ -46,6 +52,12 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified GHC.Generics as GHC +import Control.Monad.IO.Unlift +import UnliftIO.Exception +import Haskus.Utils.Variant.Excepts +import Haskus.Utils.Variant.VEither +import Control.Monad.Except (ExceptT(..), runExceptT) + #if !defined(BRICK) data Key = KEsc | KChar Char | KBS | KEnter @@ -725,3 +737,20 @@ instance Pretty ToolVersion where data BuildSystem = Hadrian | Make deriving (Show, Eq) + +instance forall es m . (MonadUnliftIO m, Exception (V es)) => MonadUnliftIO (Excepts es m) where + withRunInIO exceptSToIO = Excepts $ fmap (either VLeft VRight) $ try $ do + withRunInIO $ \runInIO -> + exceptSToIO (runInIO . ((\case + VLeft v -> liftIO $ throwIO $ toException v + VRight a -> pure a) <=< runE)) + + +instance Exception (V '[]) where + +instance + ( Exception x + , Typeable xs + , Exception (V xs) + ) => Exception (V (x ': xs)) +