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

Canonicalize the API type to make sure that the following 'law' holds: Server (a :> (b :<|> c)) ~ Server (a :> b) :<|> Server (a :> c)

Browse source
This commit is contained in:
Alp Mestanogullari 2015-03-09 15:16:38 +01:00
parent 947815e6d3
commit 9a33fa7812
3 changed files with 38 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
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
@ -12,11 +13,12 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, Server
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.API (Canonicalize)
import Servant.Server.Internal import Servant.Server.Internal
@ -42,5 +44,7 @@ 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)
type Server layout = Server' (Canonicalize layout)

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

@ -160,10 +160,11 @@ processedPathInfo r =
where pinfo = parsePathInfo r where pinfo = parsePathInfo r
class HasServer layout where class HasServer layout where
type Server layout :: * type Server' layout :: *
route :: Proxy layout -> Server layout -> RoutingApplication route :: Proxy layout -> Server' layout -> RoutingApplication
canonicalize :: Canonicalize layout ~ t => Proxy layout -> Proxy t
canonicalize Proxy = Proxy
-- * Instances -- * Instances
@ -179,7 +180,7 @@ class HasServer layout where
-- > 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 Server (a :<|> b) = Server a :<|> Server b type Server' (a :<|> b) = Server' a :<|> Server' b
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
@ -212,8 +213,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 Server (Capture capture a :> sublayout) = type Server' (Capture capture a :> sublayout) =
a -> Server sublayout a -> Server' sublayout
route Proxy subserver request respond = case processedPathInfo request of route Proxy subserver request respond = case processedPathInfo request of
(first : rest) (first : rest)
@ -239,7 +240,7 @@ 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 Server Delete = EitherT (Int, String) IO () type Server' Delete = EitherT (Int, String) IO ()
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do | pathIsEmpty request && requestMethod request == methodDelete = do
@ -268,7 +269,7 @@ 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 Server (Get ctypes a) = EitherT (Int, String) IO a type Server' (Get ctypes a) = EitherT (Int, String) IO 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
@ -308,8 +309,8 @@ instance ( AllCTRender ctypes a
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 Server (Header sym a :> sublayout) = type Server' (Header sym a :> sublayout) =
Maybe a -> Server sublayout Maybe a -> Server' sublayout
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)
@ -332,7 +333,7 @@ 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 Server (Post ctypes a) = EitherT (Int, String) IO a type Server' (Post ctypes a) = EitherT (Int, String) IO a
route Proxy action request respond route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -365,7 +366,7 @@ instance ( AllCTRender ctypes a
-- list. -- list.
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
) => HasServer (Put ctypes a) where ) => 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPut = do | pathIsEmpty request && requestMethod request == methodPut = do
@ -398,7 +399,7 @@ instance ( AllCTRender ctypes a
instance ( AllCTRender ctypes a instance ( AllCTRender ctypes a
, Typeable a , Typeable a
, ToJSON a) => HasServer (Patch ctypes a) where , 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 route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodPost = do | pathIsEmpty request && requestMethod request == methodPost = do
@ -442,8 +443,8 @@ instance ( AllCTRender ctypes a
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 Server (QueryParam sym a :> sublayout) = type Server' (QueryParam sym a :> sublayout) =
Maybe a -> Server sublayout Maybe a -> Server' sublayout
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -480,8 +481,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 Server (QueryParams sym a :> sublayout) = type Server' (QueryParams sym a :> sublayout) =
[a] -> Server sublayout [a] -> Server' sublayout
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -513,8 +514,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 Server (QueryFlag sym :> sublayout) = type Server' (QueryFlag sym :> sublayout) =
Bool -> Server sublayout Bool -> Server' sublayout
route Proxy subserver request respond = do route Proxy subserver request respond = do
let querytext = parseQueryText $ rawQueryString request let querytext = parseQueryText $ rawQueryString request
@ -556,8 +557,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 Server (MatrixParam sym a :> sublayout) = type Server' (MatrixParam sym a :> sublayout) =
Maybe a -> Server sublayout Maybe a -> Server' sublayout
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -594,8 +595,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 Server (MatrixParams sym a :> sublayout) = type Server' (MatrixParams sym a :> sublayout) =
[a] -> Server sublayout [a] -> Server' sublayout
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -628,8 +629,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 Server (MatrixFlag sym :> sublayout) = type Server' (MatrixFlag sym :> sublayout) =
Bool -> Server sublayout Bool -> Server' sublayout
route Proxy subserver request respond = case parsePathInfo request of route Proxy subserver request respond = case parsePathInfo request of
(first : _) (first : _)
@ -656,7 +657,7 @@ 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 Server Raw = Application type Server' Raw = Application
route Proxy rawApplication request respond = route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith) rawApplication request (respond . succeedWith)
@ -683,8 +684,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 Server (ReqBody list a :> sublayout) = type Server' (ReqBody list a :> sublayout) =
a -> Server sublayout a -> Server' sublayout
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
@ -703,7 +704,7 @@ 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 Server (path :> sublayout) = Server sublayout type Server' (path :> sublayout) = Server' sublayout
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.
-- --