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

server: added Config machinery

Browse source
This commit is contained in:
Sönke Hahn 2016-01-14 23:43:48 +01:00
parent e7b80e96fd
commit 8ecc3f0706
31 changed files with 486 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.travis.yml
View file

@ -25,7 +25,7 @@ install:
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
script:
- for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done
- for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done
cache:
directories:

12
servant-client/test/Servant/ClientSpec.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@ -110,7 +111,7 @@ api :: Proxy Api
api = Proxy
server :: Application
server = serve api (
server = serve api EmptyConfig (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
@ -137,7 +138,7 @@ failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi (
failServer = serve failApi EmptyConfig (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@ -227,7 +228,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
context "are correctly handled by the client" $
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
@ -283,8 +284,9 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
, HasConfig api '[], HasClient api
, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi

25
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -8,6 +8,7 @@
import Data.Aeson
import Data.ByteString (ByteString)
import Data.IORef
import Data.Text (Text)
import GHC.Generics
import Network.Wai
@ -18,23 +19,32 @@ import Servant.Server.Internal
-- Pretty much stolen/adapted from
-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
type DBLookup = ByteString -> IO Bool
type DBConnection = IORef [ByteString]
type DBLookup = DBConnection -> ByteString -> IO Bool
initDB :: IO DBConnection
initDB = newIORef ["good password"]
isGoodCookie :: DBLookup
isGoodCookie = return . (== "good password")
isGoodCookie ref password = do
allowed <- readIORef ref
return (password `elem` allowed)
data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m
type HasConfig (AuthProtected :> rest) config =
(HasConfigEntry config DBConnection, HasConfig rest config)
route Proxy subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request
where
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
Just v -> do
authGranted <- isGoodCookie v
let dbConnection = getConfigEntry config
authGranted <- isGoodCookie dbConnection v
if authGranted
then return $ Route ()
else return $ FailFatal err403 { errBody = "Invalid cookie" }
@ -66,7 +76,10 @@ server = return prvdata :<|> return pubdata
pubdata = [PublicData "this is a public piece of data"]
main :: IO ()
main = run 8080 (serve api server)
main = do
dbConnection <- initDB
let config = dbConnection :. EmptyConfig
run 8080 (serve api config server)
{- Sample session:
$ curl http://localhost:8080/

2
servant-examples/socket-io-chat/socket-io-chat.hs
View file

@ -38,7 +38,7 @@ server sHandler = socketIOHandler
app :: WaiMonad () -> Application
app sHandler = serve api $ server sHandler
app sHandler = serve api EmptyConfig $ server sHandler
port :: Int
port = 3001

2
servant-examples/tutorial/T1.hs
View file

@ -42,4 +42,4 @@ server :: Server UserAPI
server = return users
app :: Application
app = serve userAPI server
app = serve userAPI EmptyConfig server

2
servant-examples/tutorial/T10.hs
View file

@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs
plain = ("Content-Type", "text/plain")
app :: Application
app = serve api server
app = serve api EmptyConfig server

2
servant-examples/tutorial/T2.hs
View file

@ -49,4 +49,4 @@ server = return users
:<|> return isaac
app :: Application
app = serve userAPI server
app = serve userAPI EmptyConfig server

2
servant-examples/tutorial/T3.hs
View file

@ -81,4 +81,4 @@ server = position
marketing clientinfo = return (emailForClient clientinfo)
app :: Application
app = serve api server
app = serve api EmptyConfig server

2
servant-examples/tutorial/T4.hs
View file

@ -60,4 +60,4 @@ server :: Server PersonAPI
server = return persons
app :: Application
app = serve personAPI server
app = serve personAPI EmptyConfig server

2
servant-examples/tutorial/T5.hs
View file

@ -34,4 +34,4 @@ server = do
where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
app :: Application
app = serve ioAPI server
app = serve ioAPI EmptyConfig server

2
servant-examples/tutorial/T6.hs
View file

@ -15,4 +15,4 @@ server :: Server API
server = serveDirectory "tutorial"
app :: Application
app = serve api server
app = serve api EmptyConfig server

2
servant-examples/tutorial/T7.hs
View file

@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT
readerToEither = Nat $ \r -> return (runReader r "hi")
app :: Application
app = serve readerAPI readerServer
app = serve readerAPI EmptyConfig readerServer

2
servant-examples/tutorial/T9.hs
View file

@ -102,4 +102,4 @@ writeJSFiles = do
TIO.writeFile "tutorial/t9/jq.js" jq
app :: Application
app = serve api' server'
app = serve api' EmptyConfig server'

4
servant-examples/wai-middleware/wai-middleware.hs
View file

@ -41,11 +41,11 @@ server = return products
-- logStdout :: Middleware
-- i.e, logStdout :: Application -> Application
-- serve :: Proxy api -> Server api -> Application
-- serve :: Proxy api -> Config a -> Server api -> Application
-- so applying a middleware is really as simple as
-- applying a function to the result of 'serve'
app :: Application
app = logStdout (serve simpleAPI server)
app = logStdout (serve simpleAPI EmptyConfig server)
main :: IO ()
main = run 8080 app

2
servant-mock/example/main.hs
View file

@ -20,4 +20,4 @@ api :: Proxy API
api = Proxy
main :: IO ()
main = run 8080 (serve api $ mock api)
main = run 8080 (serve api EmptyConfig $ mock api)

2
servant-server/example/greet.hs
View file

@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
-- Turn the server into a WAI app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module.
test :: Application
test = serve testApi server
test = serve testApi EmptyConfig server
-- Run the server.
--

7
servant-server/servant-server.cabal
View file

@ -37,6 +37,7 @@ library
Servant
Servant.Server
Servant.Server.Internal
Servant.Server.Internal.Config
Servant.Server.Internal.Enter
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
@ -94,10 +95,13 @@ test-suite spec
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.Server.ErrorSpec
Servant.Server.Internal.ConfigSpec
Servant.Server.Internal.EnterSpec
Servant.ServerSpec
Servant.Server.UsingConfigSpec
Servant.Server.UsingConfigSpec.TestCombinators
Servant.Utils.StaticFilesSpec
Servant.Server.ErrorSpec
build-depends:
base == 4.*
, aeson
@ -115,6 +119,7 @@ test-suite spec
, servant
, servant-server
, string-conversions
, should-not-typecheck == 2.*
, temporary
, text
, transformers

15
servant-server/src/Servant/Server.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
@ -35,6 +36,10 @@ module Servant.Server
, generalizeNat
, tweakResponse
-- * Config
, Config(..)
, NamedConfig(..)
-- * Default error type
, ServantErr(..)
-- ** 3XX
@ -96,14 +101,18 @@ import Servant.Server.Internal.Enter
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > config :: Config '[]
-- > config = EmptyConfig
-- >
-- > app :: Application
-- > app = serve myApi server
-- > app = serve myApi config server
-- >
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (runRouter (route p d))
serve :: (HasConfig layout a, HasServer layout)
=> Proxy layout -> Config a -> Server layout -> Application
serve p config server = toApplication (runRouter (route p config d))
where
d = Delayed r r r (\ _ _ -> Route server)
r = return (Route ())

95
servant-server/src/Servant/Server/Internal.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -13,6 +14,7 @@
module Servant.Server.Internal
( module Servant.Server.Internal
, module Servant.Server.Internal.Config
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServantErr
@ -30,6 +32,7 @@ import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import Data.Typeable
import GHC.Exts (Constraint)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
@ -49,7 +52,8 @@ import Servant.API ((:<|>) (..), (:>), Capture,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault)
Raw, RemoteHost, ReqBody, Vault,
WithNamedConfig)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
@ -58,6 +62,7 @@ import Servant.API.ContentTypes (AcceptHeader (..),
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
import Servant.Server.Internal.Config
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
@ -65,8 +70,9 @@ import Servant.Server.Internal.ServantErr
class HasServer layout where
type ServerT layout (m :: * -> *) :: *
type HasConfig layout (c :: [*]) :: Constraint
route :: Proxy layout -> Delayed (Server layout) -> Router
route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -86,9 +92,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)
route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
(route pb ((\ (_ :<|> b) -> b) <$> server))
route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server))
(route pb config ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
@ -117,10 +124,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
route Proxy d =
route Proxy config d =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
config
(addCapture d $ case captured captureProxy first of
Nothing -> return $ Fail err404
Just v -> return $ Route v
@ -192,8 +201,9 @@ instance OVERLAPPABLE_
) => HasServer (Verb method status ctypes a) where
type ServerT (Verb method status ctypes a) m = m a
type HasConfig (Verb method status ctypes a) c = ()
route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
@ -203,8 +213,9 @@ instance OVERLAPPING_
) => HasServer (Verb method status ctypes (Headers h a)) where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
type HasConfig (Verb method status ctypes (Headers h a)) c = ()
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
@ -233,10 +244,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
route Proxy subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
@ -265,8 +277,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
route Proxy subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
@ -274,7 +287,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -301,15 +314,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
route Proxy subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
-- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values
parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters
in route (Proxy :: Proxy sublayout) (passToServer subserver values)
in route (Proxy :: Proxy sublayout) config (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
@ -332,14 +346,15 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
route Proxy subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of
Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
in route (Proxy :: Proxy sublayout) config (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
@ -355,8 +370,9 @@ instance (KnownSymbol sym, HasServer sublayout)
instance HasServer Raw where
type ServerT Raw m = Application
type HasConfig Raw c = ()
route Proxy rawApplication = LeafRouter $ \ request respond -> do
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
case r of
Route app -> app request (respond . Route)
@ -389,9 +405,10 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
route Proxy subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request))
where
bodyCheck request = do
-- See HTTP RFC 2616, section 7.2.1
@ -412,37 +429,42 @@ instance ( AllCTUnrender list a, HasServer sublayout
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m
type HasConfig (path :> sublayout) c = HasConfig sublayout c
route Proxy subserver = StaticRouter $
route Proxy config subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) subserver)
(route (Proxy :: Proxy sublayout) config subserver)
where proxyPath = Proxy :: Proxy path
instance HasServer api => HasServer (RemoteHost :> api) where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
type HasConfig (RemoteHost :> api) c = HasConfig api c
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req)
instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
type HasConfig (IsSecure :> api) c = HasConfig api c
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ secure req)
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ secure req)
where secure req = if isSecure req then Secure else NotSecure
instance HasServer api => HasServer (Vault :> api) where
type ServerT (Vault :> api) m = Vault -> ServerT api m
type HasConfig (Vault :> api) c = HasConfig api c
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ vault req)
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ vault req)
instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
type HasConfig (HttpVersion :> api) c = HasConfig api c
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
@ -452,3 +474,20 @@ pathIsEmpty = go . pathInfo
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
-- * configs
instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where
type ServerT (WithNamedConfig name subConfig subApi) m =
ServerT subApi m
type HasConfig (WithNamedConfig name subConfig subApi) config =
(HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed =
route subProxy subConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subConfig :: Config subConfig
subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

57
servant-server/src/Servant/Server/Internal/Config.hs Normal file
View file

@ -0,0 +1,57 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
#include "overlapping-compat.h"
module Servant.Server.Internal.Config where
import Data.Proxy
import GHC.TypeLits
-- | The entire configuration.
data Config a where
EmptyConfig :: Config '[]
(:.) :: x -> Config xs -> Config (x ': xs)
infixr 5 :.
instance Show (Config '[]) where
show EmptyConfig = "EmptyConfig"
instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
showsPrec outerPrecedence (a :. as) =
showParen (outerPrecedence > 5) $
shows a . showString " :. " . shows as
instance Eq (Config '[]) where
_ == _ = True
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
class HasConfigEntry (config :: [*]) (val :: *) where
getConfigEntry :: Config config -> val
instance OVERLAPPABLE_
HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
getConfigEntry (_ :. xs) = getConfigEntry xs
instance OVERLAPPING_
HasConfigEntry (val ': xs) val where
getConfigEntry (x :. _) = x
-- * support for named subconfigs
data NamedConfig (name :: Symbol) (subConfig :: [*])
= NamedConfig (Config subConfig)
descendIntoNamedConfig :: forall config name subConfig .
HasConfigEntry config (NamedConfig name subConfig) =>
Proxy (name :: Symbol) -> Config config -> Config subConfig
descendIntoNamedConfig Proxy config =
let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig
in subConfig

8
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402
errorOrderSpec :: Spec
errorOrderSpec = describe "HTTP error order"
$ with (return $ serve errorOrderApi errorOrderServer) $ do
$ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do
let badContentType = (hContentType, "text/plain")
badAccept = (hAccept, "text/plain")
badMethod = methodGet
@ -89,7 +89,7 @@ prioErrorsApi = Proxy
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
let server = return
with (return $ serve prioErrorsApi server) $ do
with (return $ serve prioErrorsApi EmptyConfig server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
@ -154,7 +154,7 @@ errorRetryServer
errorRetrySpec :: Spec
errorRetrySpec = describe "Handler search"
$ with (return $ serve errorRetryApi errorRetryServer) $ do
$ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do
let jsonCT = (hContentType, "application/json")
jsonAccept = (hAccept, "application/json")
@ -194,7 +194,7 @@ errorChoiceServer = return 0
errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors"
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do
$ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do
it "should respond with 404 if no path matches" $ do
request methodGet "" [] "" `shouldRespondWith` 404

61
servant-server/test/Servant/Server/Internal/ConfigSpec.hs Normal file
View file

@ -0,0 +1,61 @@
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Servant.Server.Internal.ConfigSpec (spec) where
import Data.Proxy (Proxy (..))
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
import Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API
import Servant.Server.Internal.Config
spec :: Spec
spec = do
describe "getConfigEntry" $ do
it "gets the config if a matching one exists" $ do
let config = 'a' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
it "gets the first matching config" $ do
let config = 'a' :. 'b' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
it "does not typecheck if type does not exist" $ do
let config = 'a' :. EmptyConfig
x = getConfigEntry config :: Bool
shouldNotTypecheck x
context "Show instance" $ do
let config = 'a' :. True :. EmptyConfig
it "has a Show instance" $ do
show config `shouldBe` "'a' :. True :. EmptyConfig"
context "bracketing" $ do
it "works" $ do
show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)"
it "works with operators" $ do
let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
describe "descendIntoNamedConfig" $ do
let config :: Config [Char, NamedConfig "sub" '[Char]]
config =
'a' :.
(NamedConfig subConfig :: NamedConfig "sub" '[Char])
:. EmptyConfig
subConfig = 'b' :. EmptyConfig
it "allows extracting subconfigs" $ do
descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig
it "allows extracting entries from subconfigs" $ do
getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char])
`shouldBe` 'b'
it "does not typecheck if subConfig has the wrong type" $ do
let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int]
shouldNotTypecheck (show x)
it "does not typecheck if subConfig with that name doesn't exist" $ do
let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char]
shouldNotTypecheck (show x)

4
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'
enterSpec :: Spec
enterSpec = describe "Enter" $ do
with (return (serve readerAPI readerServer)) $ do
with (return (serve readerAPI EmptyConfig readerServer)) $ do
it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
with (return (serve combinedAPI combinedReaderServer)) $ do
with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
it "allows combnation of enters" $ do
get "bool" `shouldRespondWith` "true"

125
servant-server/test/Servant/Server/UsingConfigSpec.hs Normal file
View file

@ -0,0 +1,125 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.UsingConfigSpec where
import Control.Monad.Trans.Except
import Network.Wai
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai
import Servant
import Servant.Server.UsingConfigSpec.TestCombinators
spec :: Spec
spec = do
spec1
spec2
spec3
spec4
-- * API
type OneEntryAPI =
ExtractFromConfig :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String
testServer s = return s
oneEntryApp :: Application
oneEntryApp =
serve (Proxy :: Proxy OneEntryAPI) config testServer
where
config :: Config '[String]
config = "configEntry" :. EmptyConfig
type OneEntryTwiceAPI =
"foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
"bar" :> ExtractFromConfig :> Get '[JSON] String
oneEntryTwiceApp :: Application
oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
testServer :<|>
testServer
where
config :: Config '[String]
config = "configEntryTwice" :. EmptyConfig
-- * tests
spec1 :: Spec
spec1 = do
describe "accessing config entries from custom combinators" $ do
with (return oneEntryApp) $ do
it "allows retrieving a ConfigEntry" $ do
get "/" `shouldRespondWith` "\"configEntry\""
with (return oneEntryTwiceApp) $ do
it "allows retrieving the same ConfigEntry twice" $ do
get "/foo" `shouldRespondWith` "\"configEntryTwice\""
get "/bar" `shouldRespondWith` "\"configEntryTwice\""
type InjectAPI =
InjectIntoConfig :> "untagged" :> ExtractFromConfig :>
Get '[JSON] String :<|>
InjectIntoConfig :> "tagged" :> ExtractFromConfig :>
Get '[JSON] String
injectApp :: Application
injectApp = serve (Proxy :: Proxy InjectAPI) config $
(\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where
config = EmptyConfig
spec2 :: Spec
spec2 = do
with (return injectApp) $ do
describe "inserting config entries with custom combinators" $ do
it "allows to inject config entries" $ do
get "/untagged" `shouldRespondWith` "\"injected\""
it "allows to inject tagged config entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\""
type WithBirdfaceAPI =
"foo" :> ExtractFromConfig :> Get '[JSON] String :<|>
NamedConfigWithBirdface "sub" '[String] :>
"bar" :> ExtractFromConfig :> Get '[JSON] String
withBirdfaceApp :: Application
withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $
testServer :<|>
testServer
where
config :: Config '[String, (NamedConfig "sub" '[String])]
config =
"firstEntry" :.
(NamedConfig ("secondEntry" :. EmptyConfig)) :.
EmptyConfig
spec3 :: Spec
spec3 = do
with (return withBirdfaceApp) $ do
it "allows retrieving different ConfigEntries for the same combinator" $ do
get "/foo" `shouldRespondWith` "\"firstEntry\""
get "/bar" `shouldRespondWith` "\"secondEntry\""
type NamedConfigAPI =
WithNamedConfig "sub" '[String] (
ExtractFromConfig :> Get '[JSON] String)
namedConfigApp :: Application
namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return
where
config :: Config '[NamedConfig "sub" '[String]]
config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig
spec4 :: Spec
spec4 = do
with (return namedConfigApp) $ do
describe "WithNamedConfig" $ do
it "allows descending into a subconfig for a given api" $ do
get "/" `shouldRespondWith` "\"descend\""

78
servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs Normal file
View file

@ -0,0 +1,78 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | These are custom combinators for Servant.Server.UsingConfigSpec.
--
-- (For writing your own combinators you need to import Internal modules, for
-- just *using* combinators that require a Config, you don't. This module is
-- separate from Servant.Server.UsingConfigSpec to test that the module imports
-- work out this way.)
module Servant.Server.UsingConfigSpec.TestCombinators where
import GHC.TypeLits
import Servant
import Servant.Server.Internal.Config
import Servant.Server.Internal.RoutingApplication
data ExtractFromConfig
instance (HasServer subApi) =>
HasServer (ExtractFromConfig :> subApi) where
type ServerT (ExtractFromConfig :> subApi) m =
String -> ServerT subApi m
type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) =
(HasConfigEntry c String, HasConfig subApi c)
route Proxy config delayed =
route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
where
subProxy :: Proxy subApi
subProxy = Proxy
inject config f = f (getConfigEntry config)
data InjectIntoConfig
instance (HasServer subApi) =>
HasServer (InjectIntoConfig :> subApi) where
type ServerT (InjectIntoConfig :> subApi) m =
ServerT subApi m
type HasConfig (InjectIntoConfig :> subApi) c =
(HasConfig subApi (String ': c))
route Proxy config delayed =
route subProxy newConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
newConfig = ("injected" :: String) :. config
data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*])
instance (HasServer subApi) =>
HasServer (NamedConfigWithBirdface name subConfig :> subApi) where
type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m =
ServerT subApi m
type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config =
(HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig)
route Proxy config delayed =
route subProxy subConfig delayed
where
subProxy :: Proxy subApi
subProxy = Proxy
subConfig :: Config subConfig
subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config

35
servant-server/test/Servant/ServerSpec.hs
View file

@ -47,7 +47,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Raw, RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader)
import Servant.Server (ServantErr (..), Server, err404,
serve)
serve, Config(EmptyConfig))
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
@ -101,7 +101,7 @@ verbSpec = describe "Servant.API.Verb" $ do
wrongMethod m = if m == methodPatch then methodPost else methodPatch
test desc api method (status :: Int) = context desc $
with (return $ serve api server) $ do
with (return $ serve api EmptyConfig server) $ do
-- HEAD and 214/215 need not return bodies
unless (status `elem` [214, 215] || method == methodHead) $
@ -176,7 +176,7 @@ captureServer legs = case legs of
captureSpec :: Spec
captureSpec = do
describe "Servant.API.Capture" $ do
with (return (serve captureApi captureServer)) $ do
with (return (serve captureApi EmptyConfig captureServer)) $ do
it "can capture parts of the 'pathInfo'" $ do
response <- get "/2"
@ -187,6 +187,7 @@ captureSpec = do
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
EmptyConfig
(\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "strips the captured path snippet from pathInfo" $ do
@ -219,8 +220,8 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
it "allows to retrieve simple GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
it "allows retrieving simple GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params1,
@ -231,8 +232,8 @@ queryParamSpec = do
name = "bob"
}
it "allows to retrieve lists in GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
it "allows retrieving lists in GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params2 = "?names[]=bob&names[]=john"
response2 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params2,
@ -245,8 +246,8 @@ queryParamSpec = do
}
it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
it "allows retrieving value-less GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3,
@ -298,7 +299,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
mkReq method x = Test.Hspec.Wai.request method x
[(hContentType, "application/json;charset=utf-8")]
with (return $ serve reqBodyApi server) $ do
with (return $ serve reqBodyApi EmptyConfig server) $ do
it "passes the argument to the handler" $ do
response <- mkReq methodPost "" (encode alice)
@ -331,13 +332,13 @@ headerSpec = describe "Servant.API.Header" $ do
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
with (return (serve headerApi EmptyConfig expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi expectsString)) $ do
with (return (serve headerApi EmptyConfig expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
it "passes the header to the handler (String)" $
@ -361,7 +362,7 @@ rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
@ -369,7 +370,7 @@ rawSpec = do
simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
@ -403,7 +404,7 @@ alternativeServer =
alternativeSpec :: Spec
alternativeSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve alternativeApi alternativeServer) $ do
with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
@ -438,7 +439,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
let methods = [methodGet, methodPost, methodPut, methodPatch]
@ -504,7 +505,7 @@ miscServ = versionHandler
hostHandler = return . show
miscCombinatorSpec :: Spec
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""

4
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it)
import Test.Hspec.Wai (get, shouldRespondWith, with)
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
import Servant.Server (Server, serve)
import Servant.Server (Server, serve, Config(EmptyConfig))
import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory)
@ -29,7 +29,7 @@ api :: Proxy Api
api = Proxy
app :: Application
app = serve api server
app = serve api EmptyConfig server
server :: Server Api
server =

1
servant/servant.cabal
View file

@ -40,6 +40,7 @@ library
Servant.API.Sub
Servant.API.Vault
Servant.API.Verbs
Servant.API.WithNamedConfig
Servant.Utils.Links
build-depends:
base >=4.7 && <5

3
servant/src/Servant/API.hs
View file

@ -23,6 +23,8 @@ module Servant.API (
-- | Is the request made through HTTPS?
module Servant.API.Vault,
-- | Access the location for arbitrary data to be shared by applications and middleware
module Servant.API.WithNamedConfig,
-- | Access config entries in combinators in servant-server
-- * Actual endpoints, distinguished by HTTP method
module Servant.API.Verbs,
@ -88,6 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte
PutNoContent, PutNonAuthoritative,
ReflectMethod (reflectMethod),
Verb, StdMethod(..))
import Servant.API.WithNamedConfig (WithNamedConfig)
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),

8
servant/src/Servant/API/WithNamedConfig.hs Normal file
View file

@ -0,0 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module Servant.API.WithNamedConfig where
import GHC.TypeLits
data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi

1
stack.yaml
View file

@ -16,4 +16,5 @@ packages:
extra-deps:
- engine-io-wai-1.0.2
- control-monad-omega-0.3.1
- should-not-typecheck-2.0.1
resolver: nightly-2015-10-08