Use http-client-openssl for internal downloader
This commit is contained in:
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
|
||||
Reference in New Issue
Block a user