{-# OPTIONS_GHC -Wno-orphans #-}
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 []