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

Merge pull request #32 from haskell-servant/canonical-types

Browse source 
Canonicalize types
This commit is contained in:
Alp Mestanogullari 2015-04-19 13:23:51 +03:00
commit 01a020d432
4 changed files with 63 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG.md
View file

@ -5,6 +5,7 @@
* Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * 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) * 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) * 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) * Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28)
* Add server support for response headers * Add server support for response headers

8
src/Servant/Server.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module lets you implement 'Server's for defined APIs. You'll -- | This module lets you implement 'Server's for defined APIs. You'll
@ -13,11 +14,12 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, Server , Server
, ServerT
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.API (Canonicalize, canonicalize)
import Servant.Server.Internal import Servant.Server.Internal
@ -43,5 +45,5 @@ import Servant.Server.Internal
-- > -- >
-- > main :: IO () -- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
serve :: HasServer layout => Proxy layout -> Server layout -> Application serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application
serve p server = toApplication (route p server) serve p server = toApplication (route (canonicalize p) server)

99
src/Servant/Server/Internal.hs
View file

@ -32,17 +32,17 @@ import Network.Wai (Application, Request, Response,
requestMethod, responseLBS, requestMethod, responseLBS,
strictRequestBody) strictRequestBody)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, MatrixFlag, Canonicalize, Delete, Get, Header,
MatrixParam, MatrixParams, Patch, MatrixFlag, MatrixParam, MatrixParams,
Post, Put, QueryFlag, QueryParam, Patch, Post, Put, QueryFlag,
QueryParams, Raw, ReqBody) QueryParam, QueryParams, Raw,
ReqBody)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..))
import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders) import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders)
import Servant.Common.Text (FromText, fromText) import Servant.Common.Text (FromText, fromText)
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
| Done !B.ByteString | Done !B.ByteString
@ -168,11 +168,13 @@ processedPathInfo r =
where pinfo = parsePathInfo r where pinfo = parsePathInfo r
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT' layout (m :: * -> *) :: *
route :: Proxy layout -> Server layout -> RoutingApplication
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 -- * Instances
@ -188,9 +190,11 @@ type Server layout = ServerT layout (EitherT (Int, String) IO)
-- > where listAllBooks = ... -- > where listAllBooks = ...
-- > postBook book = ... -- > postBook book = ...
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where 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 Proxy (a :<|> b) request respond =
route pa a request $ \ mResponse -> route pa a request $ \mResponse ->
if isMismatch mResponse if isMismatch mResponse
then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
else respond mResponse else respond mResponse
@ -221,8 +225,8 @@ captured _ = fromText
instance (KnownSymbol capture, FromText a, HasServer sublayout) instance (KnownSymbol capture, FromText a, HasServer sublayout)
=> HasServer (Capture capture a :> sublayout) where => HasServer (Capture capture a :> sublayout) where
type ServerT (Capture capture a :> sublayout) m = type ServerT' (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT' sublayout m
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)
@ -248,7 +252,8 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- painlessly error out if the conditions for a successful deletion -- painlessly error out if the conditions for a successful deletion
-- are not met. -- are not met.
instance HasServer Delete where instance HasServer Delete where
type ServerT Delete m = m ()
type ServerT' Delete m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do | pathIsEmpty request && requestMethod request == methodDelete = do
@ -277,7 +282,9 @@ instance HasServer Delete where
-- list. -- list.
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Get ctypes a) where ) => 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action e <- runEitherT action
@ -296,7 +303,7 @@ instance ( AllCTRender ctypes a
-- '()' ==> 204 No Content -- '()' ==> 204 No Content
instance HasServer (Get ctypes ()) where instance HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m () type ServerT' (Get ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action e <- runEitherT action
@ -310,7 +317,7 @@ instance HasServer (Get ctypes ()) where
-- Add response headers -- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodGet = do | pathIsEmpty request && requestMethod request == methodGet = do
e <- runEitherT action 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) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (Header sym a :> sublayout) where => HasServer (Header sym a :> sublayout) where
type ServerT (Header sym a :> sublayout) m = type ServerT' (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)
@ -375,7 +382,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
-- list. -- list.
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Post ctypes a) where ) => 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -394,7 +402,7 @@ instance ( AllCTRender ctypes a
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
instance HasServer (Post ctypes ()) where instance HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m () type ServerT' (Post ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
@ -408,7 +416,7 @@ instance HasServer (Post ctypes ()) where
-- Add response headers -- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
e <- runEitherT action e <- runEitherT action
@ -441,7 +449,8 @@ instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where
-- list. -- list.
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where ) => 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
@ -460,7 +469,7 @@ instance ( AllCTRender ctypes a
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
instance HasServer (Put ctypes ()) where instance HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m () type ServerT' (Put ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action e <- runEitherT action
@ -474,7 +483,7 @@ instance HasServer (Put ctypes ()) where
-- Add response headers -- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
e <- runEitherT action 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. -- yielding status code 200 along the way.
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Patch ctypes a) where ) => 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
@ -524,7 +533,7 @@ instance ( AllCTRender ctypes a
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
instance HasServer (Patch ctypes ()) where instance HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m () type ServerT' (Patch ctypes ()) m = m ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action e <- runEitherT action
@ -538,7 +547,7 @@ instance HasServer (Patch ctypes ()) where
-- Add response headers -- Add response headers
instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPatch = do | pathIsEmpty request && requestMethod request == methodPatch = do
e <- runEitherT action 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) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParam sym a :> sublayout) where => HasServer (QueryParam sym a :> sublayout) where
type ServerT (QueryParam sym a :> sublayout) m = type ServerT' (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -618,8 +627,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (QueryParams sym a :> sublayout) where => HasServer (QueryParams sym a :> sublayout) where
type ServerT (QueryParams sym a :> sublayout) m = type ServerT' (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -651,8 +660,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (QueryFlag sym :> sublayout) where => HasServer (QueryFlag sym :> sublayout) where
type ServerT (QueryFlag sym :> sublayout) m = type ServerT' (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -694,8 +703,8 @@ parseMatrixText = parseQueryText
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParam sym a :> sublayout) where => HasServer (MatrixParam sym a :> sublayout) where
type ServerT (MatrixParam sym a :> sublayout) m = type ServerT' (MatrixParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -732,8 +741,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout)
=> HasServer (MatrixParams sym a :> sublayout) where => HasServer (MatrixParams sym a :> sublayout) where
type ServerT (MatrixParams sym a :> sublayout) m = type ServerT' (MatrixParams sym a :> sublayout) m =
[a] -> ServerT sublayout m [a] -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -766,8 +775,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
instance (KnownSymbol sym, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout)
=> HasServer (MatrixFlag sym :> sublayout) where => HasServer (MatrixFlag sym :> sublayout) where
type ServerT (MatrixFlag sym :> sublayout) m = type ServerT' (MatrixFlag sym :> sublayout) m =
Bool -> ServerT sublayout m Bool -> ServerT' sublayout m
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -794,7 +803,9 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw where instance HasServer Raw where
type ServerT Raw m = Application
type ServerT' Raw m = Application
route Proxy rawApplication request respond = route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith) rawApplication request (respond . succeedWith)
@ -821,8 +832,8 @@ instance HasServer Raw where
instance ( AllCTUnrender list a, HasServer sublayout instance ( AllCTUnrender list a, HasServer sublayout
) => HasServer (ReqBody list a :> sublayout) where ) => HasServer (ReqBody list a :> sublayout) where
type ServerT (ReqBody list a :> sublayout) m = type ServerT' (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT' sublayout m
route Proxy subserver request respond = do route Proxy subserver request respond = do
-- See HTTP RFC 2616, section 7.2.1 -- 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 -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where 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 route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)
| first == cs (symbolVal proxyPath) | first == cs (symbolVal proxyPath)

2
src/Servant/Utils/StaticFiles.hs
View file

@ -9,7 +9,7 @@ module Servant.Utils.StaticFiles (
import Filesystem.Path.CurrentOS (decodeString) import Filesystem.Path.CurrentOS (decodeString)
import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.Server.Internal (Server) import Servant.Server (Server)
-- | Serve anything under the specified directory as a 'Raw' endpoint. -- | Serve anything under the specified directory as a 'Raw' endpoint.
-- --