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

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

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.Methods
import Dormouse.Client.Payload
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 qualified Streamly.External.ByteString as SEB
import qualified Streamly.Data.Stream as Stream

givesPopper :: Stream.Stream IO Word8 -> C.GivesPopper ()
givesPopper :: Stream IO Word8 -> GivesPopper ()
givesPopper Stream IO Word8
rawStream NeedsPopper ()
k = do
  let initialStream :: Stream IO (Array Word8)
initialStream = Int -> Stream IO Word8 -> Stream IO (Array Word8)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
Int -> Stream m a -> Stream m (Array a)
Stream.chunksOf Int
32768 Stream IO Word8
rawStream
  IORef (Stream IO (Array Word8))
streamState <- Stream IO (Array Word8) -> IO (IORef (Stream IO (Array Word8)))
forall a. a -> IO (IORef a)
newIORef Stream IO (Array Word8)
initialStream
  let popper :: IO ByteString
popper = do
        Stream IO (Array Word8)
stream <- IORef (Stream IO (Array Word8)) -> IO (Stream IO (Array Word8))
forall a. IORef a -> IO a
readIORef IORef (Stream IO (Array Word8))
streamState
        Maybe (Array Word8, Stream IO (Array Word8))
test <- Stream IO (Array Word8)
-> IO (Maybe (Array Word8, Stream IO (Array Word8)))
forall (m :: * -> *) a.
Monad m =>
Stream m a -> m (Maybe (a, Stream m a))
Stream.uncons Stream IO (Array Word8)
stream
        case Maybe (Array Word8, Stream IO (Array Word8))
test of
          Just (Array Word8
elems, Stream IO (Array Word8)
stream') -> IORef (Stream IO (Array Word8)) -> Stream IO (Array Word8) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Stream IO (Array Word8))
streamState Stream 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, Stream IO (Array Word8))
Nothing               -> ByteString -> IO ByteString
forall a. a -> IO a
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 Stream IO Word8
stream) = Int64 -> GivesPopper () -> RequestBody
C.RequestBodyStream (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size) (Stream IO Word8 -> GivesPopper ()
givesPopper Stream IO Word8
stream)
translateRequestBody (ChunkedTransfer Stream IO Word8
stream)           = GivesPopper () -> RequestBody
C.RequestBodyStreamChunked (Stream IO Word8 -> GivesPopper ()
givesPopper Stream 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
    { C.host = host
    , C.path = encodePath path
    , C.secure = isSecure
    , C.port = fromIntegral port
    , C.queryString = encodeQuery queryText
    }

responseStream :: C.Response C.BodyReader -> Stream.Stream IO Word8
responseStream :: Response (IO ByteString) -> Stream IO Word8
responseStream Response (IO ByteString)
resp = 
    IO ByteString -> Stream IO ByteString
forall (m :: * -> *) a. Monad m => m a -> Stream m a
Stream.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)
  Stream IO ByteString
-> (Stream IO ByteString -> Stream IO ByteString)
-> Stream IO ByteString
forall a b. a -> (a -> b) -> b
& (ByteString -> Bool)
-> Stream IO ByteString -> Stream IO ByteString
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Stream m a -> Stream m a
Stream.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null)
  Stream IO ByteString
-> (Stream IO ByteString -> Stream IO Word8) -> Stream IO Word8
forall a b. a -> (a -> b) -> b
& (ByteString -> Stream IO Word8)
-> Stream IO ByteString -> Stream IO Word8
forall (m :: * -> *) a b.
Monad m =>
(a -> Stream m b) -> Stream m a -> Stream m b
Stream.concatMap (Unfold IO ByteString Word8 -> ByteString -> Stream IO Word8
forall (m :: * -> *) a b.
Applicative m =>
Unfold m a b -> a -> Stream m b
Stream.unfold Unfold IO ByteString Word8
forall (m :: * -> *). Monad m => Unfold m ByteString Word8
SEB.reader)

sendHttp :: (HasDormouseClientConfig env, MonadReader env m, MonadIO m, IsUrl url) => HttpRequest url method RawRequestPayload contentTag acceptTag -> (HttpResponse (Stream.Stream IO Word8) -> IO (HttpResponse b)) -> m (HttpResponse b)
sendHttp :: forall env (m :: * -> *) url (method :: Symbol) contentTag
       acceptTag b.
(HasDormouseClientConfig env, MonadReader env m, MonadIO m,
 IsUrl url) =>
HttpRequest url method RawRequestPayload contentTag acceptTag
-> (HttpResponse (Stream 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 (Stream 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 a. (env -> a) -> m a
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 { C.method = methodAsByteString method, C.requestBody = translateRequestBody reqBody, C.requestHeaders = Map.toList reqHeaders }
  IO (HttpResponse b) -> m (HttpResponse b)
forall a. IO a -> m a
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 = [(HeaderName, ByteString)] -> Map HeaderName ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(HeaderName, ByteString)] -> Map HeaderName ByteString)
-> [(HeaderName, ByteString)] -> Map HeaderName ByteString
forall a b. (a -> b) -> a -> b
$ Response (IO ByteString) -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
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 (Stream IO Word8) -> IO (HttpResponse b)
deserialiseResp (HttpResponse (Stream IO Word8) -> IO (HttpResponse b))
-> HttpResponse (Stream IO Word8) -> IO (HttpResponse b)
forall a b. (a -> b) -> a -> b
$ HttpResponse 
        { responseStatusCode :: Int
responseStatusCode = Int
statusCode
        , responseHeaders :: Map HeaderName ByteString
responseHeaders = Map HeaderName ByteString
respHeaders
        , responseBody :: Stream IO Word8
responseBody = Response (IO ByteString) -> Stream IO Word8
responseStream Response (IO ByteString)
resp
        }
      )