{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Network.HTTP.StackClient
( httpJSON
, httpLbs
, httpNoBody
, httpSink
, withResponse
, setRequestMethod
, setRequestHeader
, addRequestHeader
, setRequestBody
, getResponseHeaders
, getResponseBody
, getResponseStatusCode
, parseRequest
, getUri
, path
, checkResponse
, parseUrlThrow
, requestHeaders
, getGlobalManager
, applyDigestAuth
, displayDigestAuthException
, Request
, RequestBody(RequestBodyBS, RequestBodyLBS)
, Response
, HttpException
, hAccept
, hContentLength
, hContentMD5
, methodPut
, formDataBody
, partFileRequestBody
, partBS
, partLBS
, setGithubHeaders
, download
, redownload
, 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.Monoid (Sum (..))
import qualified Data.Text as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Network.HTTP.Client (Request, RequestBody(..), Response, parseRequest, getUri, path, checkResponse, parseUrlThrow)
import Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders)
import Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut)
import Network.HTTP.Conduit (requestHeaders)
import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException)
import Network.HTTP.Download hiding (download, redownload, verifiedDownload)
import qualified Network.HTTP.Download as Download
import qualified Network.HTTP.Simple
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS)
import Path
import Prelude (until, (!!))
import RIO
import RIO.PrettyPrint
import Text.Printf (printf)
setUserAgent :: Request -> Request
setUserAgent = setRequestHeader "User-Agent" ["The Haskell Stack"]
httpJSON :: (MonadIO m, FromJSON a) => Request -> m (Response a)
httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent
httpLbs :: MonadIO m => Request -> m (Response LByteString)
httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent
httpNoBody :: MonadIO m => Request -> m (Response ())
httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent
httpSink
:: MonadUnliftIO m
=> Request
-> (Response () -> ConduitM Strict.ByteString Void m a)
-> m a
httpSink = Network.HTTP.Simple.httpSink . setUserAgent
withResponse
:: (MonadUnliftIO m, MonadIO n)
=> Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a
withResponse = Network.HTTP.Simple.withResponse . setUserAgent
setGithubHeaders :: Request -> Request
setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]
download :: HasTerm env
=> Request
-> Path Abs File
-> RIO env Bool
download req dest = Download.download (setUserAgent req) dest
redownload :: HasTerm env
=> Request
-> Path Abs File
-> RIO env Bool
redownload req dest = Download.redownload (setUserAgent req) dest
verifiedDownload
:: HasTerm env
=> DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload dr destpath progressSink =
Download.verifiedDownload dr' destpath progressSink
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
chattyProgressNoTotal totalSoFar =
printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
(T.unpack label)
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
bytesfmt :: Integral a => String -> a -> String
bytesfmt formatter bs = printf (formatter <> " %s")
(fromIntegral (signum bs) * dec :: Double)
(bytesSuffixes !! i)
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"]
chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m ()
chunksOverTime diff = do
currentTime <- liftIO getCurrentTime
evalStateC (currentTime, mempty) go
where
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