Implement async fetching
This commit is contained in:
parent
a2a605ad89
commit
a109fa00ac
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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))
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user