Implement async fetching

app/ghcup/Main.hs

@@ -181,13 +181,15 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
           -- 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

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

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

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
+

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))
+