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

Merge commit '8ecc3f07064a3a627b8e49fb182789c82cd9c5d7' into jkarni/config

Browse source
This commit is contained in:
aaron levin 2016-01-16 17:46:23 +01:00
commit 2e7778d1d6
20 changed files with 409 additions and 145 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:

7
CONTRIBUTING.md
View file

@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it!
We are currently moving to a more aggresive release policy, so that you can get
what you contribute from Hackage fairly soon. However, note that prior to major
releases it may take some time in between releases.
## Reporting security issues
Please email haskell-servant-maintainers AT googlegroups DOT com. This group is
private, and accessible only to known maintainers. We will then discuss how to
proceed. Please do not make the issue public before we inform you that we have
a patch ready.

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}

9
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -735,6 +735,15 @@ instance OVERLAPPING_
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where

6
servant-docs/test/Servant/DocsSpec.hs
View file

@ -63,6 +63,7 @@ spec = describe "Servant.Docs" $ do
, ("zwei, kaks, kaks",(TT2,UT2,UT2))
]
where
tests md = do
it "mentions supported content-types" $ do
@ -76,11 +77,15 @@ spec = describe "Servant.Docs" $ do
md `shouldContain` "POST"
md `shouldContain` "GET"
it "mentions headers" $ do
md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
it "contains response samples" $
md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
it "contains request body samples" $
md `shouldContain` "17"
-- * APIs
data Datatype1 = Datatype1 { dt1field1 :: String
@ -103,6 +108,7 @@ instance MimeRender PlainText Int where
type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
:<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
:<|> Header "X-Test" Int :> Put '[JSON] Int
data TT = TT1 | TT2 deriving (Show, Eq)
data UT = UT1 | UT2 deriving (Show, Eq)

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)

3
servant-mock/servant-mock.cabal
View file

@ -18,8 +18,7 @@ cabal-version: >=1.10
flag example
description: Build the example too
manual: True
default: False
default: True
library
exposed-modules:

1
servant-mock/src/Servant/Mock.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

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

@ -99,11 +99,13 @@ test-suite spec
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.Server.Internal.EnterSpec
Servant.Server.Internal.ConfigSpec
Servant.ServerSpec
Servant.Utils.StaticFilesSpec
Servant.Server.ErrorSpec
Servant.Server.Internal.ConfigSpec
Servant.Server.Internal.EnterSpec
Servant.ServerSpec
Servant.Server.UsingConfigSpec
Servant.Server.UsingConfigSpec.TestCombinators
Servant.Utils.StaticFilesSpec
build-depends:
base == 4.*
, aeson

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

@ -1,3 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
@ -35,11 +36,6 @@ module Servant.Server
, generalizeNat
, tweakResponse
-- * Config
, ConfigEntry(..)
, Config(..)
, (.:.)
-- * General Authentication
, AuthHandler(unAuthHandler)
, AuthReturnType
@ -49,6 +45,10 @@ module Servant.Server
, BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
, BasicAuthResult(..)
-- * Config
, Config(..)
, NamedConfig(..)
-- * Default error type
, ServantErr(..)
-- ** 3XX
@ -77,7 +77,7 @@ module Servant.Server
, err415
, err416
, err417
-- * 5XX
-- ** 5XX
, err500
, err501
, err502
@ -110,18 +110,18 @@ import Servant.Server.Internal.Enter
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > cfg :: Config '[]
-- > cfg = EmptyConfig
-- > config :: Config '[]
-- > config = EmptyConfig
-- >
-- > app :: Application
-- > app = serve myApi cfg server
-- > app = serve myApi config server
-- >
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasCfg layout a, HasServer layout)
serve :: (HasConfig layout a, HasServer layout)
=> Proxy layout -> Config a -> Server layout -> Application
serve p cfg server = toApplication (runRouter (route p cfg d))
serve p config server = toApplication (runRouter (route p config d))
where
d = Delayed r r r r (\ _ _ _ -> Route server)
r = return (Route ())

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -53,7 +54,8 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Ba
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault)
Raw, RemoteHost, ReqBody, Vault,
WithNamedConfig)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
AllCTUnrender (..),
@ -71,9 +73,9 @@ import Servant.Server.Internal.ServantErr
class HasServer layout where
type ServerT layout (m :: * -> *) :: *
type HasCfg layout (c :: [*]) :: Constraint
type HasConfig layout (c :: [*]) :: Constraint
route :: HasCfg layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -93,10 +95,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 HasCfg (a :<|> b) c = (HasCfg a c, HasCfg b c)
type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c)
route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server))
(route pb cfg ((\ (_ :<|> 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
@ -125,12 +127,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
type HasCfg (Capture capture a :> sublayout) c = (HasCfg sublayout c)
type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c)
route Proxy cfg d =
route Proxy config d =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
cfg
config
(addCapture d $ case captured captureProxy first of
Nothing -> return $ Fail err404
Just v -> return $ Route v
@ -202,7 +204,7 @@ instance OVERLAPPABLE_
) => HasServer (Verb method status ctypes a) where
type ServerT (Verb method status ctypes a) m = m a
type HasCfg (Verb method status ctypes a) c = ()
type HasConfig (Verb method status ctypes a) c = ()
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
@ -214,7 +216,7 @@ 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 HasCfg (Verb method status ctypes (Headers h a)) c = ()
type HasConfig (Verb method status ctypes (Headers h a)) c = ()
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
@ -245,11 +247,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasCfg (Header sym a :> sublayout) c = HasCfg sublayout c
type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) cfg (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,
@ -278,9 +280,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasCfg (QueryParam sym a :> sublayout) c = HasCfg sublayout c
type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
route Proxy config subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
@ -288,7 +290,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) cfg (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,
@ -315,16 +317,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
type HasCfg (QueryParams sym a :> sublayout) c = HasCfg sublayout c
type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c
route Proxy cfg 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) cfg (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
@ -347,15 +349,15 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
type HasCfg (QueryFlag sym :> sublayout) c = HasCfg sublayout c
type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c
route Proxy cfg 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) cfg (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
@ -371,7 +373,7 @@ instance (KnownSymbol sym, HasServer sublayout)
instance HasServer Raw where
type ServerT Raw m = Application
type HasCfg Raw c = ()
type HasConfig Raw c = ()
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
@ -406,10 +408,10 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
type HasCfg (ReqBody list a :> sublayout) c = HasCfg sublayout c
type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) cfg (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
@ -430,67 +432,67 @@ instance ( AllCTUnrender list a, HasServer sublayout
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m
type HasCfg (path :> sublayout) c = HasCfg sublayout c
type HasConfig (path :> sublayout) c = HasConfig sublayout c
route Proxy cfg subserver = StaticRouter $
route Proxy config subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) cfg 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 HasCfg (RemoteHost :> api) c = HasCfg api c
type HasConfig (RemoteHost :> api) c = HasConfig api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (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 HasCfg (IsSecure :> api) c = HasCfg api c
type HasConfig (IsSecure :> api) c = HasConfig api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (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 HasCfg (Vault :> api) c = HasCfg api c
type HasConfig (Vault :> api) c = HasConfig api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (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 HasCfg (HttpVersion :> api) c = HasCfg api c
type HasConfig (HttpVersion :> api) c = HasConfig api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)
route Proxy config subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
-- | Basic Authentication
instance (KnownSymbol realm, HasServer api)
=> HasServer (BasicAuth tag realm usr :> api) where
type ServerT (BasicAuth tag realm usr :> api) m = usr -> ServerT api m
type HasCfg (BasicAuth tag realm usr :> api) c
= (HasConfigEntry c tag (BasicAuthCheck usr), HasCfg api c)
type HasConfig (BasicAuth tag realm usr :> api) c
= (HasConfigEntry c (BasicAuthCheck usr), HasConfig api c)
route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request)
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
baCfg = getConfigEntry (Proxy :: Proxy tag) cfg
authCheck req = runBasicAuth req realm baCfg
basicAuthConfig = getConfigEntry config
authCheck req = runBasicAuth req realm basicAuthConfig
-- | General Authentication
instance HasServer api => HasServer (AuthProtect tag :> api) where
type ServerT (AuthProtect tag :> api) m = AuthReturnType (AuthProtect tag) -> ServerT api m
type HasCfg (AuthProtect tag :> api) c
= (HasConfigEntry c tag (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasCfg api c)
type HasConfig (AuthProtect tag :> api) c
= (HasConfigEntry c (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasConfig api c)
route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request)
route Proxy config subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
where
authHandler = unAuthHandler (getConfigEntry (Proxy :: Proxy tag) cfg)
authHandler = unAuthHandler (getConfigEntry config)
authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
pathIsEmpty :: Request -> Bool
@ -501,3 +503,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

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

@ -1,62 +1,57 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Server.Internal.Config where
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
-- | A single entry in the configuration. The first parameter is phantom, and
-- is used to lookup a @ConfigEntry@ in a @Config@.
newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a }
deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable
, Num, Ord, Real, Functor, Foldable, Traversable, NFData)
import Data.Proxy
import GHC.TypeLits
-- | The entire configuration.
data Config a where
EmptyConfig :: Config '[]
ConsConfig :: x -> Config xs -> Config (x ': xs)
(:.) :: x -> Config xs -> Config (x ': xs)
infixr 5 :.
instance Show (Config '[]) where
show EmptyConfig = "EmptyConfig"
instance (Show a, Show (Config as)) => Show (Config (ConfigEntry tag a ': as)) where
showsPrec outerPrecedence (ConsConfig (ConfigEntry a) as) =
instance (Show a, Show (Config as)) => Show (Config (a ': as)) where
showsPrec outerPrecedence (a :. as) =
showParen (outerPrecedence > 5) $
shows a . showString " .:. " . shows as
shows a . showString " :. " . shows as
instance Eq (Config '[]) where
_ == _ = True
instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
(.:.) :: x -> Config xs -> Config (ConfigEntry tag x ': xs)
e .:. cfg = ConsConfig (ConfigEntry e) cfg
infixr 5 .:.
class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where
getConfigEntry :: proxy a -> Config cfg -> val
class HasConfigEntry (config :: [*]) (val :: *) where
getConfigEntry :: Config config -> val
instance OVERLAPPABLE_
HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where
getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs
HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
getConfigEntry (_ :. xs) = getConfigEntry xs
instance OVERLAPPABLE_
HasConfigEntry (ConfigEntry tag val ': xs) tag val where
getConfigEntry _ (ConsConfig x _) = unConfigEntry x
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

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

@ -11,42 +11,51 @@ import Servant.Server.Internal.Config
spec :: Spec
spec = do
getConfigEntrySpec
getConfigEntrySpec :: Spec
getConfigEntrySpec = describe "getConfigEntry" $ do
let cfg1 = 0 .:. EmptyConfig :: Config '[ConfigEntry "a" Int]
cfg2 = 1 .:. cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int]
describe "getConfigEntry" $ do
it "gets the config if a matching one exists" $ do
getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0
let config = 'a' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
it "gets the first matching config" $ do
let config = 'a' :. 'b' :. EmptyConfig
getConfigEntry config `shouldBe` 'a'
getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1
it "allows to distinguish between different config entries with the same type by tag" $ do
let cfg = 'a' .:. 'b' .:. EmptyConfig :: Config '[ConfigEntry 1 Char, ConfigEntry 2 Char]
getConfigEntry (Proxy :: Proxy 1) cfg `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 cfg = 1 .:. 2 .:. EmptyConfig
let config = 'a' :. True :. EmptyConfig
it "has a Show instance" $ do
show cfg `shouldBe` "1 .:. 2 .:. EmptyConfig"
show config `shouldBe` "'a' :. True :. EmptyConfig"
it "bracketing works" $ do
show (Just cfg) `shouldBe` "Just (1 .:. 2 .:. EmptyConfig)"
context "bracketing" $ do
it "works" $ do
show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)"
it "bracketing works with operators" $ do
let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)
show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)"
it "works with operators" $ do
let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)
show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)"
it "does not typecheck if key does not exist" $ do
let x = getConfigEntry (Proxy :: Proxy "b") cfg1 :: Int
shouldNotTypecheck x
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 "does not typecheck if key maps to a different type" $ do
let x = getConfigEntry (Proxy :: Proxy "a") cfg1 :: String
shouldNotTypecheck x
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)

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

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

@ -48,10 +48,10 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Bas
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader)
import Servant.Server ((.:.), AuthHandler, AuthReturnType,
import Servant.Server (AuthHandler, AuthReturnType,
BasicAuthCheck (BasicAuthCheck),
BasicAuthResult (Authorized, Unauthorized),
Config (EmptyConfig), ConfigEntry, ServantErr (..),
Config ((:.), EmptyConfig), ServantErr (..),
mkAuthHandler, Server, err401, err404, serve)
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
@ -226,7 +226,7 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
it "allows to retrieve simple GET parameters" $
it "allows retrieving simple GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{
@ -238,7 +238,7 @@ queryParamSpec = do
name = "bob"
}
it "allows to retrieve lists in GET parameters" $
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{
@ -252,7 +252,7 @@ queryParamSpec = do
}
it "allows to retrieve value-less GET parameters" $
it "allows retrieving value-less GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{
@ -537,8 +537,8 @@ authServer = const (return jerry) :<|> const (return tweety)
type instance AuthReturnType (AuthProtect "auth") = ()
authConfig :: Config '[ ConfigEntry "basic" (BasicAuthCheck ())
, ConfigEntry "auth" (AuthHandler Request ())
authConfig :: Config '[ BasicAuthCheck ()
, AuthHandler Request ()
]
authConfig =
let basicHandler = BasicAuthCheck $ (\usr pass ->
@ -551,7 +551,7 @@ authConfig =
then return ()
else throwE err401
)
in basicHandler .:. mkAuthHandler authHandler .:. EmptyConfig
in basicHandler :. mkAuthHandler authHandler :. EmptyConfig
authSpec :: Spec
authSpec = do

1
servant/.ghci Normal file
View file

@ -0,0 +1 @@
:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h

1
servant/servant.cabal
View file

@ -41,6 +41,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,
@ -92,6 +94,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