Implement async fetching

Wrt #836

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

docs/install.md

@@ -318,6 +318,24 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
 
 All set. You can run `cabal init` now in an empty directory to start a project.
 
+## Esoteric distros
+
+### Void Linux
+
+Since void linux can be installed with glibc and musl, it's hard to support correctly with ghcup.
+One way to make ghcup work on **Void Linux musl** is to follow the [Overriding distro detection](../guide/#overriding-distro-detection)
+section and tell it to consider Alpine bindists only. E.g.:
+
+```sh
+curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_MINIMAL=1 sh
+source ~/.ghcup/env
+ghcup config set platform-override '{ "arch": "A_64", "platform": { "contents": "Alpine", "tag": "Linux" }, "version": "3.17" }'
+ghcup install cabal --set latest
+ghcup install ghc --set latest
+ghcup install stack --set latest
+ghcup install hls --set latest
+```
+
 ## Vim integration
 
 See [ghcup.vim](https://github.com/hasufell/ghcup.vim).

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

scripts/bootstrap/bootstrap-haskell.ps1

@@ -40,10 +40,13 @@ param (
     # Whether to disable use of curl.exe
     [switch]$DisableCurl,
     # The Msys2 version to download (e.g. 20221216)
-    [string]$Msys2Version
+    [string]$Msys2Version,
+    # The Msys2 sha256sum hash
+    [string]$Msys2Hash
 )
 
 $DefaultMsys2Version = "20221216"
+$DefaultMsys2Hash = "18370d32b0264915c97e3d7c618f7b32d48ad80858923883fde5145acd32ca0f"
 
 $Silent = !$Interactive
 
@@ -430,9 +433,12 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
 	if (!($Msys2Version)) {
 		$Msys2Version = $DefaultMsys2Version
 	}
+	if (!($Msys2Hash)) {
+		$Msys2Hash = $DefaultMsys2Hash
+	}
     Print-Msg -msg ('Downloading Msys2 archive {0}...' -f $Msys2Version)
     $archive = ('msys2-base-x86_64-{0}.sfx.exe' -f $Msys2Version)
-    $msysUrl = ('https://repo.msys2.org/distrib/x86_64/{0}' -f "$archive")
+    $msysUrl = ('https://downloads.haskell.org/ghcup/msys2/{0}' -f "$archive")
     $archivePath = ('{0}\{1}' -f ([IO.Path]::GetTempPath()), "$archive")
 
     if ((Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) -and !($DisableCurl)) {
@@ -440,6 +446,11 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
     } else {
       Get-FileWCSynchronous -url "$msysUrl" -destinationFolder ([IO.Path]::GetTempPath()) -includeStats
     }
+	$Msys2HashChecked = Get-FileHash -Algorithm SHA256 "${archivePath}"
+	if (!($Msys2HashChecked.Hash -eq $Msys2Hash)) {
+		Print-Msg -color Red -msg ("Hashes don't match, got {0}, but expected {1}" -f $Msys2HashChecked, $Msys2Hash)
+		Exit 1
+	}
 
     Print-Msg -msg 'Extracting Msys2 archive...'
     $null = & "$archivePath" '-y' ('-o{0}' -f $GhcupDir)  # Extract
@@ -448,7 +459,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
     Print-Msg -msg 'Processing MSYS2 bash for first time use...'
     Exec "$Bash" '-lc' 'exit'
 
-    Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`"
+    Exec "$env:windir\system32\taskkill.exe" /F /FI "MODULES eq msys-2.0.dll"
 
     Print-Msg -msg 'Upgrading full system...'
     Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'