{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Body` trait.
module WebGear.Server.Trait.Body () where

import Control.Arrow (returnA)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.Aeson as Aeson
import Data.ByteString.Conversion (FromByteString, ToByteString, parser, runParser', toByteString)
import Data.ByteString.Lazy (fromChunks)
import Data.Text (Text, pack)
import Network.HTTP.Media.RenderHeader (RenderHeader (renderHeader))
import Network.HTTP.Types (hContentType)
import WebGear.Core.Handler (Handler (..))
import WebGear.Core.Request (Request, getRequestBodyChunk)
import WebGear.Core.Response (Response (..))
import WebGear.Core.Trait (Get (..), Linked, Set (..), unlink)
import WebGear.Core.Trait.Body (Body (..), JSONBody (..))
import WebGear.Server.Handler (ServerHandler)

instance (MonadIO m, FromByteString val) => Get (ServerHandler m) (Body val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait :: Body val -> ServerHandler m (Linked ts Request) (Either Text val)
  getTrait :: forall (ts :: [*]).
Body val -> ServerHandler m (Linked ts Request) (Either Text val)
getTrait (Body Maybe MediaType
_) = forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM forall a b. (a -> b) -> a -> b
$ \Linked ts Request
request -> do
    [ByteString]
chunks <- forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM (forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBodyChunk forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
request
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. Parser a -> ByteString -> Either String a
runParser' forall a. FromByteString a => Parser a
parser ([ByteString] -> ByteString
fromChunks [ByteString]
chunks) of
      Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
e
      Right val
t -> forall a b. b -> Either a b
Right val
t

instance (Monad m, ToByteString val) => Set (ServerHandler m) (Body val) Response where
  {-# INLINEABLE setTrait #-}
  setTrait ::
    Body val ->
    (Linked ts Response -> Response -> val -> Linked (Body val : ts) Response) ->
    ServerHandler m (Linked ts Response, val) (Linked (Body val : ts) Response)
  setTrait :: forall (ts :: [*]).
Body val
-> (Linked ts Response
    -> Response -> val -> Linked (Body val : ts) Response)
-> ServerHandler
     m (Linked ts Response, val) (Linked (Body val : ts) Response)
setTrait (Body Maybe MediaType
mediaType) Linked ts Response
-> Response -> val -> Linked (Body val : ts) Response
f = proc (Linked ts Response
linkedResponse, val
val) -> do
    let response :: Response
response = (forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
linkedResponse)
        response' :: Response
response' =
          Response
response
            { responseBody :: Maybe ByteString
responseBody = forall a. a -> Maybe a
Just (forall a. ToByteString a => a -> ByteString
toByteString val
val)
            , responseHeaders :: HashMap HeaderName ByteString
responseHeaders =
                Response -> HashMap HeaderName ByteString
responseHeaders Response
response
                  forall a. Semigroup a => a -> a -> a
<> case Maybe MediaType
mediaType of
                    Just MediaType
mt -> [(HeaderName
hContentType, forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
mt)]
                    Maybe MediaType
Nothing -> []
            }
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Linked ts Response
-> Response -> val -> Linked (Body val : ts) Response
f Linked ts Response
linkedResponse Response
response' val
val

instance (MonadIO m, Aeson.FromJSON val) => Get (ServerHandler m) (JSONBody val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait :: JSONBody val -> ServerHandler m (Linked ts Request) (Either Text val)
  getTrait :: forall (ts :: [*]).
JSONBody val
-> ServerHandler m (Linked ts Request) (Either Text val)
getTrait (JSONBody Maybe MediaType
_) = forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM forall a b. (a -> b) -> a -> b
$ \Linked ts Request
request -> do
    [ByteString]
chunks <- forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM (forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBodyChunk forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
request
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ([ByteString] -> ByteString
fromChunks [ByteString]
chunks) of
      Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
e
      Right val
t -> forall a b. b -> Either a b
Right val
t

instance (Monad m, Aeson.ToJSON val) => Set (ServerHandler m) (JSONBody val) Response where
  {-# INLINEABLE setTrait #-}
  setTrait ::
    JSONBody val ->
    (Linked ts Response -> Response -> val -> Linked (JSONBody val : ts) Response) ->
    ServerHandler m (Linked ts Response, val) (Linked (JSONBody val : ts) Response)
  setTrait :: forall (ts :: [*]).
JSONBody val
-> (Linked ts Response
    -> Response -> val -> Linked (JSONBody val : ts) Response)
-> ServerHandler
     m (Linked ts Response, val) (Linked (JSONBody val : ts) Response)
setTrait (JSONBody Maybe MediaType
mediaType) Linked ts Response
-> Response -> val -> Linked (JSONBody val : ts) Response
f = proc (Linked ts Response
linkedResponse, val
val) -> do
    let response :: Response
response = forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
linkedResponse
        ctype :: ByteString
ctype = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"application/json" forall h. RenderHeader h => h -> ByteString
renderHeader Maybe MediaType
mediaType
        response' :: Response
response' =
          Response
response
            { responseBody :: Maybe ByteString
responseBody = forall a. a -> Maybe a
Just (forall a. ToJSON a => a -> ByteString
Aeson.encode val
val)
            , responseHeaders :: HashMap HeaderName ByteString
responseHeaders =
                Response -> HashMap HeaderName ByteString
responseHeaders Response
response
                  forall a. Semigroup a => a -> a -> a
<> [(HeaderName
hContentType, ByteString
ctype)]
            }
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Linked ts Response
-> Response -> val -> Linked (JSONBody val : ts) Response
f Linked ts Response
linkedResponse Response
response' val
val

takeWhileM :: Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM :: forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM a -> Bool
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
takeWhileM a -> Bool
p (m a
mx : [m a]
mxs) = do
  a
x <- m a
mx
  if a -> Bool
p a
x
    then (a
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM a -> Bool
p [m a]
mxs
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure []