diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 0bec3370..7329fecc 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | This module lets you implement 'Server's for defined APIs. You'll @@ -12,11 +13,12 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) + , Server ) where import Data.Proxy (Proxy) import Network.Wai (Application) - +import Servant.API (Canonicalize) import Servant.Server.Internal @@ -42,5 +44,7 @@ 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) + +type Server layout = Server' (Canonicalize layout) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 159560fa..a8e97687 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -160,10 +160,11 @@ processedPathInfo r = where pinfo = parsePathInfo r class HasServer layout where - type Server layout :: * - route :: Proxy layout -> Server layout -> RoutingApplication - + type Server' layout :: * + route :: Proxy layout -> Server' layout -> RoutingApplication +canonicalize :: Canonicalize layout ~ t => Proxy layout -> Proxy t +canonicalize Proxy = Proxy -- * Instances @@ -179,7 +180,7 @@ class HasServer layout where -- > where listAllBooks = ... -- > postBook book = ... instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type Server (a :<|> b) = Server a :<|> Server b + type Server' (a :<|> b) = Server' a :<|> Server' b route Proxy (a :<|> b) request respond = route pa a request $ \ mResponse -> if isMismatch mResponse @@ -212,8 +213,8 @@ captured _ = fromText instance (KnownSymbol capture, FromText a, HasServer sublayout) => HasServer (Capture capture a :> sublayout) where - type Server (Capture capture a :> sublayout) = - a -> Server sublayout + type Server' (Capture capture a :> sublayout) = + a -> Server' sublayout route Proxy subserver request respond = case processedPathInfo request of (first : rest) @@ -239,7 +240,7 @@ 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 Server Delete = EitherT (Int, String) IO () + type Server' Delete = EitherT (Int, String) IO () route Proxy action request respond | pathIsEmpty request && requestMethod request == methodDelete = do @@ -268,7 +269,7 @@ instance HasServer Delete where -- list. instance ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - type Server (Get ctypes a) = EitherT (Int, String) IO a + type Server' (Get ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action @@ -308,8 +309,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (Header sym a :> sublayout) where - type Server (Header sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (Header sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = do let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) @@ -332,7 +333,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- list. instance ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where - type Server (Post ctypes a) = EitherT (Int, String) IO a + type Server' (Post ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -365,7 +366,7 @@ instance ( AllCTRender ctypes a -- list. instance ( AllCTRender ctypes a ) => HasServer (Put ctypes a) where - type Server (Put ctypes a) = EitherT (Int, String) IO a + type Server' (Put ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do @@ -398,7 +399,7 @@ instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a , Typeable a , ToJSON a) => HasServer (Patch ctypes a) where - type Server (Patch ctypes a) = EitherT (Int, String) IO a + type Server' (Patch ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do @@ -442,8 +443,8 @@ instance ( AllCTRender ctypes a instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParam sym a :> sublayout) where - type Server (QueryParam sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (QueryParam sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -480,8 +481,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (QueryParams sym a :> sublayout) where - type Server (QueryParams sym a :> sublayout) = - [a] -> Server sublayout + type Server' (QueryParams sym a :> sublayout) = + [a] -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -513,8 +514,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (QueryFlag sym :> sublayout) where - type Server (QueryFlag sym :> sublayout) = - Bool -> Server sublayout + type Server' (QueryFlag sym :> sublayout) = + Bool -> Server' sublayout route Proxy subserver request respond = do let querytext = parseQueryText $ rawQueryString request @@ -556,8 +557,8 @@ parseMatrixText = parseQueryText instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParam sym a :> sublayout) where - type Server (MatrixParam sym a :> sublayout) = - Maybe a -> Server sublayout + type Server' (MatrixParam sym a :> sublayout) = + Maybe a -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -594,8 +595,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, FromText a, HasServer sublayout) => HasServer (MatrixParams sym a :> sublayout) where - type Server (MatrixParams sym a :> sublayout) = - [a] -> Server sublayout + type Server' (MatrixParams sym a :> sublayout) = + [a] -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -628,8 +629,8 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) instance (KnownSymbol sym, HasServer sublayout) => HasServer (MatrixFlag sym :> sublayout) where - type Server (MatrixFlag sym :> sublayout) = - Bool -> Server sublayout + type Server' (MatrixFlag sym :> sublayout) = + Bool -> Server' sublayout route Proxy subserver request respond = case parsePathInfo request of (first : _) @@ -656,7 +657,7 @@ instance (KnownSymbol sym, HasServer sublayout) -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" instance HasServer Raw where - type Server Raw = Application + type Server' Raw = Application route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) @@ -683,8 +684,8 @@ instance HasServer Raw where instance ( AllCTUnrender list a, HasServer sublayout ) => HasServer (ReqBody list a :> sublayout) where - type Server (ReqBody list a :> sublayout) = - a -> Server sublayout + type Server' (ReqBody list a :> sublayout) = + a -> Server' sublayout route Proxy subserver request respond = do -- See HTTP RFC 2616, section 7.2.1 @@ -703,7 +704,7 @@ 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 Server (path :> sublayout) = Server sublayout + type Server' (path :> sublayout) = Server' sublayout route Proxy subserver request respond = case processedPathInfo request of (first : rest) | first == cs (symbolVal proxyPath) diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs index 9cd5fdcc..07c51173 100644 --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -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. --