{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Headroom.IO.Network
(
DownloadContentFn
, Network(..)
, mkNetwork
, downloadContent
,
NetworkError(..)
)
where
import Data.String.Interpolate ( i )
import Headroom.Meta ( buildVersion
, productName
, productVendor
)
import Headroom.Meta.Version ( printVersion )
import Headroom.Types ( fromHeadroomError
, toHeadroomError
)
import qualified Network.HTTP.Client as HC
import Network.HTTP.Req ( BsResponse
, GET(GET)
, HttpException(..)
, MonadHttp
, NoReqBody(NoReqBody)
, bsResponse
, defaultHttpConfig
, header
, req
, responseBody
, runReq
, useURI
)
import qualified Network.HTTP.Req as Req
import qualified Network.HTTP.Types.Status as HC
import RIO
import qualified RIO.Text as T
import qualified Text.URI as URI
import Text.URI ( URI )
type DownloadContentFn m
= URI
-> m ByteString
data Network m = Network
{ Network m -> DownloadContentFn m
nDownloadContent :: DownloadContentFn m
}
mkNetwork :: MonadIO m => Network m
mkNetwork :: Network m
mkNetwork = Network :: forall (m :: * -> *). DownloadContentFn m -> Network m
Network { nDownloadContent :: DownloadContentFn m
nDownloadContent = DownloadContentFn m
forall (m :: * -> *). MonadIO m => URI -> m ByteString
downloadContent }
downloadContent :: MonadIO m
=> URI
-> m ByteString
downloadContent :: URI -> m ByteString
downloadContent URI
uri = HttpConfig -> Req ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req ByteString -> m ByteString) -> Req ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
BsResponse
response <- URI -> Req BsResponse
forall (m :: * -> *).
(MonadHttp m, MonadThrow m, MonadUnliftIO m) =>
URI -> m BsResponse
httpGet URI
uri
ByteString -> Req ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Req ByteString) -> ByteString -> Req ByteString
forall a b. (a -> b) -> a -> b
$ BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody BsResponse
response
headers :: Req.Option scheme
= ByteString -> ByteString -> Option scheme
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"User-Agent" (ByteString -> Option scheme) -> ByteString -> Option scheme
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
ua
where
ua :: Text
ua = Text
forall a. IsString a => a
productVendor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
productName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
printVersion Version
buildVersion
httpGet :: (MonadHttp m, MonadThrow m, MonadUnliftIO m) => URI -> m BsResponse
httpGet :: URI -> m BsResponse
httpGet URI
uri = do
Either (Url 'Http, Option Any) (Url 'Https, Option Any)
urlE <- m (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
-> (Either (Url 'Http, Option Any) (Url 'Https, Option Any)
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any)))
-> Maybe (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NetworkError
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NetworkError
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any)))
-> NetworkError
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
forall a b. (a -> b) -> a -> b
$ URI -> NetworkError
InvalidURL URI
uri) Either (Url 'Http, Option Any) (Url 'Https, Option Any)
-> m (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
-> Maybe (Either (Url 'Http, Option Any) (Url 'Https, Option Any))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
useURI URI
uri)
Either HttpException BsResponse
eitherRes <- case Either (Url 'Http, Option Any) (Url 'Https, Option Any)
urlE of
Left (Url 'Http, Option Any)
url -> Url 'Http -> m (Either HttpException BsResponse)
forall (_ :: * -> *) (scheme :: Scheme).
(MonadUnliftIO _, MonadHttp _) =>
Url scheme -> _ (Either HttpException BsResponse)
doGet (Url 'Http -> m (Either HttpException BsResponse))
-> Url 'Http -> m (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ (Url 'Http, Option Any) -> Url 'Http
forall a b. (a, b) -> a
fst (Url 'Http, Option Any)
url
Right (Url 'Https, Option Any)
url -> Url 'Https -> m (Either HttpException BsResponse)
forall (_ :: * -> *) (scheme :: Scheme).
(MonadUnliftIO _, MonadHttp _) =>
Url scheme -> _ (Either HttpException BsResponse)
doGet (Url 'Https -> m (Either HttpException BsResponse))
-> Url 'Https -> m (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ (Url 'Https, Option Any) -> Url 'Https
forall a b. (a, b) -> a
fst (Url 'Https, Option Any)
url
case Either HttpException BsResponse
eitherRes of
Left HttpException
err -> URI -> HttpException -> m BsResponse
forall (m :: * -> *).
MonadThrow m =>
URI -> HttpException -> m BsResponse
handleHttpException URI
uri HttpException
err
Right BsResponse
res -> BsResponse -> m BsResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure BsResponse
res
where
doGet :: Url scheme -> _ (Either HttpException BsResponse)
doGet Url scheme
u = forall a.
(MonadUnliftIO _, Exception HttpException) =>
_ a -> _ (Either HttpException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @HttpException (_ BsResponse -> _ (Either HttpException BsResponse))
-> _ BsResponse -> _ (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ GET
-> Url scheme
-> NoReqBody
-> Proxy BsResponse
-> Option scheme
-> _ BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url scheme
u NoReqBody
NoReqBody Proxy BsResponse
bsResponse Option scheme
forall (scheme :: Scheme). Option scheme
headers
handleHttpException :: MonadThrow m => URI -> HttpException -> m BsResponse
handleHttpException :: URI -> HttpException -> m BsResponse
handleHttpException URI
uri HttpException
ex = case HttpException
ex of
VanillaHttpException (HC.HttpExceptionRequest Request
_ HttpExceptionContent
c) -> case HttpExceptionContent
c of
HC.ConnectionFailure SomeException
ex' ->
NetworkError -> m BsResponse
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NetworkError -> m BsResponse) -> NetworkError -> m BsResponse
forall a b. (a -> b) -> a -> b
$ URI -> Text -> NetworkError
ConnectionFailure URI
uri (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex')
HC.StatusCodeException Response ()
response ByteString
_ ->
let code :: Int
code = Status -> Int
HC.statusCode (Status -> Int) -> (Response () -> Status) -> Response () -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response () -> Status
forall body. Response body -> Status
HC.responseStatus (Response () -> Int) -> Response () -> Int
forall a b. (a -> b) -> a -> b
$ Response ()
response
message :: ByteString
message = Status -> ByteString
HC.statusMessage (Status -> ByteString)
-> (Response () -> Status) -> Response () -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response () -> Status
forall body. Response body -> Status
HC.responseStatus (Response () -> ByteString) -> Response () -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ()
response
in NetworkError -> m BsResponse
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NetworkError -> m BsResponse) -> NetworkError -> m BsResponse
forall a b. (a -> b) -> a -> b
$ URI -> Int -> Text -> NetworkError
InvalidStatus URI
uri Int
code (ByteString -> Text
decodeUtf8Lenient ByteString
message)
HttpExceptionContent
_ -> HttpException -> m BsResponse
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HttpException
ex
HttpException
_ -> HttpException -> m BsResponse
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HttpException
ex
data NetworkError
= ConnectionFailure URI Text
| InvalidStatus URI Int Text
| InvalidURL URI
deriving (NetworkError -> NetworkError -> Bool
(NetworkError -> NetworkError -> Bool)
-> (NetworkError -> NetworkError -> Bool) -> Eq NetworkError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NetworkError -> NetworkError -> Bool
$c/= :: NetworkError -> NetworkError -> Bool
== :: NetworkError -> NetworkError -> Bool
$c== :: NetworkError -> NetworkError -> Bool
Eq, Int -> NetworkError -> ShowS
[NetworkError] -> ShowS
NetworkError -> String
(Int -> NetworkError -> ShowS)
-> (NetworkError -> String)
-> ([NetworkError] -> ShowS)
-> Show NetworkError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NetworkError] -> ShowS
$cshowList :: [NetworkError] -> ShowS
show :: NetworkError -> String
$cshow :: NetworkError -> String
showsPrec :: Int -> NetworkError -> ShowS
$cshowsPrec :: Int -> NetworkError -> ShowS
Show)
instance Exception NetworkError where
displayException :: NetworkError -> String
displayException = NetworkError -> String
displayException'
toException :: NetworkError -> SomeException
toException = NetworkError -> SomeException
forall e. Exception e => e -> SomeException
toHeadroomError
fromException :: SomeException -> Maybe NetworkError
fromException = SomeException -> Maybe NetworkError
forall e. Exception e => SomeException -> Maybe e
fromHeadroomError
displayException' :: NetworkError -> String
displayException' :: NetworkError -> String
displayException' = \case
ConnectionFailure URI
uri Text
ex -> [i|Error connecting to #{URI.render uri}: #{ex}|]
InvalidStatus URI
uri Int
status Text
message ->
[i|Error downloading #{URI.render uri}: #{status} #{message}|]
InvalidURL URI
uri -> [i|Cannot build URL from input URI: #{URI.render uri}|]