{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}

module Dormouse.Client.MonadIOImpl
  ( sendHttp
  , genClientRequestFromUrlComponents
  ) where

import Control.Exception.Safe (MonadThrow, throw)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Function ((&))
import Data.Functor (($>))
import Data.IORef
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word8)
import Data.ByteString as B
import Dormouse.Client.Class
import Dormouse.Client.Exception (UnexpectedStatusCodeException(..))
import Dormouse.Client.Methods
import Dormouse.Client.Payload
import Dormouse.Client.Status
import Dormouse.Client.Types
import Dormouse.Uri
import Dormouse.Uri.Encode
import Dormouse.Url
import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as T
import qualified Network.HTTP.Types.Status as NC
import Streamly
import qualified Streamly.Prelude as S
import qualified Streamly.External.ByteString as SEB
import qualified Streamly.Internal.Memory.ArrayStream as SIMA

givesPopper :: SerialT IO Word8 -> C.GivesPopper ()
givesPopper :: SerialT IO Word8 -> GivesPopper ()
givesPopper SerialT IO Word8
rawStream NeedsPopper ()
k = do
  let initialStream :: SerialT IO (Array Word8)
initialStream = Int -> SerialT IO Word8 -> SerialT IO (Array Word8)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadIO m, Storable a) =>
Int -> t m a -> t m (Array a)
SIMA.arraysOf Int
32768 SerialT IO Word8
rawStream
  IORef (SerialT IO (Array Word8))
streamState <- SerialT IO (Array Word8) -> IO (IORef (SerialT IO (Array Word8)))
forall a. a -> IO (IORef a)
newIORef SerialT IO (Array Word8)
initialStream
  let popper :: IO ByteString
popper = do
        SerialT IO (Array Word8)
stream <- IORef (SerialT IO (Array Word8)) -> IO (SerialT IO (Array Word8))
forall a. IORef a -> IO a
readIORef IORef (SerialT IO (Array Word8))
streamState
        Maybe (Array Word8, SerialT IO (Array Word8))
test <- SerialT IO (Array Word8)
-> IO (Maybe (Array Word8, SerialT IO (Array Word8)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
SerialT m a -> m (Maybe (a, t m a))
S.uncons SerialT IO (Array Word8)
stream
        case Maybe (Array Word8, SerialT IO (Array Word8))
test of
          Just (Array Word8
elems, SerialT IO (Array Word8)
stream') -> IORef (SerialT IO (Array Word8))
-> SerialT IO (Array Word8) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SerialT IO (Array Word8))
streamState SerialT IO (Array Word8)
stream' IO () -> ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Array Word8 -> ByteString
SEB.fromArray Array Word8
elems
          Maybe (Array Word8, SerialT IO (Array Word8))
Nothing               -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
  NeedsPopper ()
k IO ByteString
popper

translateRequestBody :: RawRequestPayload -> C.RequestBody
translateRequestBody :: RawRequestPayload -> RequestBody
translateRequestBody (DefinedContentLength Word64
size SerialT IO Word8
stream) = Int64 -> GivesPopper () -> RequestBody
C.RequestBodyStream (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size) (SerialT IO Word8 -> GivesPopper ()
givesPopper SerialT IO Word8
stream)
translateRequestBody (ChunkedTransfer SerialT IO Word8
stream)           = GivesPopper () -> RequestBody
C.RequestBodyStreamChunked (SerialT IO Word8 -> GivesPopper ()
givesPopper SerialT IO Word8
stream)

genClientRequestFromUrlComponents :: AnyUrl -> C.Request
genClientRequestFromUrlComponents :: AnyUrl -> Request
genClientRequestFromUrlComponents AnyUrl
url =
  let (UrlScheme
scheme, UrlComponents
comps) = case AnyUrl
url of
        AnyUrl (HttpUrl UrlComponents
uc)  -> (UrlScheme
HttpScheme, UrlComponents
uc)
        AnyUrl (HttpsUrl UrlComponents
uc) -> (UrlScheme
HttpsScheme, UrlComponents
uc)
      authority :: Authority
authority = UrlComponents -> Authority
urlAuthority UrlComponents
comps
      path :: Path 'Absolute
path = UrlComponents -> Path 'Absolute
urlPath UrlComponents
comps
      queryParams :: Maybe Query
queryParams = UrlComponents -> Maybe Query
urlQuery UrlComponents
comps
      host :: ByteString
host = Bool -> ByteString -> ByteString
T.urlEncode Bool
False (ByteString -> ByteString)
-> (Authority -> ByteString) -> Authority -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Authority -> Text) -> Authority -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Text
unHost (Host -> Text) -> (Authority -> Host) -> Authority -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Authority -> Host
authorityHost (Authority -> ByteString) -> Authority -> ByteString
forall a b. (a -> b) -> a -> b
$ Authority
authority
      (Bool
isSecure, Int
port) = case UrlScheme
scheme of
        UrlScheme
HttpScheme -> (Bool
False, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
80 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Authority -> Maybe Int
authorityPort Authority
authority)
        UrlScheme
HttpsScheme -> (Bool
True, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
443 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$  Authority -> Maybe Int
authorityPort Authority
authority)
      queryText :: Query
queryText = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
"" Maybe Query
queryParams in
  Request
C.defaultRequest
    { host :: ByteString
C.host = ByteString
host
    , path :: ByteString
C.path = Path 'Absolute -> ByteString
encodePath Path 'Absolute
path
    , secure :: Bool
C.secure = Bool
isSecure
    , port :: Int
C.port = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
    , queryString :: ByteString
C.queryString = Query -> ByteString
encodeQuery Query
queryText
    }

responseStream :: C.Response C.BodyReader -> SerialT IO Word8
responseStream :: Response (IO ByteString) -> SerialT IO Word8
responseStream Response (IO ByteString)
resp = 
    IO ByteString -> SerialT IO ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, MonadAsync m) =>
m a -> t m a
S.repeatM (IO ByteString -> IO ByteString
C.brRead (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> IO ByteString
forall body. Response body -> body
C.responseBody Response (IO ByteString)
resp)
  SerialT IO ByteString
-> (SerialT IO ByteString -> SerialT IO ByteString)
-> SerialT IO ByteString
forall a b. a -> (a -> b) -> b
& (ByteString -> Bool)
-> SerialT IO ByteString -> SerialT IO ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> Bool) -> t m a -> t m a
S.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null)
  SerialT IO ByteString
-> (SerialT IO ByteString -> SerialT IO Word8) -> SerialT IO Word8
forall a b. a -> (a -> b) -> b
& (ByteString -> SerialT IO Word8)
-> SerialT IO ByteString -> SerialT IO Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
(a -> t m b) -> t m a -> t m b
S.concatMap (Unfold IO ByteString Word8 -> ByteString -> SerialT IO Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(IsStream t, Monad m) =>
Unfold m a b -> a -> t m b
S.unfold Unfold IO ByteString Word8
forall (m :: * -> *). Monad m => Unfold m ByteString Word8
SEB.read)

sendHttp :: (HasDormouseClientConfig env, MonadReader env m, MonadIO m, MonadThrow m, IsUrl url) => HttpRequest url method RawRequestPayload contentTag acceptTag -> (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)) -> m (HttpResponse b)
sendHttp :: HttpRequest url method RawRequestPayload contentTag acceptTag
-> (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b))
-> m (HttpResponse b)
sendHttp HttpRequest { requestMethod :: forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag
-> HttpMethod method
requestMethod = HttpMethod method
method, requestUrl :: forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> url
requestUrl = url
url, requestBody :: forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag -> body
requestBody = RawRequestPayload
reqBody, requestHeaders :: forall url (method :: Symbol) body contentTag acceptTag.
HttpRequest url method body contentTag acceptTag
-> Map HeaderName ByteString
requestHeaders = Map HeaderName ByteString
reqHeaders} HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
deserialiseResp = do
  Manager
manager <- DormouseClientConfig -> Manager
clientManager (DormouseClientConfig -> Manager)
-> m DormouseClientConfig -> m Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (env -> DormouseClientConfig) -> m DormouseClientConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader env -> DormouseClientConfig
forall a. HasDormouseClientConfig a => a -> DormouseClientConfig
getDormouseClientConfig
  let initialRequest :: Request
initialRequest = AnyUrl -> Request
genClientRequestFromUrlComponents (AnyUrl -> Request) -> AnyUrl -> Request
forall a b. (a -> b) -> a -> b
$ url -> AnyUrl
forall url. IsUrl url => url -> AnyUrl
asAnyUrl url
url
  let request :: Request
request = Request
initialRequest { method :: ByteString
C.method = HttpMethod method -> ByteString
forall (a :: Symbol). HttpMethod a -> ByteString
methodAsByteString HttpMethod method
method, requestBody :: RequestBody
C.requestBody = RawRequestPayload -> RequestBody
translateRequestBody RawRequestPayload
reqBody, requestHeaders :: RequestHeaders
C.requestHeaders = Map HeaderName ByteString -> RequestHeaders
forall k a. Map k a -> [(k, a)]
Map.toList Map HeaderName ByteString
reqHeaders }
  HttpResponse b
response <- IO (HttpResponse b) -> m (HttpResponse b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HttpResponse b) -> m (HttpResponse b))
-> IO (HttpResponse b) -> m (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ Request
-> Manager
-> (Response (IO ByteString) -> IO (HttpResponse b))
-> IO (HttpResponse b)
forall a.
Request -> Manager -> (Response (IO ByteString) -> IO a) -> IO a
C.withResponse Request
request Manager
manager (\Response (IO ByteString)
resp -> do
      let respHeaders :: Map HeaderName ByteString
respHeaders = RequestHeaders -> Map HeaderName ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (RequestHeaders -> Map HeaderName ByteString)
-> RequestHeaders -> Map HeaderName ByteString
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> RequestHeaders
forall body. Response body -> RequestHeaders
C.responseHeaders Response (IO ByteString)
resp
      let statusCode :: Int
statusCode = Status -> Int
NC.statusCode (Status -> Int)
-> (Response (IO ByteString) -> Status)
-> Response (IO ByteString)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response (IO ByteString) -> Status
forall body. Response body -> Status
C.responseStatus (Response (IO ByteString) -> Int)
-> Response (IO ByteString) -> Int
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString)
resp
      HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
deserialiseResp (HttpResponse (SerialT IO Word8) -> IO (HttpResponse b))
-> HttpResponse (SerialT IO Word8) -> IO (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ HttpResponse :: forall body.
Int -> Map HeaderName ByteString -> body -> HttpResponse body
HttpResponse 
        { responseStatusCode :: Int
responseStatusCode = Int
statusCode
        , responseHeaders :: Map HeaderName ByteString
responseHeaders = Map HeaderName ByteString
respHeaders
        , responseBody :: SerialT IO Word8
responseBody = Response (IO ByteString) -> SerialT IO Word8
responseStream Response (IO ByteString)
resp
        }
      ) 
  case HttpResponse b -> Int
forall body. HttpResponse body -> Int
responseStatusCode HttpResponse b
response of
    Int
Successful -> HttpResponse b -> m (HttpResponse b)
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse b
response
    Int
_          -> UnexpectedStatusCodeException -> m (HttpResponse b)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (UnexpectedStatusCodeException -> m (HttpResponse b))
-> UnexpectedStatusCodeException -> m (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ Int -> UnexpectedStatusCodeException
UnexpectedStatusCodeException (HttpResponse b -> Int
forall body. HttpResponse body -> Int
responseStatusCode HttpResponse b
response)