Implement async fetching

This commit is contained in:
Julian Ospald 2023-08-02 21:28:32 +08:00
parent a2a605ad89
commit a109fa00ac
No known key found for this signature in database
GPG Key ID: CCC85C0E40C06A8C
5 changed files with 52 additions and 6 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

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