eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Remove Canonicalize

Browse Source
This commit is contained in:
Julian K. Arni 2015-05-03 01:45:17 +02:00
parent bdf6d9aa48
commit 50b05860b7
12 changed files with 106 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-client/CHANGELOG.md
View File

@ -7,7 +7,6 @@
* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
* Support for PATCH
* Make () instances expect No Content status code, and not try to decode body.
* `Canonicalize` API types before generating client functions for them
* Add support for response headers
0.2.2

79
servant-client/src/Servant/Client.hs
View File

@ -53,17 +53,16 @@ import Servant.Common.Req
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
client p = clientWithRoute (canonicalize p) defReq
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client' layout :: *
clientWithRoute :: Proxy layout -> Req -> Client' layout
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
type Client layout = Client' (Canonicalize layout)
-- | A client querying function for @a ':<|>' b@ will actually hand you
-- one function for querying @a@ and another one for querying @b@,
@ -79,7 +78,7 @@ type Client layout = Client' (Canonicalize layout)
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client' (a :<|> b) = Client' a :<|> Client' b
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req
@ -106,8 +105,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
type Client' (Capture capture a :> sublayout) =
a -> Client' sublayout
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -120,7 +119,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance HasClient Delete where
type Client' Delete = BaseUrl -> EitherT ServantError IO ()
type Client Delete = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@ -134,7 +133,7 @@ instance
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
clientWithRoute Proxy req host =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
@ -145,7 +144,7 @@ instance
{-# OVERLAPPING #-}
#endif
HasClient (Get (ct ': cts) ()) where
type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
performRequestNoBody H.methodGet req [204] host
@ -157,7 +156,7 @@ instance
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client' (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
type Client (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host
return $ Headers { getResponse = resp
@ -192,8 +191,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (Header sym a :> sublayout) where
type Client' (Header sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -210,7 +209,7 @@ instance
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req uri =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
@ -222,7 +221,7 @@ instance
{-# OVERLAPPING #-}
#endif
HasClient (Post (ct ': cts) ()) where
type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPost req [204] host
@ -234,7 +233,7 @@ instance
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client' (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
type Client (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host
return $ Headers { getResponse = resp
@ -250,7 +249,7 @@ instance
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
@ -262,7 +261,7 @@ instance
{-# OVERLAPPING #-}
#endif
HasClient (Put (ct ': cts) ()) where
type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPut req [204] host
@ -274,7 +273,7 @@ instance
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client' (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
type Client (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host
return $ Headers { getResponse = resp
@ -290,7 +289,7 @@ instance
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
@ -302,7 +301,7 @@ instance
{-# OVERLAPPING #-}
#endif
HasClient (Patch (ct ': cts) ()) where
type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPatch req [204] host
@ -314,7 +313,7 @@ instance
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client' (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
type Client (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host
return $ Headers { getResponse = resp
@ -349,8 +348,8 @@ instance
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where
type Client' (QueryParam sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -391,8 +390,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where
type Client' (QueryParams sym a :> sublayout) =
[a] -> Client' sublayout
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -426,8 +425,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where
type Client' (QueryFlag sym :> sublayout) =
Bool -> Client' sublayout
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -465,8 +464,8 @@ instance (KnownSymbol sym, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParam sym a :> sublayout) where
type Client' (MatrixParam sym a :> sublayout) =
Maybe a -> Client' sublayout
type Client (MatrixParam sym a :> sublayout) =
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -506,8 +505,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParams sym a :> sublayout) where
type Client' (MatrixParams sym a :> sublayout) =
[a] -> Client' sublayout
type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -541,8 +540,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (MatrixFlag sym :> sublayout) where
type Client' (MatrixFlag sym :> sublayout) =
Bool -> Client' sublayout
type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -555,9 +554,9 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`.
instance HasClient Raw where
type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client' Raw
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod host = do
performRequest httpMethod req (const True) host
@ -582,8 +581,8 @@ instance HasClient Raw where
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
type Client' (ReqBody (ct ': cts) a :> sublayout) =
a -> Client' sublayout
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $ do
@ -592,7 +591,7 @@ instance (MimeRender ct a, HasClient sublayout)
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client' (path :> sublayout) = Client' sublayout
type Client (path :> sublayout) = Client sublayout
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) $

4
servant-client/test/Servant/ClientSpec.hs
View File

@ -307,8 +307,8 @@ spec = do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT ServantErr IO a,
HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
Proxy api -> WrappedApi

1
servant-docs/CHANGELOG.md
View File

@ -5,7 +5,6 @@
* Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)
* Remove ToJSON superclass from ToSample
* Split out Internal module
* `Canonicalize` API types before generating the docs for them
* Add support for response headers
0.3

12
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -291,8 +291,8 @@ makeLenses ''Action
-- | Generate the docs for a given API that implements 'HasDocs'. This is the
-- default way to create documentation.
docs :: HasDocs (Canonicalize layout) => Proxy layout -> API
docs p = docsFor (canonicalize p) (defEndpoint, defAction)
docs :: HasDocs layout => Proxy layout -> API
docs p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API.
@ -336,11 +336,7 @@ extraInfo p action =
-- 'extraInfo'.
--
-- If you only want to add an introduction, use 'docsWithIntros'.
docsWith :: HasDocs (Canonicalize layout)
=> [DocIntro]
-> ExtraInfo layout
-> Proxy layout
-> API
docsWith :: HasDocs layout => [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
docsWith intros (ExtraInfo endpoints) p =
docs p & apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith combineAction endpoints
@ -348,7 +344,7 @@ docsWith intros (ExtraInfo endpoints) p =
-- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s)
docsWithIntros :: HasDocs (Canonicalize layout) => [DocIntro] -> Proxy layout -> API
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros = docsWith intros mempty
-- | The class that abstracts away the impact of API combinators

7
servant-jquery/src/Servant/JQuery.hs
View File

@ -26,8 +26,8 @@ import Data.Proxy
import Servant.API
import Servant.JQuery.Internal
jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
jquery p = jqueryFor (canonicalize p) defReq
jquery :: HasJQ layout => Proxy layout -> JQ layout
jquery p = jqueryFor p defReq
-- js codegen
generateJS :: AjaxReq -> String
@ -112,6 +112,5 @@ instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
-- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type. You can then write it to
-- a file or integrate it in a page, for example.
jsForAPI :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
=> Proxy api -> String
jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String
jsForAPI p = jsFor (jquery p)

38
servant-jquery/src/Servant/JQuery/Internal.hs
View File

@ -194,14 +194,12 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
Elem a (b ': list) = Elem a list
class HasJQ (layout :: *) where
type JQ' layout :: *
jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
type JQ layout = JQ' (Canonicalize layout)
type JQ layout :: *
jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
instance (HasJQ a, HasJQ b)
=> HasJQ (a :<|> b) where
type JQ' (a :<|> b) = JQ' a :<|> JQ' b
type JQ (a :<|> b) = JQ a :<|> JQ b
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy a) req
@ -209,7 +207,7 @@ instance (HasJQ a, HasJQ b)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (Capture sym a :> sublayout) where
type JQ' (Capture sym a :> sublayout) = JQ' sublayout
type JQ (Capture sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -218,14 +216,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Delete where
type JQ' Delete = AjaxReq
type JQ Delete = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("delete" <>)
& reqMethod .~ "DELETE"
instance Elem JSON list => HasJQ (Get list a) where
type JQ' (Get list a) = AjaxReq
type JQ (Get list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("get" <>)
@ -233,7 +231,7 @@ instance Elem JSON list => HasJQ (Get list a) where
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (Header sym a :> sublayout) where
type JQ' (Header sym a :> sublayout) = JQ' sublayout
type JQ (Header sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
@ -242,14 +240,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
subP = Proxy :: Proxy sublayout
instance Elem JSON list => HasJQ (Post list a) where
type JQ' (Post list a) = AjaxReq
type JQ (Post list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("post" <>)
& reqMethod .~ "POST"
instance Elem JSON list => HasJQ (Put list a) where
type JQ' (Put list a) = AjaxReq
type JQ (Put list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("put" <>)
@ -257,7 +255,7 @@ instance Elem JSON list => HasJQ (Put list a) where
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryParam sym a :> sublayout) where
type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
type JQ (QueryParam sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -267,7 +265,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryParams sym a :> sublayout) where
type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
type JQ (QueryParams sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -277,7 +275,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (QueryFlag sym :> sublayout) where
type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
type JQ (QueryFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -287,7 +285,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixParam sym a :> sublayout) where
type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -298,7 +296,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixParams sym a :> sublayout) where
type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -308,7 +306,7 @@ instance (KnownSymbol sym, HasJQ sublayout)
instance (KnownSymbol sym, HasJQ sublayout)
=> HasJQ (MatrixFlag sym :> sublayout) where
type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -317,14 +315,14 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Raw where
type JQ' Raw = Method -> AjaxReq
type JQ Raw = Method -> AjaxReq
jqueryFor Proxy req method =
req & funcName %~ ((toLower <$> method) <>)
& reqMethod .~ method
instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
type JQ' (ReqBody list a :> sublayout) = JQ' sublayout
type JQ (ReqBody list a :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $
@ -332,7 +330,7 @@ instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout
instance (KnownSymbol path, HasJQ sublayout)
=> HasJQ (path :> sublayout) where
type JQ' (path :> sublayout) = JQ' sublayout
type JQ (path :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) $

1
servant-server/CHANGELOG.md
View File

@ -5,7 +5,6 @@
* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*
* Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29)
* Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21)
* Canonicalize API types before generating the handler types with `Server`
* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
* Add server support for response headers

6
servant-server/src/Servant/Server.hs
View File

@ -15,7 +15,6 @@ module Servant.Server
, -- * Handlers for all standard combinators
HasServer(..)
, Server
, ServerT
-- * Enter
-- $enterDoc
@ -80,7 +79,6 @@ module Servant.Server
import Data.Proxy (Proxy)
import Network.Wai (Application)
import Servant.API (Canonicalize, canonicalize)
import Servant.Server.Internal
import Servant.Server.Internal.Enter
import Servant.Server.Internal.ServantErr
@ -109,8 +107,8 @@ import Servant.Server.Internal.ServantErr
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
serve p server = toApplication (route (canonicalize p) server)
serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server)
-- Documentation

78
servant-server/src/Servant/Server/Internal.hs
View File

@ -38,7 +38,7 @@ import Network.Wai (Application, Request, Response,
requestMethod, responseLBS,
strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture,
Canonicalize, Delete, Get, Header,
Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams,
Patch, Post, Put, QueryFlag,
QueryParam, QueryParams, Raw,
@ -177,13 +177,11 @@ processedPathInfo r =
where pinfo = parsePathInfo r
class HasServer layout where
type ServerT' layout (m :: * -> *) :: *
type ServerT layout (m :: * -> *) :: *
route :: Proxy layout -> Server' layout -> RoutingApplication
route :: Proxy layout -> Server layout -> RoutingApplication
type Server layout = Server' (Canonicalize layout)
type Server' layout = ServerT' layout (EitherT ServantErr IO)
type ServerT layout m = ServerT' (Canonicalize layout) m
type Server layout = ServerT layout (EitherT ServantErr IO)
-- * Instances
@ -200,7 +198,7 @@ type ServerT layout m = ServerT' (Canonicalize layout) m
-- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT' (a :<|> b) m = ServerT' a m :<|> ServerT' b m
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy (a :<|> b) request respond =
route pa a request $ \mResponse ->
@ -234,8 +232,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where
type ServerT' (Capture capture a :> sublayout) m =
a -> ServerT' sublayout m
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)
@ -262,7 +260,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- are not met.
instance HasServer Delete where
type ServerT' Delete m = m ()
type ServerT Delete m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
@ -293,7 +291,7 @@ instance
#endif
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT' (Get ctypes a) m = m a
type ServerT (Get ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
@ -317,7 +315,7 @@ instance
#endif
HasServer (Get ctypes ()) where
type ServerT' (Get ctypes ()) m = m ()
type ServerT (Get ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
@ -337,7 +335,7 @@ instance
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Get ctypes (Headers h v)) where
type ServerT' (Get ctypes (Headers h v)) m = m (Headers h v)
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do
@ -378,8 +376,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where
type ServerT' (Header sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@ -407,7 +405,7 @@ instance
( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type ServerT' (Post ctypes a) m = m a
type ServerT (Post ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
@ -430,7 +428,7 @@ instance
#endif
HasServer (Post ctypes ()) where
type ServerT' (Post ctypes ()) m = m ()
type ServerT (Post ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
@ -450,7 +448,7 @@ instance
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Post ctypes (Headers h v)) where
type ServerT' (Post ctypes (Headers h v)) m = m (Headers h v)
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do
@ -487,7 +485,7 @@ instance
#endif
( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT' (Put ctypes a) m = m a
type ServerT (Put ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
@ -510,7 +508,7 @@ instance
#endif
HasServer (Put ctypes ()) where
type ServerT' (Put ctypes ()) m = m ()
type ServerT (Put ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
@ -530,7 +528,7 @@ instance
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Put ctypes (Headers h v)) where
type ServerT' (Put ctypes (Headers h v)) m = m (Headers h v)
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do
@ -565,7 +563,7 @@ instance
#endif
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT' (Patch ctypes a) m = m a
type ServerT (Patch ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
@ -588,7 +586,7 @@ instance
#endif
HasServer (Patch ctypes ()) where
type ServerT' (Patch ctypes ()) m = m ()
type ServerT (Patch ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
@ -608,7 +606,7 @@ instance
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Patch ctypes (Headers h v)) where
type ServerT' (Patch ctypes (Headers h v)) m = m (Headers h v)
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do
@ -650,8 +648,8 @@ instance
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where
type ServerT' (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -688,8 +686,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where
type ServerT' (QueryParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -721,8 +719,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where
type ServerT' (QueryFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request
@ -764,8 +762,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where
type ServerT' (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT' sublayout m
type ServerT (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -802,8 +800,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where
type ServerT' (MatrixParams sym a :> sublayout) m =
[a] -> ServerT' sublayout m
type ServerT (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -836,8 +834,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where
type ServerT' (MatrixFlag sym :> sublayout) m =
Bool -> ServerT' sublayout m
type ServerT (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
route Proxy subserver request respond = case parsePathInfo request of
(first : _)
@ -865,7 +863,7 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw where
type ServerT' Raw m = Application
type ServerT Raw m = Application
route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith)
@ -893,8 +891,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where
type ServerT' (ReqBody list a :> sublayout) m =
a -> ServerT' sublayout m
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
route Proxy subserver request respond = do
-- See HTTP RFC 2616, section 7.2.1
@ -914,7 +912,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
-- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT' (path :> sublayout) m = ServerT' sublayout m
type ServerT (path :> sublayout) m = ServerT sublayout m
route Proxy subserver request respond = case processedPathInfo request of
(first : rest)

1
servant/CHANGELOG.md
View File

@ -1,6 +1,5 @@
0.3
---
* Add a `Canonicalize` type family that distributes all `:>`s inside `:<|>`s to get to the canonical type of an API -- which is then used in all other packages to avoid weird handler types in *servant-server*.
* Multiple content-type/accept support for all the relevant combinators
* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
* Type-safe link generation to API endpoints

34
servant/src/Servant/API.hs
View File

@ -49,10 +49,6 @@ module Servant.API (
module Servant.Common.Text,
-- | Classes and instances for types that can be converted to and from @Text@
-- * Canonicalizing (flattening) API types
Canonicalize,
canonicalize,
-- * Utilities
module Servant.Utils.Links,
-- | Type-safe internal URIs
@ -88,33 +84,3 @@ import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)
-- | Turn an API type into its canonical form.
--
-- The canonical form of an API type is basically the all-flattened form
-- of the original type. More formally, it takes a type as input and hands you
-- back an /equivalent/ type formed of toplevel `:<|>`-separated chains of `:>`s,
-- i.e with all `:>`s distributed inside the `:<|>`s.
--
-- It basically turns:
--
-- > "hello" :> (Get Hello :<|> ReqBody Hello :> Put Hello)
--
-- into
--
-- > ("hello" :> Get Hello) :<|> ("hello" :> ReqBody Hello :> Put Hello)
--
-- i.e distributing all ':>'-separated bits into the subsequent ':<|>'s.
type family Canonicalize api :: * where
-- requires UndecidableInstances
Canonicalize (a :> (b :<|> c)) = a :> Canonicalize b :<|> a :> Canonicalize c
Canonicalize ((a :<|> b) :> c) = a :> Canonicalize c :<|> b :> Canonicalize c
Canonicalize (a :> b) = Redex b (Canonicalize b) a
Canonicalize (a :<|> b) = Canonicalize a :<|> Canonicalize b
Canonicalize a = a
type family Redex a b c :: * where
Redex a a first = Canonicalize first :> a
Redex a b first = Canonicalize (first :> b)
canonicalize :: Proxy layout -> Proxy (Canonicalize layout)
canonicalize Proxy = Proxy