diff --git a/ghcup.cabal b/ghcup.cabal index 71d56bcc26f9c68f804ac22c38653caaef59e376..d772c872a55faeb5675ea7152772e83788ba2758 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -105,11 +105,14 @@ common hpath-io common hpath-posix build-depends: hpath-posix >=0.13.2 -common http-io-streams - build-depends: http-io-streams >=0.1.2.0 +common http-client + build-depends: http-client >=0.7.1 -common io-streams - build-depends: io-streams >=1.5 +common http-client-openssl + build-depends: http-client-openssl >=0.3.1.0 + +common http-types + build-depends: http-types >=0.12.3 common libarchive build-depends: libarchive >= 2.2.5.0 @@ -120,6 +123,9 @@ common lzma common megaparsec build-depends: megaparsec >=8.0.0 +common monad-control + build-depends: monad-control >=1.0.2.3 + common monad-logger build-depends: monad-logger >=0.3.31 @@ -189,6 +195,9 @@ common time common transformers build-depends: transformers >=0.5 +common transformers-base + build-depends: transformers-base >=0.4.4 + common os-release build-depends: os-release >=1.0.0 @@ -263,6 +272,7 @@ library , hpath-posix , lzma , megaparsec + , monad-control , monad-logger , mtl , optics @@ -282,6 +292,7 @@ library , text , time , transformers + , transformers-base , os-release , unix , unix-bytestring @@ -299,7 +310,6 @@ library GHCup.Data.GHCupInfo GHCup.Data.ToolRequirements GHCup.Download - GHCup.Download.Utils GHCup.Errors GHCup.Platform GHCup.Requirements @@ -323,10 +333,11 @@ library if flag(internal-downloader) import: HsOpenSSL - , http-io-streams - , io-streams + , http-client + , http-client-openssl + , http-types , terminal-progress-bar - exposed-modules: GHCup.Download.IOStreams + exposed-modules: GHCup.Download.Internal cpp-options: -DINTERNAL_DOWNLOADER if flag(tar) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 0d655a8261fbfca4bbe10c9a5f6caae66448a339..5ab5d568141a05705411082f9c17ed03bc12473f 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -12,8 +12,7 @@ module GHCup.Download where #if defined(INTERNAL_DOWNLOADER) -import GHCup.Download.IOStreams -import GHCup.Download.Utils +import GHCup.Download.Internal #endif import GHCup.Errors import GHCup.Types @@ -233,16 +232,20 @@ getDownloads urlSource = do #if !defined(INTERNAL_DOWNLOADER) pure Nothing #else - headers <- - handleIO (\_ -> pure mempty) - $ liftE - $ ( catchAllE - (\_ -> - pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString) + Settings{..} <- lift ask + case downloader of + Internal -> do + headers <- + handleIO (\_ -> pure mempty) + $ liftE + $ ( catchAllE + (\_ -> + pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString) + ) + $ getHead uri' ) - $ getHead uri' - ) - pure $ parseModifiedHeader headers + pure $ parseModifiedHeader headers + _ -> pure Nothing parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime parseModifiedHeader headers = @@ -339,9 +342,7 @@ download dli dest mfn liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True (o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing #if defined(INTERNAL_DOWNLOADER) - Internal -> do - (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli) - liftE $ downloadToFile https host fullPath port destFile + Internal -> liftE $ downloadToFile (_dlUri dli) destFile #endif liftE $ checkDigest dli destFile @@ -408,10 +409,8 @@ downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m) m L.ByteString downloadBS uri' - | scheme == "https" - = dl True - | scheme == "http" - = dl False + | scheme == "https" || scheme == "http" + = dl | scheme == "file" = liftIOException doesNotExistErrorType (FileDoesNotExistError path) $ (liftIO $ RD.readFile path) @@ -421,11 +420,7 @@ downloadBS uri' where scheme = view (uriSchemeL' % schemeBSL') uri' path = view pathL' uri' -#if defined(INTERNAL_DOWNLOADER) - dl https = do -#else - dl _ = do -#endif + dl = do lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|] lift getDownloader >>= \case Curl -> do @@ -445,9 +440,7 @@ downloadBS uri' pure $ L.fromStrict stdout CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args #if defined(INTERNAL_DOWNLOADER) - Internal -> do - (_, host', fullPath', port') <- liftE $ uriToQuadruple uri' - liftE $ downloadBS' https host' fullPath' port' + Internal -> liftE $ downloadBS' uri' #endif diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs deleted file mode 100644 index 272bb0e2c03464b5fe90f6f84f260cf98981c748..0000000000000000000000000000000000000000 --- a/lib/GHCup/Download/IOStreams.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - - -module GHCup.Download.IOStreams where - - -import GHCup.Download.Utils -import GHCup.Errors -import GHCup.Types.Optics -import GHCup.Types.JSON ( ) -import GHCup.Utils.File -import GHCup.Utils.Prelude - -import Control.Applicative -import Control.Exception.Safe -import Control.Monad -import Control.Monad.Reader -import Data.ByteString ( ByteString ) -import Data.ByteString.Builder -import Data.CaseInsensitive ( CI ) -import Data.IORef -import Data.Maybe -import Data.Text.Read -import HPath -import HPath.IO as HIO -import Haskus.Utils.Variant.Excepts -import Network.Http.Client hiding ( URL ) -import Optics -import Prelude hiding ( abs - , readFile - , writeFile - ) -import "unix" System.Posix.IO.ByteString - hiding ( fdWrite ) -import "unix-bytestring" System.Posix.IO.ByteString - ( fdWrite ) -import System.ProgressBar -import URI.ByteString - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as L -import qualified Data.Map.Strict as M -import qualified System.IO.Streams as Streams - - - - - - ---------------------------- - --[ Low-level (non-curl) ]-- - ---------------------------- - - --- | Load the result of this download into memory at once. -downloadBS' :: MonadIO m - => Bool -- ^ https? - -> ByteString -- ^ host (e.g. "www.example.com") - -> ByteString -- ^ path (e.g. "/my/file") including query - -> Maybe Int -- ^ optional port (e.g. 3000) - -> Excepts - '[ HTTPStatusError - , URIParseError - , UnsupportedScheme - , NoLocationHeader - , TooManyRedirs - ] - m - (L.ByteString) -downloadBS' https host path port = do - bref <- liftIO $ newIORef (mempty :: Builder) - let stepper bs = modifyIORef bref (<> byteString bs) - downloadInternal False https host path port stepper - liftIO (readIORef bref <&> toLazyByteString) - - -downloadToFile :: (MonadMask m, MonadIO m) - => Bool -- ^ https? - -> ByteString -- ^ host (e.g. "www.example.com") - -> ByteString -- ^ path (e.g. "/my/file") including query - -> Maybe Int -- ^ optional port (e.g. 3000) - -> Path Abs -- ^ destination file to create and write to - -> Excepts '[DownloadFailed] m () -downloadToFile https host fullPath port destFile = do - fd <- liftIO $ createRegularFileFd newFilePerms destFile - let stepper = fdWrite fd - flip finally (liftIO $ closeFd fd) - $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper - - -downloadInternal :: MonadIO m - => Bool -- ^ whether to show a progress bar - -> Bool -- ^ https? - -> ByteString -- ^ host - -> ByteString -- ^ path with query - -> Maybe Int -- ^ optional port - -> (ByteString -> IO a) -- ^ the consuming step function - -> Excepts - '[ HTTPStatusError - , URIParseError - , UnsupportedScheme - , NoLocationHeader - , TooManyRedirs - ] - m - () -downloadInternal = go (5 :: Int) - - where - go redirs progressBar https host path port consumer = do - r <- liftIO $ withConnection' https host port action - veitherToExcepts r >>= \case - Just r' -> - if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs - Nothing -> pure () - where - action c = do - let q = buildRequest1 $ http GET path - - sendRequest c q emptyBody - - receiveResponse - c - (\r i' -> runE $ do - let scode = getStatusCode r - if - | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing - | scode >= 300 && scode < 400 -> case getHeader r "Location" of - Just r' -> pure $ Just $ r' - Nothing -> throwE NoLocationHeader - | otherwise -> throwE $ HTTPStatusError scode - ) - - followRedirectURL bs = case parseURI strictURIParserOptions bs of - Right uri' -> do - (https', host', fullPath', port') <- liftE $ uriToQuadruple uri' - go (redirs - 1) progressBar https' host' fullPath' port' consumer - Left e -> throwE e - - downloadStream r i' = do - let size = case getHeader r "Content-Length" of - Just x' -> case decimal $ decUTF8Safe x' of - Left _ -> 0 - Right (r', _) -> r' - Nothing -> 0 - - mpb <- if progressBar - then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ())) - else pure Nothing - - outStream <- liftIO $ Streams.makeOutputStream - (\case - Just bs -> do - forM_ mpb $ \pb -> incProgress pb (BS.length bs) - void $ consumer bs - Nothing -> pure () - ) - liftIO $ Streams.connect i' outStream - - -getHead :: (MonadCatch m, MonadIO m) - => URI - -> Excepts - '[ HTTPStatusError - , URIParseError - , UnsupportedScheme - , NoLocationHeader - , TooManyRedirs - , ProcessError - ] - m - (M.Map (CI ByteString) ByteString) -getHead uri' | scheme == "https" = head' True - | scheme == "http" = head' False - | otherwise = throwE UnsupportedScheme - - where - scheme = view (uriSchemeL' % schemeBSL') uri' - head' https = do - (_, host', fullPath', port') <- liftE $ uriToQuadruple uri' - liftE $ headInternal https host' fullPath' port' - - -headInternal :: MonadIO m - => Bool -- ^ https? - -> ByteString -- ^ host - -> ByteString -- ^ path with query - -> Maybe Int -- ^ optional port - -> Excepts - '[ HTTPStatusError - , URIParseError - , UnsupportedScheme - , TooManyRedirs - , NoLocationHeader - ] - m - (M.Map (CI ByteString) ByteString) -headInternal = go (5 :: Int) - - where - go redirs https host path port = do - r <- liftIO $ withConnection' https host port action - veitherToExcepts r >>= \case - Left r' -> - if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs - Right hs -> pure hs - where - - action c = do - let q = buildRequest1 $ http HEAD path - - sendRequest c q emptyBody - - unsafeReceiveResponse - c - (\r _ -> runE $ do - let scode = getStatusCode r - if - | scode >= 200 && scode < 300 -> do - let headers = getHeaderMap r - pure $ Right $ headers - | scode >= 300 && scode < 400 -> case getHeader r "Location" of - Just r' -> pure $ Left $ r' - Nothing -> throwE NoLocationHeader - | otherwise -> throwE $ HTTPStatusError scode - ) - - followRedirectURL bs = case parseURI strictURIParserOptions bs of - Right uri' -> do - (https', host', fullPath', port') <- liftE $ uriToQuadruple uri' - go (redirs - 1) https' host' fullPath' port' - Left e -> throwE e - - -withConnection' :: Bool - -> ByteString - -> Maybe Int - -> (Connection -> IO a) - -> IO a -withConnection' https host port action = bracket acquire closeConnection action - - where - acquire = case https of - True -> do - ctx <- baselineContextSSL - openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port) - False -> openConnection host (fromIntegral $ fromMaybe 80 port) diff --git a/lib/GHCup/Download/Internal.hs b/lib/GHCup/Download/Internal.hs new file mode 100644 index 0000000000000000000000000000000000000000..e9eb7d34d8a6fc7a2827416bddfa083dcac5d7cd --- /dev/null +++ b/lib/GHCup/Download/Internal.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + + +module GHCup.Download.Internal where + + +import GHCup.Errors +import GHCup.Types.Optics +import GHCup.Types.JSON ( ) +import GHCup.Utils.File +import GHCup.Utils.Prelude + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Reader +import Data.ByteString ( ByteString ) +import Data.ByteString.Builder +import Data.CaseInsensitive ( CI ) +import Data.IORef +import Data.Maybe +import Data.Text.Read +import HPath +import HPath.IO as HIO +import Haskus.Utils.Variant.Excepts +import Network.HTTP.Client +import Network.HTTP.Client.OpenSSL +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header +import Optics +import Prelude hiding ( abs + , readFile + , writeFile + ) +import "unix" System.Posix.IO.ByteString + hiding ( fdWrite ) +import "unix-bytestring" System.Posix.IO.ByteString + ( fdWrite ) +import System.ProgressBar +import URI.ByteString + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as L +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified OpenSSL.Session as SSL + + + + + + ---------------------------- + --[ Low-level (non-curl) ]-- + ---------------------------- + + +-- | Load the result of this download into memory at once. +downloadBS' :: (MonadThrow m, MonadIO m) + => URI + -> Excepts + '[HTTPStatusError] + m + (L.ByteString) +downloadBS' uri' = do + bref <- liftIO $ newIORef (mempty :: Builder) + let stepper bs = modifyIORef bref (<> byteString bs) + downloadInternal False + (T.unpack . decUTF8Safe . serializeURIRef' $ uri') + stepper + liftIO (readIORef bref <&> toLazyByteString) + + +downloadToFile :: (MonadMask m, MonadIO m) + => URI + -> Path Abs -- ^ destination file to create and write to + -> Excepts '[DownloadFailed] m () +downloadToFile uri' destFile = do + fd <- liftIO $ createRegularFileFd newFilePerms destFile + let stepper = fdWrite fd + flip finally (liftIO $ closeFd fd) + $ reThrowAll DownloadFailed + $ downloadInternal True + (T.unpack . decUTF8Safe . serializeURIRef' $ uri') + stepper + + +downloadInternal :: (MonadThrow m, MonadIO m) + => Bool -- ^ whether to show a progress bar + -> String + -> (ByteString -> IO a) -- ^ the consuming step function + -> Excepts + '[HTTPStatusError] + m + () +downloadInternal progressBar uri' consumer = lEM $ liftIO $ withConnection' action + where + action :: (MonadThrow m, MonadIO m) => Manager -> m (Either HTTPStatusError ()) + action m = do + request <- parseRequest ("GET " <> uri') + liftIO $ withResponse + request + m + (\r -> do + let scode = statusCode . responseStatus $ r + if + | scode >= 200 && scode < 300 -> + let headers = M.fromList . responseHeaders $ r + in fmap Right $ liftIO $ downloadStream (responseBody r) headers + | otherwise -> pure $ Left $ HTTPStatusError scode + ) + + downloadStream :: BodyReader -> M.Map HeaderName ByteString -> IO () + downloadStream br headers = do + let size = case M.lookup "Content-Length" headers of + Just x' -> case decimal $ decUTF8Safe x' of + Left _ -> 0 + Right (r', _) -> r' + Nothing -> 0 + + mpb <- if progressBar + then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ())) + else pure Nothing + + loop mpb + + where + loop mpb = do + bs <- brRead br + if BS.length bs == 0 then pure () else do + void $ consumer bs + forM_ mpb $ \pb -> incProgress pb (BS.length bs) + loop mpb + + +getHead :: (MonadCatch m, MonadIO m) + => URI + -> Excepts + '[HTTPStatusError, UnsupportedScheme] + m + (M.Map (CI ByteString) ByteString) +getHead uri' | scheme == "https" || scheme == "http" = head' + | otherwise = throwE UnsupportedScheme + + where + scheme = view (uriSchemeL' % schemeBSL') uri' + head' = + liftE $ headInternal (T.unpack . decUTF8Safe . serializeURIRef' $ uri') + + +headInternal :: (MonadThrow m, MonadIO m) + => String + -> Excepts + '[HTTPStatusError] + m + (M.Map (CI ByteString) ByteString) +headInternal uri' = lEM $ liftIO $ withConnection' action + where + action :: (MonadThrow m, MonadIO m) + => Manager + -> m (Either HTTPStatusError (M.Map (CI ByteString) ByteString)) + action m = do + request <- parseRequest ("HEAD " <> uri') + liftIO $ withResponse + request + m + (\r -> do + let scode = statusCode . responseStatus $ r + if + | scode >= 200 && scode < 300 -> do + let headers = responseHeaders r + pure $ Right $ M.fromList $ headers + | otherwise -> pure $ Left (HTTPStatusError scode) + ) + + +withConnection' :: (Manager -> IO a) -> IO a +withConnection' action = do + mg <- newManager $ opensslManagerSettings baselineContextSSL + withOpenSSL (action mg) + + +baselineContextSSL :: IO SSL.SSLContext +baselineContextSSL = withOpenSSL $ do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx +#if defined(darwin_HOST_OS) + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#elif defined(mingw32_HOST_OS) + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#elif defined(freebsd_HOST_OS) + SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem" + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing +#elif defined(openbsd_HOST_OS) + SSL.contextSetCAFile ctx "/etc/ssl/cert.pem" + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing +#else + fedora <- doesDirectoryExist [abs|/etc/pki/tls|] + if fedora + then do + SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt" + else do + SSL.contextSetCADirectory ctx "/etc/ssl/certs" + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing +#endif + return ctx diff --git a/lib/GHCup/Download/Utils.hs b/lib/GHCup/Download/Utils.hs deleted file mode 100644 index f9024700336cbb529546ffbef8cadf061bf668ed..0000000000000000000000000000000000000000 --- a/lib/GHCup/Download/Utils.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - - -module GHCup.Download.Utils where - - -import GHCup.Errors -import GHCup.Types.Optics -import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude - -import Control.Applicative -import Control.Monad -import Data.ByteString ( ByteString ) -import Data.Maybe -import Haskus.Utils.Variant.Excepts -import Optics -import Prelude hiding ( abs - , readFile - , writeFile - ) -import URI.ByteString - -import qualified Data.Binary.Builder as B -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as L - - --- | Extracts from a URI type: (https?, host, path+query, port) -uriToQuadruple :: Monad m - => URI - -> Excepts - '[UnsupportedScheme] - m - (Bool, ByteString, ByteString, Maybe Int) -uriToQuadruple URI {..} = do - let scheme = view schemeBSL' uriScheme - - host <- - preview (_Just % authorityHostL' % hostBSL') uriAuthority - ?? UnsupportedScheme - - https <- if - | scheme == "https" -> pure True - | scheme == "http" -> pure False - | otherwise -> throwE UnsupportedScheme - - let queryBS = - BS.intercalate "&" - . fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y) - $ (queryPairs uriQuery) - port = - preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority - fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS - pure (https, host, fullpath, port) - where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery - diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 3eea58a260b7942b07e6a1a5374429d8653b281e..615820629cad41ff153aa1a509e1d62b2cc99692 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -1,8 +1,12 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -13,8 +17,10 @@ module GHCup.Utils.Prelude where import Control.Applicative import Control.Exception.Safe import Control.Monad +import Control.Monad.Base import Control.Monad.IO.Class import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.Control import Data.Bifunctor import Data.ByteString ( ByteString ) import Data.String @@ -264,3 +270,40 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode decUTF8Safe' :: L.ByteString -> Text decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode + + +instance MonadBaseControl b m => MonadBaseControl b (Excepts e m) where + type StM (Excepts e m) a = ComposeSt (Excepts e) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + +instance MonadTransControl (Excepts e) where + type StT (Excepts e) a = VEither e a + liftWith f = veitherMToExcepts <$> liftM return $ f $ runE + restoreT = veitherMToExcepts + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadBase b m => MonadBase b (Excepts e m) where + liftBase = liftBaseDefault + {-# INLINABLE liftBase #-} + +instance MonadBaseControl (VEither e) (VEither e) where + type StM (VEither e) a = a + liftBaseWith f = f id + restoreM = return + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + +instance MonadBase (VEither e) (VEither e) where + liftBase = id + {-# INLINABLE liftBase #-} + + +veitherMToExcepts :: Monad m => m (VEither es a) -> Excepts es m a +veitherMToExcepts ma = do + ve <- lift ma + veitherToExcepts ve +