2014-10-25 01:27:39 +02:00
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Servant.API.RQBody where
|
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
import Data.Aeson
|
|
|
|
import Data.Proxy
|
|
|
|
import Network.Wai
|
|
|
|
import Servant.API.Sub
|
|
|
|
import Servant.Client
|
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
|
|
|
|
data RQBody a
|
|
|
|
|
|
|
|
instance (FromJSON a, HasServer sublayout)
|
|
|
|
=> HasServer (RQBody a :> sublayout) where
|
|
|
|
|
|
|
|
type Server (RQBody a :> sublayout) =
|
|
|
|
a -> Server sublayout
|
|
|
|
|
2014-10-27 11:24:20 +01:00
|
|
|
route Proxy subserver globalPathInfo request respond = do
|
2014-10-25 01:27:39 +02:00
|
|
|
mrqbody <- decode' <$> lazyRequestBody request
|
|
|
|
case mrqbody of
|
2014-10-27 11:24:20 +01:00
|
|
|
Nothing -> respond Nothing
|
|
|
|
Just v -> route (Proxy :: Proxy sublayout) (subserver v) globalPathInfo request respond
|
2014-10-25 01:27:39 +02:00
|
|
|
|
|
|
|
instance (ToJSON a, HasClient sublayout)
|
|
|
|
=> HasClient (RQBody a :> sublayout) where
|
|
|
|
|
|
|
|
type Client (RQBody a :> sublayout) =
|
|
|
|
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)
|
|
|
|
=> HasDocs (RQBody a :> sublayout) where
|
|
|
|
|
|
|
|
docsFor Proxy (endpoint, action) =
|
|
|
|
docsFor sublayoutP (endpoint, action')
|
|
|
|
|
|
|
|
where sublayoutP = Proxy :: Proxy sublayout
|
|
|
|
|
|
|
|
action' = action & rqbody .~ toSample p
|
|
|
|
p = Proxy :: Proxy a
|