ghcup-hs/lib/GHCup/Download/Internal.hs

{-# 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)
  -- TODO: performance
  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