{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}

{-|
Module      : Headroom.IO.Network
Description : Network related IO operations
Copyright   : (c) 2019-2021 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Module providing support to perform selected network IO operations, such as
downloading file content, etc.
-}

module Headroom.IO.Network
  ( -- * Type Aliases
    DownloadContentFn
    -- * Polymorphic Record
  , Network(..)
  , mkNetwork
    -- * Network IO operations
  , downloadContent
  )
where

import           Data.String.Interpolate             ( i )
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
                                                     , req
                                                     , responseBody
                                                     , runReq
                                                     , useURI
                                                     )
import qualified Network.HTTP.Types.Status          as HC
import           RIO
import qualified RIO.Text                           as T
import           Text.URI                            ( URI )
import qualified Text.URI                           as URI


--------------------------------  TYPE ALIASES  --------------------------------

-- | Type of a function that returns content of remote resource.
type DownloadContentFn m
  =  URI    -- ^ /URI/ of remote resource
  -> m Text -- ^ downloaded content


-----------------------------  POLYMORPHIC RECORD  -----------------------------

-- | Polymorphic record of functions performing network IO operations.
data Network m = Network
  { Network m -> DownloadContentFn m
nDownloadContent :: DownloadContentFn m -- ^ downloads remote content
  }


-- | Constructs new 'Network' that performs real network /IO/ operations.
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 Text
downloadContent }


------------------------------  PUBLIC FUNCTIONS  ------------------------------

-- | Downloads content of remote resource as 'Text'. Note that only @http@ and
-- @https@ is supported at this moment.
downloadContent :: MonadIO m
                => URI    -- ^ /URI/ of remote resource
                -> m Text -- ^ downloaded content
downloadContent :: URI -> m Text
downloadContent URI
uri = HttpConfig -> Req Text -> m Text
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req Text -> m Text) -> Req Text -> m Text
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
  case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody BsResponse
response of
    Left  UnicodeException
err  -> NetworkError -> Req Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (NetworkError -> Req Text) -> NetworkError -> Req Text
forall a b. (a -> b) -> a -> b
$ URI -> Text -> NetworkError
InvalidResponse URI
uri (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
err)
    Right Text
body -> Text -> Req Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
body


------------------------------  PRIVATE FUNCTIONS  -----------------------------

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).
Url scheme -> m (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).
Url scheme -> m (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 -> m (Either HttpException BsResponse)
doGet = \Url scheme
u -> forall a.
(MonadUnliftIO m, Exception HttpException) =>
m a -> m (Either HttpException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @HttpException (m BsResponse -> m (Either HttpException BsResponse))
-> m BsResponse -> m (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ GET
-> Url scheme
-> NoReqBody
-> Proxy BsResponse
-> Option scheme
-> m 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 a. Monoid a => a
mempty


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

---------------------------------  ERROR TYPES  --------------------------------

-- | Error related to network operations.
data NetworkError
  = ConnectionFailure URI Text -- ^ connection failure
  | InvalidResponse URI Text        -- ^ error during obtaining response
  | InvalidStatus URI Int Text      -- ^ invalid response status
  | InvalidURL URI                  -- ^ given /URI/ is not valid
  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}|]
  InvalidResponse URI
uri Text
reason ->
    [i|Cannot decode response for '#{URI.render uri}': #{reason}|]
  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}|]