{-# 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 :: Body val -> ServerHandler m (Linked ts Request) (Either Text val)
getTrait (Body Maybe MediaType
_) = (Linked ts Request -> m (Either Text val))
-> ServerHandler m (Linked ts Request) (Either Text val)
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM ((Linked ts Request -> m (Either Text val))
 -> ServerHandler m (Linked ts Request) (Either Text val))
-> (Linked ts Request -> m (Either Text val))
-> ServerHandler m (Linked ts Request) (Either Text val)
forall a b. (a -> b) -> a -> b
$ \Linked ts Request
request -> do
    [ByteString]
chunks <- (ByteString -> Bool) -> [m ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
forall a. Monoid a => a
mempty) ([m ByteString] -> m [ByteString])
-> [m ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ m ByteString -> [m ByteString]
forall a. a -> [a]
repeat (m ByteString -> [m ByteString]) -> m ByteString -> [m ByteString]
forall a b. (a -> b) -> a -> b
$ IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBodyChunk (Request -> IO ByteString) -> Request -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Linked ts Request -> Request
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
request
    Either Text val -> m (Either Text val)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text val -> m (Either Text val))
-> Either Text val -> m (Either Text val)
forall a b. (a -> b) -> a -> b
$ case Parser val -> ByteString -> Either String val
forall a. Parser a -> ByteString -> Either String a
runParser' Parser val
forall a. FromByteString a => Parser a
parser ([ByteString] -> ByteString
fromChunks [ByteString]
chunks) of
      Left String
e -> Text -> Either Text val
forall a b. a -> Either a b
Left (Text -> Either Text val) -> Text -> Either Text val
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
e
      Right val
t -> val -> Either Text val
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 :: 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 = (Linked ts Response -> Response
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
linkedResponse)
        response' :: Response
response' =
          Response
response
            { responseBody :: Maybe ByteString
responseBody = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (val -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString val
val)
            , responseHeaders :: HashMap HeaderName ByteString
responseHeaders =
                Response -> HashMap HeaderName ByteString
responseHeaders Response
response
                  HashMap HeaderName ByteString
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall a. Semigroup a => a -> a -> a
<> case Maybe MediaType
mediaType of
                    Just MediaType
mt -> [(HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
mt)]
                    Maybe MediaType
Nothing -> []
            }
    ServerHandler
  m
  (Linked (Body val : ts) Response)
  (Linked (Body val : ts) Response)
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 :: JSONBody val
-> ServerHandler m (Linked ts Request) (Either Text val)
getTrait (JSONBody Maybe MediaType
_) = (Linked ts Request -> m (Either Text val))
-> ServerHandler m (Linked ts Request) (Either Text val)
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM ((Linked ts Request -> m (Either Text val))
 -> ServerHandler m (Linked ts Request) (Either Text val))
-> (Linked ts Request -> m (Either Text val))
-> ServerHandler m (Linked ts Request) (Either Text val)
forall a b. (a -> b) -> a -> b
$ \Linked ts Request
request -> do
    [ByteString]
chunks <- (ByteString -> Bool) -> [m ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
forall a. Monoid a => a
mempty) ([m ByteString] -> m [ByteString])
-> [m ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ m ByteString -> [m ByteString]
forall a. a -> [a]
repeat (m ByteString -> [m ByteString]) -> m ByteString -> [m ByteString]
forall a b. (a -> b) -> a -> b
$ IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
getRequestBodyChunk (Request -> IO ByteString) -> Request -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Linked ts Request -> Request
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
request
    Either Text val -> m (Either Text val)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text val -> m (Either Text val))
-> Either Text val -> m (Either Text val)
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either String val
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ([ByteString] -> ByteString
fromChunks [ByteString]
chunks) of
      Left String
e -> Text -> Either Text val
forall a b. a -> Either a b
Left (Text -> Either Text val) -> Text -> Either Text val
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
e
      Right val
t -> val -> Either Text val
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 :: 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 = Linked ts Response -> Response
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
linkedResponse
        ctype :: ByteString
ctype = ByteString
-> (MediaType -> ByteString) -> Maybe MediaType -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"application/json" MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader Maybe MediaType
mediaType
        response' :: Response
response' =
          Response
response
            { responseBody :: Maybe ByteString
responseBody = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (val -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode val
val)
            , responseHeaders :: HashMap HeaderName ByteString
responseHeaders =
                Response -> HashMap HeaderName ByteString
responseHeaders Response
response
                  HashMap HeaderName ByteString
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
hContentType, ByteString
ctype)]
            }
    ServerHandler
  m
  (Linked (JSONBody val : ts) Response)
  (Linked (JSONBody val : ts) Response)
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 :: (a -> Bool) -> [m a] -> m [a]
takeWhileM a -> Bool
_ [] = [a] -> m [a]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Bool) -> [m a] -> m [a]
forall (m :: * -> *) a. Monad m => (a -> Bool) -> [m a] -> m [a]
takeWhileM a -> Bool
p [m a]
mxs
    else [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []