content: {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  {-|
  Module      : Network.HTTP.StackClient
  License     : BSD-3-Clause
  
  Wrapper functions of 'Network.HTTP.Simple' and 'Network.HTTP.Client' to add the
  'User-Agent' HTTP request header to each request.
  -}
  
  module Network.HTTP.StackClient
    ( httpJSON
    , httpLbs
    , httpNoBody
    , httpSink
    , withResponse
    , setRequestCheckStatus
    , setRequestMethod
    , setRequestHeader
    , setRequestHeaders
    , addRequestHeader
    , setRequestBody
    , getResponseHeaders
    , getResponseBody
    , getResponseStatusCode
    , parseRequest
    , getUri
    , path
    , checkResponse
    , parseUrlThrow
    , requestHeaders
    , getGlobalManager
    , applyDigestAuth
    , displayDigestAuthException
    , Request
    , RequestBody (RequestBodyBS, RequestBodyLBS)
    , Response (..)
    , HttpException (..)
    , HttpExceptionContent (..)
    , notFound404
    , hAccept
    , hContentLength
    , hContentMD5
    , method
    , methodPost
    , methodPut
    , formDataBody
    , partFileRequestBody
    , partBS
    , partLBS
    , setGitHubHeaders
    , download
    , redownload
    , requestBody
    , verifiedDownload
    , verifiedDownloadWithProgress
    , CheckHexDigest (..)
    , DownloadRequest
    , drRetryPolicyDefault
    , VerifiedDownloadException (..)
    , HashCheck (..)
    , mkDownloadRequest
    , setHashChecks
    , setLengthCheck
    , setRetryPolicy
    , setForceDownload
    ) where
  
  import           Control.Monad.State ( get, put, modify )
  import           Data.Aeson ( FromJSON )
  import qualified Data.ByteString as Strict
  import           Data.Conduit
                     ( ConduitM, ConduitT, awaitForever, (.|), yield, await )
  import           Data.Conduit.Lift ( evalStateC )
  import qualified Data.Conduit.List as CL
  import           Data.List.Extra ( (!?) )
  import           Data.Monoid ( Sum (..) )
  import qualified Data.Text as T
  import           Data.Time.Clock
                     ( NominalDiffTime, diffUTCTime, getCurrentTime )
  import           Network.HTTP.Client
                     ( HttpException (..), HttpExceptionContent (..), Request
                     , RequestBody (..), Response (..), checkResponse, getUri
                     , method, parseRequest, parseUrlThrow, path, requestBody
                     )
  import           Network.HTTP.Client.MultipartFormData
                     ( formDataBody, partBS, partFileRequestBody, partLBS )
  import           Network.HTTP.Client.TLS
                     ( applyDigestAuth, displayDigestAuthException
                     , getGlobalManager
                     )
  import           Network.HTTP.Conduit ( requestHeaders )
  import           Network.HTTP.Download
                     ( CheckHexDigest (..), DownloadRequest, HashCheck (..)
                     , VerifiedDownloadException (..), drRetryPolicyDefault
                     , mkDownloadRequest, modifyRequest, setForceDownload
                     , setHashChecks, setLengthCheck, setRetryPolicy
                     )
  import qualified Network.HTTP.Download as Download
  import           Network.HTTP.Simple
                     ( addRequestHeader, getResponseBody, getResponseHeaders
                     , getResponseStatusCode, setRequestBody
                     , setRequestCheckStatus, setRequestHeader, setRequestHeaders
                     , setRequestMethod
                     )
  import qualified Network.HTTP.Simple
                     ( httpJSON, httpLbs, httpNoBody, httpSink, withResponse )
  import           Network.HTTP.Types
                     ( hAccept, hContentLength, hContentMD5, methodPost, methodPut
                     , notFound404
                     )
  import           Path ( Abs, File, Path )
  import           Prelude ( until )
  import           RIO
  import           RIO.PrettyPrint ( HasTerm )
  import           Text.Printf ( printf )
  
  -- | Set the User-Agent request header to @The Haskell Stack@.
  setUserAgent :: Request -> Request
  setUserAgent = setRequestHeader "User-Agent" ["The Haskell Stack"]
  
  -- | Like 'Network.HTTP.Simple.httpJSON' but sets the User-Agent request header.
  httpJSON :: (MonadIO m, FromJSON a) => Request -> m (Response a)
  httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent
  
  -- | Like 'Network.HTTP.Simple.httpLbs' but sets the User-Agent request header.
  httpLbs :: MonadIO m => Request -> m (Response LByteString)
  httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent
  
  -- | Like 'Network.HTTP.Simple.httpNoBody' but sets the User-Agent request
  -- header.
  httpNoBody :: MonadIO m => Request -> m (Response ())
  httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent
  
  -- | Like 'Network.HTTP.Simple.httpSink' but sets the User-Agent request header.
  httpSink ::
       MonadUnliftIO m
    => Request
    -> (Response () -> ConduitM Strict.ByteString Void m a)
    -> m a
  httpSink = Network.HTTP.Simple.httpSink . setUserAgent
  
  -- | Like 'Network.HTTP.Simple.withResponse' but sets the User-Agent request
  -- header.
  withResponse ::
       (MonadUnliftIO m, MonadIO n)
    => Request
    -> (Response (ConduitM i Strict.ByteString n ()) -> m a)
    -> m a
  withResponse = Network.HTTP.Simple.withResponse . setUserAgent
  
  -- | Set the Accept request header to specify GitHub API v3.
  setGitHubHeaders :: Request -> Request
  setGitHubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]
  
  -- | Download the given URL to the given location. If the file already exists,
  -- no download is performed. Otherwise, creates the parent directory, downloads
  -- to a temporary file, and on file download completion moves to the
  -- appropriate destination.
  --
  -- Throws an exception if things go wrong
  download ::
       HasTerm env
    => Request
    -> Path Abs File
       -- ^ destination
    -> RIO env Bool
       -- ^ Was a downloaded performed (True) or did the file already exist
       -- (False)?
  download req = Download.download (setUserAgent req)
  
  -- | Same as 'download', but will download a file a second time if it is already present.
  --
  -- Returns 'True' if the file was downloaded, 'False' otherwise
  redownload ::
       HasTerm env
    => Request
    -> Path Abs File -- ^ destination
    -> RIO env Bool
  redownload req = Download.redownload (setUserAgent req)
  
  -- | Copied and extended version of Network.HTTP.Download.download.
  --
  -- Has the following additional features:
  -- * Verifies that response content-length header (if present)
  --     matches expected length
  -- * Limits the download to (close to) the expected # of bytes
  -- * Verifies that the expected # bytes were downloaded (not too few)
  -- * Verifies md5 if response includes content-md5 header
  -- * Verifies the expected hashes
  --
  -- Throws VerifiedDownloadException.
  -- Throws IOExceptions related to file system operations.
  -- Throws HttpException.
  verifiedDownload ::
       HasTerm env
    => DownloadRequest
    -> Path Abs File -- ^ destination
    -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
       -- ^ custom hook to observe progress
    -> RIO env Bool -- ^ Whether a download was performed
  verifiedDownload dr = Download.verifiedDownload dr'
   where
    dr' = modifyRequest setUserAgent dr
  
  verifiedDownloadWithProgress ::
       HasTerm env
    => DownloadRequest
    -> Path Abs File
    -> Text
    -> Maybe Int
    -> RIO env Bool
  verifiedDownloadWithProgress req destpath lbl msize =
    verifiedDownload req destpath (chattyDownloadProgress lbl msize)
  
  chattyDownloadProgress ::
       ( HasLogFunc env
       , MonadIO m
       , MonadReader env m
       )
    => Text
    -> Maybe Int
    -> f
    -> ConduitT ByteString c m ()
  chattyDownloadProgress label mtotalSize _ = do
    _ <- logSticky $ RIO.display label <> ": download has begun"
    CL.map (Sum . Strict.length)
      .| chunksOverTime 1
      .| go
   where
    go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
      modify (+ size)
      totalSoFar <- get
      logSticky $ fromString $
        case mtotalSize of
          Nothing -> chattyProgressNoTotal totalSoFar
          Just 0 -> chattyProgressNoTotal totalSoFar
          Just totalSize -> chattyProgressWithTotal totalSoFar totalSize
  
    -- Example: ghc: 42.13 KiB downloaded...
    chattyProgressNoTotal totalSoFar =
      printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
             (T.unpack label)
  
      -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
    chattyProgressWithTotal totalSoFar total =
      printf (  "%s: "
             <> bytesfmt "%7.2f" totalSoFar
             <> " / "
             <> bytesfmt "%.2f" total
             <> " (%6.2f%%) downloaded..."
             )
             (T.unpack label)
             percentage
     where
      percentage :: Double
      percentage = fromIntegral totalSoFar / fromIntegral total * 100
  
  -- | Given a printf format string for the decimal part and a number of
  -- bytes, formats the bytes using an appropriate unit and returns the
  -- formatted string.
  --
  -- >>> bytesfmt "%.2" 512368
  -- "500.359375 KiB"
  bytesfmt :: Integral a => String -> a -> String
  bytesfmt formatter bs = printf (formatter <> " %s")
                                 (fromIntegral (signum bs) * dec :: Double)
                                 bytesSuffix
   where
    (dec, i) = getSuffix (abs bs)
    getSuffix n = until p (\(x, y) -> (x / 1024, y + 1)) (fromIntegral n, 0)
     where
      p (n', numDivs) = n' < 1024 || numDivs == length bytesSuffixes - 1
    bytesSuffixes :: [String]
    bytesSuffixes = ["B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"]
    bytesSuffix = fromMaybe
      (error "bytesfmt: the impossible happened! Index out of range.")
      (bytesSuffixes !? i)
  
  -- Await eagerly (collect with monoidal append),
  -- but space out yields by at least the given amount of time.
  -- The final yield may come sooner, and may be a superfluous mempty.
  -- Note that Integer and Float literals can be turned into NominalDiffTime
  -- (these literals are interpreted as "seconds")
  chunksOverTime ::
       (Monoid a, Semigroup a, MonadIO m)
    => NominalDiffTime
    -> ConduitM a a m ()
  chunksOverTime diff = do
    currentTime <- liftIO getCurrentTime
    evalStateC (currentTime, mempty) go
   where
    -- State is a tuple of:
    -- * the last time a yield happened (or the beginning of the sink)
    -- * the accumulated awaits since the last yield
    go = await >>= \case
      Nothing -> do
        (_, acc) <- get
        yield acc
      Just a -> do
        (lastTime, acc) <- get
        let acc' = acc <> a
        currentTime <- liftIO getCurrentTime
        if diff < diffUTCTime currentTime lastTime
          then put (currentTime, mempty) >> yield acc'
          else put (lastTime,    acc')
        go
  