2014-10-25 01:27:39 +02:00
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2014-10-28 16:29:04 +01:00
|
|
|
module Servant.API.ReqBody where
|
2014-10-25 01:27:39 +02:00
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
import Data.Aeson
|
|
|
|
import Data.Proxy
|
|
|
|
import Network.Wai
|
|
|
|
import Servant.API.Sub
|
|
|
|
import Servant.Client
|
2014-11-07 11:57:41 +01:00
|
|
|
import Servant.Common.Req
|
2014-10-28 09:04:27 +01:00
|
|
|
import Servant.Docs
|
2014-10-25 01:27:39 +02:00
|
|
|
import Servant.Server
|
|
|
|
|
|
|
|
-- * Request Body support
|
2014-10-28 16:29:04 +01:00
|
|
|
data ReqBody a
|
2014-10-25 01:27:39 +02:00
|
|
|
|
|
|
|
instance (FromJSON a, HasServer sublayout)
|
2014-10-28 16:29:04 +01:00
|
|
|
=> HasServer (ReqBody a :> sublayout) where
|
2014-10-25 01:27:39 +02:00
|
|
|
|
2014-10-28 16:29:04 +01:00
|
|
|
type Server (ReqBody a :> sublayout) =
|
2014-10-25 01:27:39 +02:00
|
|
|
a -> Server sublayout
|
|
|
|
|
2014-10-28 10:42:49 +01:00
|
|
|
route Proxy subserver request respond = do
|
2014-10-25 01:27:39 +02:00
|
|
|
mrqbody <- decode' <$> lazyRequestBody request
|
|
|
|
case mrqbody of
|
2014-10-28 16:52:30 +01:00
|
|
|
Nothing -> respond $ failWith InvalidBody
|
2014-10-28 10:42:49 +01:00
|
|
|
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
|
2014-10-25 01:27:39 +02:00
|
|
|
|
|
|
|
instance (ToJSON a, HasClient sublayout)
|
2014-10-28 16:29:04 +01:00
|
|
|
=> HasClient (ReqBody a :> sublayout) where
|
2014-10-25 01:27:39 +02:00
|
|
|
|
2014-10-28 16:29:04 +01:00
|
|
|
type Client (ReqBody a :> sublayout) =
|
2014-10-25 01:27:39 +02:00
|
|
|
a -> Client sublayout
|
|
|
|
|
|
|
|
clientWithRoute Proxy req body =
|
|
|
|
clientWithRoute (Proxy :: Proxy sublayout) $
|
|
|
|
setRQBody (encode body) req
|
2014-10-28 09:04:27 +01:00
|
|
|
|
|
|
|
instance (ToSample a, HasDocs sublayout)
|
2014-10-28 16:29:04 +01:00
|
|
|
=> HasDocs (ReqBody a :> sublayout) where
|
2014-10-28 09:04:27 +01:00
|
|
|
|
|
|
|
docsFor Proxy (endpoint, action) =
|
|
|
|
docsFor sublayoutP (endpoint, action')
|
|
|
|
|
|
|
|
where sublayoutP = Proxy :: Proxy sublayout
|
|
|
|
|
2014-11-13 08:19:14 +01:00
|
|
|
action' = action & rqbody .~ sampleByteString p
|
2014-10-28 09:04:27 +01:00
|
|
|
p = Proxy :: Proxy a
|