From 8ef4d4543b572d32abdd79c0cd7bc6ff9d2af43e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 28 Feb 2016 23:23:32 +0100 Subject: [PATCH] renaming: Config -> Context --- servant-client/src/Servant/Client.hs | 4 +- servant-docs/src/Servant/Docs/Internal.hs | 2 +- .../auth-combinator/auth-combinator.hs | 14 +- .../wai-middleware/wai-middleware.hs | 2 +- .../src/Servant/Foreign/Internal.hs | 4 +- servant-mock/src/Servant/Mock.hs | 66 ++++----- servant-mock/test/Servant/MockSpec.hs | 2 +- servant-server/servant-server.cabal | 8 +- servant-server/src/Servant/Server.hs | 22 +-- servant-server/src/Servant/Server/Internal.hs | 116 ++++++++-------- .../src/Servant/Server/Internal/Config.hs | 99 -------------- .../src/Servant/Server/Internal/Context.hs | 99 ++++++++++++++ .../Servant/Server/Internal/ConfigSpec.hs | 61 --------- .../Servant/Server/Internal/ContextSpec.hs | 61 +++++++++ .../test/Servant/Server/UsingConfigSpec.hs | 125 ------------------ .../Server/UsingConfigSpec/TestCombinators.hs | 73 ---------- .../test/Servant/Server/UsingContextSpec.hs | 125 ++++++++++++++++++ .../UsingContextSpec/TestCombinators.hs | 72 ++++++++++ servant-server/test/Servant/ServerSpec.hs | 12 +- servant/servant.cabal | 2 +- servant/src/Servant/API.hs | 6 +- .../API/Internal/Test/ComprehensiveAPI.hs | 2 +- servant/src/Servant/API/WithNamedConfig.hs | 21 --- servant/src/Servant/API/WithNamedContext.hs | 21 +++ 24 files changed, 509 insertions(+), 510 deletions(-) delete mode 100644 servant-server/src/Servant/Server/Internal/Config.hs create mode 100644 servant-server/src/Servant/Server/Internal/Context.hs delete mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/Internal/ContextSpec.hs delete mode 100644 servant-server/test/Servant/Server/UsingConfigSpec.hs delete mode 100644 servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs delete mode 100644 servant/src/Servant/API/WithNamedConfig.hs create mode 100644 servant/src/Servant/API/WithNamedContext.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 82779651..ed27b3c7 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -418,9 +418,9 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute (Proxy :: Proxy api) req baseurl manager instance HasClient subapi => - HasClient (WithNamedConfig name config subapi) where + HasClient (WithNamedContext name context subapi) where - type Client (WithNamedConfig name config subapi) = Client subapi + type Client (WithNamedContext name context subapi) = Client subapi clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 70f8954c..666cad4c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -794,7 +794,7 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where docsFor Proxy ep = docsFor (Proxy :: Proxy sublayout) ep -instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where +instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where docsFor Proxy = docsFor (Proxy :: Proxy sublayout) -- ToSample instances for simple types diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 635c39b0..94bb8931 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -35,18 +35,18 @@ isGoodCookie ref password = do data AuthProtected -instance (HasConfigEntry config DBConnection, HasServer rest config) - => HasServer (AuthProtected :> rest) config where +instance (HasContextEntry context DBConnection, HasServer rest context) + => HasServer (AuthProtected :> rest) context where type ServerT (AuthProtected :> rest) m = ServerT rest m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request where cookieCheck req = case lookup "Cookie" (requestHeaders req) of Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } Just v -> do - let dbConnection = getConfigEntry config + let dbConnection = getContextEntry context authGranted <- isGoodCookie dbConnection v if authGranted then return $ Route () @@ -81,8 +81,8 @@ server = return prvdata :<|> return pubdata main :: IO () main = do dbConnection <- initDB - let config = dbConnection :. EmptyConfig - run 8080 (serveWithConfig api config server) + let context = dbConnection :. EmptyContext + run 8080 (serveWithContext api context server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index 1d26da1a..a2e95860 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -41,7 +41,7 @@ server = return products -- logStdout :: Middleware -- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Config config -> Server api -> Application +-- serve :: Proxy api -> Context context -> Server api -> Application -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 369d5b76..cb37f6b7 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -310,9 +310,9 @@ instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where foreignFor lang (Proxy :: Proxy sublayout) req instance HasForeign lang sublayout => - HasForeign lang (WithNamedConfig name config sublayout) where + HasForeign lang (WithNamedContext name context sublayout) where - type Foreign (WithNamedConfig name config sublayout) = Foreign sublayout + type Foreign (WithNamedContext name context sublayout) = Foreign sublayout foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 7e2261e5..9e9fed8a 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -74,7 +74,7 @@ import Test.QuickCheck.Gen (Gen, generate) -- than turns them into random-response-generating -- request handlers, hence providing an instance for -- all the combinators of the core /servant/ library. -class HasServer api config => HasMock api config where +class HasServer api context => HasMock api context where -- | Calling this method creates request handlers of -- the right type to implement the API described by -- @api@ that just generate random response values of @@ -104,67 +104,67 @@ class HasServer api config => HasMock api config where -- So under the hood, 'mock' uses the 'IO' bit to generate -- random values of type 'User' and 'Book' every time these -- endpoints are requested. - mock :: Proxy api -> Proxy config -> Server api + mock :: Proxy api -> Proxy context -> Server api -instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where - mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config +instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where + mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context -instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where +instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where mock _ = mock (Proxy :: Proxy rest) -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (RemoteHost :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (RemoteHost :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (IsSecure :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (IsSecure :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (Vault :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (Vault :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (HttpVersion :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (HttpVersion :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) - => HasMock (QueryParam s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParam s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) - => HasMock (QueryParams s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParams s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes a) config where + => HasMock (Verb method status ctypes a) context where mock _ _ = mockArbitrary instance OVERLAPPING_ (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes (Headers headerTypes a)) config where + => HasMock (Verb method status ctypes (Headers headerTypes a)) context where mock _ _ = mockArbitrary -instance HasMock Raw config where +instance HasMock Raw context where mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) -instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) => - HasMock (WithNamedConfig name subConfig rest) config where +instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => + HasMock (WithNamedContext name subContext rest) context where - mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig) + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 320a60ac..7d7b32ac 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -23,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock -- This declaration simply checks that all instances are in place. -_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]]) +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) data Body = Body diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 79f3c934..9a23a4d7 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -37,7 +37,7 @@ library Servant Servant.Server Servant.Server.Internal - Servant.Server.Internal.Config + Servant.Server.Internal.Context Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -96,11 +96,11 @@ test-suite spec main-is: Spec.hs other-modules: Servant.Server.ErrorSpec - Servant.Server.Internal.ConfigSpec + Servant.Server.Internal.ContextSpec Servant.Server.Internal.EnterSpec Servant.ServerSpec - Servant.Server.UsingConfigSpec - Servant.Server.UsingConfigSpec.TestCombinators + Servant.Server.UsingContextSpec + Servant.Server.UsingContextSpec.TestCombinators Servant.Utils.StaticFilesSpec build-depends: base == 4.* diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index fd71efb5..70fae733 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -9,7 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve - , serveWithConfig + , serveWithContext , -- * Construct a wai Application from an API toApplication @@ -38,12 +38,12 @@ module Servant.Server , generalizeNat , tweakResponse - -- * Config - , Config(..) - , HasConfigEntry(getConfigEntry) - -- ** NamedConfig - , NamedConfig(..) - , descendIntoNamedConfig + -- * Context + , Context(..) + , HasContextEntry(getContextEntry) + -- ** NamedContext + , NamedContext(..) + , descendIntoNamedContext -- * Default error type , ServantErr(..) @@ -113,11 +113,11 @@ import Servant.Server.Internal.Enter -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application -serve p = serveWithConfig p EmptyConfig +serve p = serveWithContext p EmptyContext -serveWithConfig :: (HasServer layout config) - => Proxy layout -> Config config -> Server layout -> Application -serveWithConfig p config server = toApplication (runRouter (route p config d)) +serveWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Server layout -> Application +serveWithContext p context server = toApplication (runRouter (route p context d)) where d = Delayed r r r (\ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index daf44640..05450649 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -15,7 +15,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal - , module Servant.Server.Internal.Config + , module Servant.Server.Internal.Context , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -53,7 +53,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault, - WithNamedConfig) + WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -62,16 +62,16 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) -import Servant.Server.Internal.Config +import Servant.Server.Internal.Context import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -class HasServer layout config where +class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router + route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -88,12 +88,12 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... -instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where +instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) - (route pb config ((\ (_ :<|> b) -> b) <$> server)) + route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) + (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -117,16 +117,16 @@ captured _ = parseUrlPieceMaybe -- > server = getBook -- > where getBook :: Text -> ExceptT ServantErr IO Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config) - => HasServer (Capture capture a :> sublayout) config where +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) + => HasServer (Capture capture a :> sublayout) context where type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - route Proxy config d = + route Proxy context d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) - config + context (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -195,7 +195,7 @@ methodRouterHeaders method proxy status action = LeafRouter route' instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) config where + ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a @@ -206,7 +206,7 @@ instance OVERLAPPABLE_ instance OVERLAPPING_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) config where + ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) @@ -234,15 +234,15 @@ instance OVERLAPPING_ -- > server = viewReferer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (Header sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (Header sym a :> sublayout) context where type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -266,13 +266,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (QueryParam sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParam sym a :> sublayout) context where type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -280,7 +280,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) 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) config (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -302,20 +302,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (QueryParams sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParams sym a :> sublayout) context where type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context 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) config (passToServer subserver values) + in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -333,19 +333,19 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > server = getBooks -- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout config) - => HasServer (QueryFlag sym :> sublayout) config where +instance (KnownSymbol sym, HasServer sublayout context) + => HasServer (QueryFlag sym :> sublayout) context where type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context 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) config (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -358,7 +358,7 @@ instance (KnownSymbol sym, HasServer sublayout config) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw config where +instance HasServer Raw context where type ServerT Raw m = Application @@ -390,14 +390,14 @@ instance HasServer Raw config where -- > server = postBook -- > where postBook :: Book -> ExceptT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout config - ) => HasServer (ReqBody list a :> sublayout) config where +instance ( AllCTUnrender list a, HasServer sublayout context + ) => HasServer (ReqBody list a :> sublayout) context where type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -415,40 +415,40 @@ instance ( AllCTUnrender list a, HasServer sublayout config -- | 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 config) => HasServer (path :> sublayout) config where +instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy config subserver = StaticRouter $ + route Proxy context subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) config subserver) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path -instance HasServer api config => HasServer (RemoteHost :> api) config where +instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) -instance HasServer api config => HasServer (IsSecure :> api) config where +instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ secure req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure -instance HasServer api config => HasServer (Vault :> api) config where +instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ vault req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ vault req) -instance HasServer api config => HasServer (HttpVersion :> api) config where +instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo @@ -459,19 +459,19 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP --- * configs +-- * contexts -instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) - => HasServer (WithNamedConfig name subConfig subApi) config where +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) + => HasServer (WithNamedContext name subContext subApi) context where - type ServerT (WithNamedConfig name subConfig subApi) m = + type ServerT (WithNamedContext name subContext subApi) m = ServerT subApi m - route Proxy config delayed = - route subProxy subConfig delayed + route Proxy context delayed = + route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy - subConfig :: Config subConfig - subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs deleted file mode 100644 index c162494b..00000000 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# 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 - --- | When calling 'Servant.Server.serve' you have to supply a configuration --- value of type @'Config' configTypes@. This parameter is used to pass values --- to combinators. (It shouldn't be confused with general configuration --- parameters for your web app, like the port, etc.). If you don't use --- combinators that require any config entries, you can just pass 'EmptyConfig'. --- To create a config with entries, use the operator @(':.')@. The parameter of --- the type 'Config' is a type-level list reflecting the types of the contained --- config entries: --- --- >>> :type True :. () :. EmptyConfig --- True :. () :. EmptyConfig :: Config '[Bool, ()] -data Config configTypes 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 - --- | This class is used to access config entries in 'Config's. 'getConfigEntry' --- returns the first value where the type matches: --- --- >>> getConfigEntry (True :. False :. EmptyConfig) :: Bool --- True --- --- If the 'Config' does not contain an entry of the requested type, you'll get --- an error: --- --- >>> getConfigEntry (True :. False :. EmptyConfig) :: String --- ... --- No instance for (HasConfigEntry '[] [Char]) --- ... -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 - --- | Normally config entries are accessed by their types. In case you need --- to have multiple values of the same type in your 'Config' and need to access --- them, we provide 'NamedConfig'. You can think of it as sub-namespaces for --- 'Config's. -data NamedConfig (name :: Symbol) (subConfig :: [*]) - = NamedConfig (Config subConfig) - --- | 'descendIntoNamedConfig' allows you to access `NamedConfig's. Usually you --- won't have to use it yourself but instead use a combinator like --- 'Servant.API.WithNamedConfig.WithNamedConfig'. --- --- This is how 'descendIntoNamedConfig' works: --- --- >>> :set -XFlexibleContexts --- >>> let subConfig = True :. EmptyConfig --- >>> :type subConfig --- subConfig :: Config '[Bool] --- >>> let parentConfig = False :. (NamedConfig subConfig :: NamedConfig "subConfig" '[Bool]) :. EmptyConfig --- >>> :type parentConfig --- parentConfig :: Config '[Bool, NamedConfig "subConfig" '[Bool]] --- >>> descendIntoNamedConfig (Proxy :: Proxy "subConfig") parentConfig :: Config '[Bool] --- True :. EmptyConfig -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 diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs new file mode 100644 index 00000000..3b116c9d --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -0,0 +1,99 @@ +{-# 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.Context where + +import Data.Proxy +import GHC.TypeLits + +-- | When calling 'Servant.Server.serve' you have to supply a context +-- value of type @'Context' contextTypes@. This parameter is used to pass values +-- to combinators. (It shouldn't be confused with general configuration +-- parameters for your web app, like the port, etc.). If you don't use +-- combinators that require any context entries, you can just use `serve` (or +-- pass 'EmptyContext'). To create a context with entries, use the operator +-- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting +-- the types of the contained context entries: +-- +-- >>> :type True :. () :. EmptyContext +-- True :. () :. EmptyContext :: Context '[Bool, ()] +data Context contextTypes where + EmptyContext :: Context '[] + (:.) :: x -> Context xs -> Context (x ': xs) +infixr 5 :. + +instance Show (Context '[]) where + show EmptyContext = "EmptyContext" +instance (Show a, Show (Context as)) => Show (Context (a ': as)) where + showsPrec outerPrecedence (a :. as) = + showParen (outerPrecedence > 5) $ + shows a . showString " :. " . shows as + +instance Eq (Context '[]) where + _ == _ = True +instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 + +-- | This class is used to access context entries in 'Context's. 'getContextEntry' +-- returns the first value where the type matches: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool +-- True +-- +-- If the 'Context' does not contain an entry of the requested type, you'll get +-- an error: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: String +-- ... +-- No instance for (HasContextEntry '[] [Char]) +-- ... +class HasContextEntry (context :: [*]) (val :: *) where + getContextEntry :: Context context -> val + +instance OVERLAPPABLE_ + HasContextEntry xs val => HasContextEntry (notIt ': xs) val where + getContextEntry (_ :. xs) = getContextEntry xs + +instance OVERLAPPING_ + HasContextEntry (val ': xs) val where + getContextEntry (x :. _) = x + +-- * support for named subcontexts + +-- | Normally context entries are accessed by their types. In case you need +-- to have multiple values of the same type in your 'Context' and need to access +-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for +-- 'Context's. +data NamedContext (name :: Symbol) (subContext :: [*]) + = NamedContext (Context subContext) + +-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you +-- won't have to use it yourself but instead use a combinator like +-- 'Servant.API.WithNamedContext.WithNamedContext'. +-- +-- This is how 'descendIntoNamedContext' works: +-- +-- >>> :set -XFlexibleContexts +-- >>> let subContext = True :. EmptyContext +-- >>> :type subContext +-- subContext :: Context '[Bool] +-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext +-- >>> :type parentContext +-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]] +-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool] +-- True :. EmptyContext +descendIntoNamedContext :: forall context name subContext . + HasContextEntry context (NamedContext name subContext) => + Proxy (name :: Symbol) -> Context context -> Context subContext +descendIntoNamedContext Proxy context = + let NamedContext subContext = getContextEntry context :: NamedContext name subContext + in subContext diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs deleted file mode 100644 index 182d91a8..00000000 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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) diff --git a/servant-server/test/Servant/Server/Internal/ContextSpec.hs b/servant-server/test/Servant/Server/Internal/ContextSpec.hs new file mode 100644 index 00000000..dfac1e2e --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module Servant.Server.Internal.ContextSpec (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.Context + +spec :: Spec +spec = do + describe "getContextEntry" $ do + it "gets the context if a matching one exists" $ do + let cxt = 'a' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "gets the first matching context" $ do + let cxt = 'a' :. 'b' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "does not typecheck if type does not exist" $ do + let cxt = 'a' :. EmptyContext + x = getContextEntry cxt :: Bool + shouldNotTypecheck x + + context "Show instance" $ do + let cxt = 'a' :. True :. EmptyContext + it "has a Show instance" $ do + show cxt `shouldBe` "'a' :. True :. EmptyContext" + + context "bracketing" $ do + it "works" $ do + show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" + + it "works with operators" $ do + let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) + show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" + + describe "descendIntoNamedContext" $ do + let cxt :: Context [Char, NamedContext "sub" '[Char]] + cxt = + 'a' :. + (NamedContext subContext :: NamedContext "sub" '[Char]) + :. EmptyContext + subContext = 'b' :. EmptyContext + it "allows extracting subcontexts" $ do + descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext + + it "allows extracting entries from subcontexts" $ do + getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char]) + `shouldBe` 'b' + + it "does not typecheck if subContext has the wrong type" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int] + shouldNotTypecheck (show x) + + it "does not typecheck if subContext with that name doesn't exist" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char] + shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs deleted file mode 100644 index 64d6f2cf..00000000 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# 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 = - serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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 = serveWithConfig (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\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs deleted file mode 100644 index 1da892e8..00000000 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# 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 (HasConfigEntry config String, HasServer subApi config) => - HasServer (ExtractFromConfig :> subApi) config where - - type ServerT (ExtractFromConfig :> subApi) m = - String -> ServerT subApi m - - 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 (String ': config)) => - HasServer (InjectIntoConfig :> subApi) config where - - type ServerT (InjectIntoConfig :> subApi) m = - ServerT subApi m - - route Proxy config delayed = - route subProxy newConfig delayed - where - subProxy :: Proxy subApi - subProxy = Proxy - - newConfig = ("injected" :: String) :. config - -data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) - -instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) => - HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where - - type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = - ServerT subApi m - - route Proxy config delayed = - route subProxy subConfig delayed - where - subProxy :: Proxy subApi - subProxy = Proxy - - subConfig :: Config subConfig - subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs new file mode 100644 index 00000000..33b04125 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingContextSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingContextSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromContext :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer + where + context :: Context '[String] + context = "contextEntry" :. EmptyContext + +type OneEntryTwiceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + "bar" :> ExtractFromContext :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String] + context = "contextEntryTwice" :. EmptyContext + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing context entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ContextEntry" $ do + get "/" `shouldRespondWith` "\"contextEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ContextEntry twice" $ do + get "/foo" `shouldRespondWith` "\"contextEntryTwice\"" + get "/bar" `shouldRespondWith` "\"contextEntryTwice\"" + +type InjectAPI = + InjectIntoContext :> "untagged" :> ExtractFromContext :> + Get '[JSON] String :<|> + InjectIntoContext :> "tagged" :> ExtractFromContext :> + Get '[JSON] String + +injectApp :: Application +injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + context = EmptyContext + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting context entries with custom combinators" $ do + it "allows to inject context entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged context entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + NamedContextWithBirdface "sub" '[String] :> + "bar" :> ExtractFromContext :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String, (NamedContext "sub" '[String])] + context = + "firstEntry" :. + (NamedContext ("secondEntry" :. EmptyContext)) :. + EmptyContext + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ContextEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedContextAPI = + WithNamedContext "sub" '[String] ( + ExtractFromContext :> Get '[JSON] String) + +namedContextApp :: Application +namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return + where + context :: Context '[NamedContext "sub" '[String]] + context = NamedContext ("descend" :. EmptyContext) :. EmptyContext + +spec4 :: Spec +spec4 = do + with (return namedContextApp) $ do + describe "WithNamedContext" $ do + it "allows descending into a subcontext for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs new file mode 100644 index 00000000..48595c9c --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingContextSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Context, you don't. This module is +-- separate from Servant.Server.UsingContextSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingContextSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.RoutingApplication + +data ExtractFromContext + +instance (HasContextEntry context String, HasServer subApi context) => + HasServer (ExtractFromContext :> subApi) context where + + type ServerT (ExtractFromContext :> subApi) m = + String -> ServerT subApi m + + route Proxy context delayed = + route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject context f = f (getContextEntry context) + +data InjectIntoContext + +instance (HasServer subApi (String ': context)) => + HasServer (InjectIntoContext :> subApi) context where + + type ServerT (InjectIntoContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy newContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newContext = ("injected" :: String) :. context + +data NamedContextWithBirdface (name :: Symbol) (subContext :: [*]) + +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => + HasServer (NamedContextWithBirdface name subContext :> subApi) context where + + type ServerT (NamedContextWithBirdface name subContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy subContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index efda259f..6bf9defc 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, - serve, serveWithConfig, Config(EmptyConfig)) + serve, serveWithContext, Context(EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -61,16 +61,16 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) -import Servant.Server.Internal.Config - (Config(..), NamedConfig(..)) +import Servant.Server.Internal.Context + (Context(..), NamedContext(..)) -- * comprehensive api test -- This declaration simply checks that all instances are in place. -_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig +_ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]] -comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig +comprehensiveApiContext :: Context '[NamedContext "foo" '[]] +comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext -- * Specs diff --git a/servant/servant.cabal b/servant/servant.cabal index 437c9843..1b5e3c27 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -41,7 +41,7 @@ library Servant.API.Sub Servant.API.Vault Servant.API.Verbs - Servant.API.WithNamedConfig + Servant.API.WithNamedContext Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2da0d4cf..fcaf5e91 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,8 +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 + module Servant.API.WithNamedContext, + -- | Access context entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -90,7 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) -import Servant.API.WithNamedConfig (WithNamedConfig) +import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 733968b2..91d01727 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -30,7 +30,7 @@ type ComprehensiveAPI = Vault :> GET :<|> Verb 'POST 204 '[JSON] () :<|> Verb 'POST 204 '[JSON] Int :<|> - WithNamedConfig "foo" '[] GET + WithNamedContext "foo" '[] GET comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs deleted file mode 100644 index 72b59e2f..00000000 --- a/servant/src/Servant/API/WithNamedConfig.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -module Servant.API.WithNamedConfig where - -import GHC.TypeLits - --- | 'WithNamedConfig' names a specific tagged configuration to use for the --- combinators in the API. (See also in @servant-server@, --- @Servant.Server.Config@.) For example: --- --- > type UseNamedConfigAPI = WithNamedConfig "myConfig" '[String] ( --- > ReqBody '[JSON] Int :> Get '[JSON] Int) --- --- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with --- type tag "myConfig" as their configuration. --- --- 'Config's are only relevant for @servant-server@. --- --- For more information, see the tutorial. -data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi diff --git a/servant/src/Servant/API/WithNamedContext.hs b/servant/src/Servant/API/WithNamedContext.hs new file mode 100644 index 00000000..e467ea41 --- /dev/null +++ b/servant/src/Servant/API/WithNamedContext.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedContext where + +import GHC.TypeLits + +-- | 'WithNamedContext' names a specific tagged context to use for the +-- combinators in the API. (See also in @servant-server@, +-- @Servant.Server.Context@.) For example: +-- +-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] ( +-- > ReqBody '[JSON] Int :> Get '[JSON] Int) +-- +-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with +-- type tag "myContext" as their context. +-- +-- 'Context's are only relevant for @servant-server@. +-- +-- For more information, see the tutorial. +data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi