Merge pull request #32 from haskell-servant/canonical-types
Canonicalize types
This commit is contained in:
Alp Mestanogullari
commit
01a020d432
4 changed files with 63 additions and 47 deletions
|
|
@ -5,6 +5,7 @@
|
|||
* 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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | This module lets you implement 'Server's for defined APIs. You'll
|
||||
|
|
@ -13,11 +14,12 @@ module Servant.Server
|
|||
, -- * Handlers for all standard combinators
|
||||
HasServer(..)
|
||||
, Server
|
||||
, ServerT
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy)
|
||||
import Network.Wai (Application)
|
||||
|
||||
import Servant.API (Canonicalize, canonicalize)
|
||||
import Servant.Server.Internal
|
||||
|
||||
|
||||
|
|
@ -43,5 +45,5 @@ import Servant.Server.Internal
|
|||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
serve :: HasServer layout => Proxy layout -> Server layout -> Application
|
||||
serve p server = toApplication (route p server)
|
||||
serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
|
||||
serve p server = toApplication (route (canonicalize p) server)
|
||||
|
|
|
|||
|
|
@ -32,17 +32,17 @@ import Network.Wai (Application, Request, Response,
|
|||
requestMethod, responseLBS,
|
||||
strictRequestBody)
|
||||
import Servant.API ((:<|>) (..), (:>), Capture,
|
||||
Delete, Get, Header, MatrixFlag,
|
||||
MatrixParam, MatrixParams, Patch,
|
||||
Post, Put, QueryFlag, QueryParam,
|
||||
QueryParams, Raw, ReqBody)
|
||||
Canonicalize, Delete, Get, Header,
|
||||
MatrixFlag, MatrixParam, MatrixParams,
|
||||
Patch, Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw,
|
||||
ReqBody)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..))
|
||||
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
|
||||
import Servant.Common.Text (FromText, fromText)
|
||||
|
||||
|
||||
data ReqBodyState = Uncalled
|
||||
| Called !B.ByteString
|
||||
| Done !B.ByteString
|
||||
|
|
@ -168,11 +168,13 @@ processedPathInfo r =
|
|||
where pinfo = parsePathInfo r
|
||||
|
||||
class HasServer layout where
|
||||
type ServerT layout (m :: * -> *) :: *
|
||||
route :: Proxy layout -> Server layout -> RoutingApplication
|
||||
type ServerT' layout (m :: * -> *) :: *
|
||||
|
||||
type Server layout = ServerT layout (EitherT (Int, String) IO)
|
||||
route :: Proxy layout -> Server' layout -> RoutingApplication
|
||||
|
||||
type Server layout = Server' (Canonicalize layout)
|
||||
type Server' layout = ServerT' layout (EitherT (Int, String) IO)
|
||||
type ServerT layout m = ServerT' (Canonicalize layout) m
|
||||
|
||||
-- * Instances
|
||||
|
||||
|
|
@ -188,9 +190,11 @@ type Server layout = ServerT layout (EitherT (Int, String) IO)
|
|||
-- > where listAllBooks = ...
|
||||
-- > 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 ->
|
||||
route pa a request $ \mResponse ->
|
||||
if isMismatch mResponse
|
||||
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
|
||||
else respond mResponse
|
||||
|
|
@ -221,8 +225,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)
|
||||
|
|
@ -248,7 +252,8 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
|
|||
-- painlessly error out if the conditions for a successful deletion
|
||||
-- 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
|
||||
|
|
@ -277,7 +282,9 @@ instance HasServer Delete where
|
|||
-- list.
|
||||
instance ( 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -296,7 +303,7 @@ instance ( AllCTRender ctypes a
|
|||
|
||||
-- '()' ==> 204 No Content
|
||||
instance 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -310,7 +317,7 @@ instance HasServer (Get ctypes ()) where
|
|||
|
||||
-- Add response headers
|
||||
instance ( 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -351,8 +358,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where
|
|||
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)
|
||||
|
|
@ -375,7 +382,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
|||
-- list.
|
||||
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
|
||||
|
|
@ -394,7 +402,7 @@ instance ( AllCTRender ctypes a
|
|||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -408,7 +416,7 @@ instance HasServer (Post ctypes ()) where
|
|||
|
||||
-- Add response headers
|
||||
instance ( 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -441,7 +449,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
|
|||
-- list.
|
||||
instance ( 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
|
||||
|
|
@ -460,7 +469,7 @@ instance ( AllCTRender ctypes a
|
|||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -474,7 +483,7 @@ instance HasServer (Put ctypes ()) where
|
|||
|
||||
-- Add response headers
|
||||
instance ( 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -505,7 +514,7 @@ instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where
|
|||
-- yielding status code 200 along the way.
|
||||
instance ( 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
|
||||
|
|
@ -524,7 +533,7 @@ instance ( AllCTRender ctypes a
|
|||
| otherwise = respond $ failWith NotFound
|
||||
|
||||
instance 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -538,7 +547,7 @@ instance HasServer (Patch ctypes ()) where
|
|||
|
||||
-- Add response headers
|
||||
instance ( 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
|
||||
e <- runEitherT action
|
||||
|
|
@ -580,8 +589,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) wher
|
|||
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
|
||||
|
|
@ -618,8 +627,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
|
||||
|
|
@ -651,8 +660,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
|
||||
|
|
@ -694,8 +703,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 : _)
|
||||
|
|
@ -732,8 +741,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 : _)
|
||||
|
|
@ -766,8 +775,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 : _)
|
||||
|
|
@ -794,7 +803,9 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
-- > server :: Server MyApi
|
||||
-- > 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)
|
||||
|
||||
|
|
@ -821,8 +832,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
|
||||
|
|
@ -841,7 +852,9 @@ instance ( AllCTUnrender list a, HasServer sublayout
|
|||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
-- 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)
|
||||
| first == cs (symbolVal proxyPath)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ module Servant.Utils.StaticFiles (
|
|||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
|
||||
import Servant.API.Raw (Raw)
|
||||
import Servant.Server.Internal (Server)
|
||||
import Servant.Server (Server)
|
||||
|
||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||
--
|
||||
|
|
|
|||
Loading…
Reference in a new issue