Use http-client-openssl for internal downloader
This commit is contained in:
parent
4c4266dd8c
commit
f46c8bdd6f
27
ghcup.cabal
27
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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
213
lib/GHCup/Download/Internal.hs
Normal file
213
lib/GHCup/Download/Internal.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user