module Web.Minion.Response.Body (
  module Web.Minion.Response,
  RespBody (..),
  EncodeBody (..),
  Encode (..),
  handleBody,
) where

import Control.Exception qualified as Exc
import Control.Exception.Base (throw)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class qualified as IO
import Data.ByteString qualified as Bytes
import Data.ByteString.Builder qualified as Bytes.Builder
import Data.ByteString.Lazy qualified as Bytes.Lazy
import Data.List.NonEmpty qualified as Nel
import Data.Maybe (isJust)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text.Encode
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Lazy.Encoding qualified as Text.Lazy.Encode
import Network.HTTP.Media qualified as Http
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai
import Web.Minion.Args
import Web.Minion.Error
import Web.Minion.Introspect qualified as I
import Web.Minion.Media
import Web.Minion.Media.PlainText (PlainText)
import Web.Minion.Response
import Web.Minion.Router.Internal

newtype RespBody cts a = RespBody a

instance (AllContentTypes cts) => CanRespond (RespBody cts a) where
  canRespond :: [ByteString] -> Bool
canRespond [] = Bool
True
  canRespond [ByteString]
l = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe MediaType -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MediaType -> Bool)
-> (ByteString -> Maybe MediaType) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
Http.matchAccept (forall (cts :: k). AllContentTypes cts => [MediaType]
forall {k} (cts :: k). AllContentTypes cts => [MediaType]
allContentTypes @cts)) [ByteString]
l

instance (MonadIO m) => ToResponse m (RespBody '[] a) where
  toResponse :: [ByteString] -> RespBody '[] a -> m Response
toResponse [ByteString]
_ (RespBody a
_) = IO Response -> m Response
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Response -> m Response) -> IO Response -> m Response
forall a b. (a -> b) -> a -> b
$ SomethingWentWrong -> IO Response
forall e a. Exception e => e -> IO a
Exc.throwIO SomethingWentWrong
SomethingWentWrong

instance (EncodeBody (ct ': cts) a, Encode ct a, MonadIO m, ContentType ct) => ToResponse m (RespBody (ct ': cts) a) where
  toResponse :: [ByteString] -> RespBody (ct : cts) a -> m Response
toResponse [] (RespBody a
a) = Response -> m Response
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ forall (ct :: a) a. Encode ct a => a -> Response
forall {k} (ct :: k) a. Encode ct a => a -> Response
encode @ct a
a
  toResponse (ByteString
ct : [ByteString]
_) (RespBody a
a) = Response -> m Response
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ forall (cts :: [a]) a.
EncodeBody cts a =>
ByteString -> a -> Response
forall {k} (cts :: k) a.
EncodeBody cts a =>
ByteString -> a -> Response
encodeBody @(ct ': cts) ByteString
ct a
a

class EncodeBody cts a where
  encodeBody :: Bytes.ByteString -> a -> Wai.Response

instance EncodeBody '[] a where
  encodeBody :: ByteString -> a -> Response
encodeBody ByteString
_ a
_ = SomethingWentWrong -> Response
forall a e. Exception e => e -> a
throw SomethingWentWrong
SomethingWentWrong

instance (ContentType ct, Encode ct a, EncodeBody cts a) => EncodeBody (ct ': cts) a where
  encodeBody :: ByteString -> a -> Response
encodeBody ByteString
ct a
a
    | Just MediaType
_ <- [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
Http.matchAccept (NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
Nel.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ forall (a :: a). ContentType a => NonEmpty MediaType
forall {k} (a :: k). ContentType a => NonEmpty MediaType
media @ct) ByteString
ct = forall (ct :: a) a. Encode ct a => a -> Response
forall {k} (ct :: k) a. Encode ct a => a -> Response
encode @ct a
a
    | Bool
otherwise = forall (cts :: [a]) a.
EncodeBody cts a =>
ByteString -> a -> Response
forall {k} (cts :: k) a.
EncodeBody cts a =>
ByteString -> a -> Response
encodeBody @cts ByteString
ct a
a

class Encode ct a where
  encode :: a -> Wai.Response

plainTextHeader :: (Http.HeaderName, Bytes.ByteString)
plainTextHeader :: (HeaderName, ByteString)
plainTextHeader = (HeaderName
Http.hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
Http.renderHeader (MediaType -> ByteString) -> MediaType -> ByteString
forall a b. (a -> b) -> a -> b
$ NonEmpty MediaType -> MediaType
forall a. NonEmpty a -> a
Nel.head (NonEmpty MediaType -> MediaType)
-> NonEmpty MediaType -> MediaType
forall a b. (a -> b) -> a -> b
$ forall a. ContentType a => NonEmpty MediaType
forall {k} (a :: k). ContentType a => NonEmpty MediaType
media @PlainText)

instance Encode PlainText Text.Text where
  encode :: Text -> Response
encode Text
a =
    Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder
      Status
Http.status200
      [(HeaderName, ByteString)
Item ResponseHeaders
plainTextHeader]
      ( ByteString -> Builder
Bytes.Builder.lazyByteString
          (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Bytes.Lazy.fromStrict
          (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.Encode.encodeUtf8
          (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
a
      )

instance Encode PlainText Text.Lazy.Text where
  encode :: Text -> Response
encode Text
a =
    Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder
      Status
Http.status200
      [(HeaderName, ByteString)
Item ResponseHeaders
plainTextHeader]
      ( ByteString -> Builder
Bytes.Builder.lazyByteString
          (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.Lazy.Encode.encodeUtf8
          (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Text
a
      )

instance Encode PlainText String where
  encode :: String -> Response
encode String
a =
    Status -> ResponseHeaders -> Builder -> Response
Wai.responseBuilder
      Status
Http.status200
      [(HeaderName, ByteString)
Item ResponseHeaders
plainTextHeader]
      ( ByteString -> Builder
Bytes.Builder.lazyByteString
          (ByteString -> Builder)
-> (String -> ByteString) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.Lazy.Encode.encodeUtf8
          (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.Lazy.pack
          (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
a
      )

{- | Handles request with specified HTTP method and responds with specified Content-Type

@
... '/>' 'handleBody' GET \@'[PlainText] \@MyResponse someEndpoint
@
-}
{-# INLINE handleBody #-}
handleBody ::
  forall cts o m ts i st.
  (HandleArgs ts st m) =>
  (IsResponse m (RespBody cts o)) =>
  (I.Introspection i I.Response (RespBody cts o)) =>
  -- | .
  Http.Method ->
  (DelayedArgs st ~> m o) ->
  Router' i ts m
handleBody :: forall {k} (cts :: k) o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, IsResponse m (RespBody cts o),
 Introspection i 'Response (RespBody cts o)) =>
ByteString -> (DelayedArgs st ~> m o) -> Router' i ts m
handleBody ByteString
method = forall (f :: * -> *) o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, ToResponse m (f o), CanRespond (f o),
 Introspection i 'Response (f o)) =>
ByteString
-> (o -> f o) -> (DelayedArgs st ~> m o) -> Router' i ts m
makeHandle @(RespBody cts) @o ByteString
method o -> RespBody cts o
forall {k} (cts :: k) a. a -> RespBody cts a
RespBody