From 57fe12ce84e0759c7eed4a25d4a3746729496cdb Mon Sep 17 00:00:00 2001 From: Luke Clifton Date: Tue, 22 Dec 2015 15:48:49 +1100 Subject: [PATCH 1/5] MimeUnrender and MimeRender instances for Cassava This allows the same API type to be used for `serve` and `client`. --- servant-cassava/src/Servant/CSV/Cassava.hs | 25 +++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/servant-cassava/src/Servant/CSV/Cassava.hs b/servant-cassava/src/Servant/CSV/Cassava.hs index 5bd5a374..3c00a662 100644 --- a/servant-cassava/src/Servant/CSV/Cassava.hs +++ b/servant-cassava/src/Servant/CSV/Cassava.hs @@ -19,7 +19,7 @@ module Servant.CSV.Cassava where import Data.Csv import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import Data.Vector (Vector) +import Data.Vector (Vector, toList) import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Servant.API (Accept (..), MimeRender (..), @@ -50,6 +50,18 @@ instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) where p = Proxy :: Proxy opt +-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining +-- the order of headers and fields. +instance ( ToNamedRecord a, EncodeOpts opt + ) => MimeRender (CSV', opt) (Header, Vector a) where + mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) + where p = Proxy :: Proxy opt + +-- | Encode with 'encodeDefaultOrderedByNameWith' +instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt + ) => MimeRender (CSV', opt) (Vector a) where + mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList + where p = Proxy :: Proxy opt -- ** Encode Options @@ -66,6 +78,17 @@ instance EncodeOpts DefaultEncodeOpts where -- ** Instances -- | Decode with 'decodeByNameWith' +instance ( FromNamedRecord a, DecodeOpts opt + ) => MimeUnrender (CSV', opt) (Header, [a]) where + mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs + where p = Proxy :: Proxy opt + +-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. +instance ( FromRecord a, DecodeOpts opt + ) => MimeUnrender (CSV', opt) [a] where + mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs + where p = Proxy :: Proxy opt + instance ( FromNamedRecord a, DecodeOpts opt ) => MimeUnrender (CSV', opt) (Header, Vector a) where mimeUnrender _ = decodeByNameWith (decodeOpts p) From 130fd27e0160fc61da9b1fbe6b5810f2b00e9d24 Mon Sep 17 00:00:00 2001 From: Luke Clifton Date: Tue, 22 Dec 2015 22:03:46 +1100 Subject: [PATCH 2/5] Conditionally include Control.Applicative <$> --- servant-cassava/src/Servant/CSV/Cassava.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/servant-cassava/src/Servant/CSV/Cassava.hs b/servant-cassava/src/Servant/CSV/Cassava.hs index 3c00a662..625007e7 100644 --- a/servant-cassava/src/Servant/CSV/Cassava.hs +++ b/servant-cassava/src/Servant/CSV/Cassava.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,6 +17,9 @@ -- >>> type EgDefault = Get '[CSV] [(Int, String)] module Servant.CSV.Cassava where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif import Data.Csv import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) From 1ea1340c5c49b86ec0f1ca32fce64fbd53a63c52 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 25 Dec 2015 15:50:28 +0100 Subject: [PATCH 3/5] Use env bash rather than /bin/bash. --- scripts/bump-versions.sh | 2 +- scripts/clear-sandbox.sh | 2 +- scripts/generate-nix-files.sh | 2 +- scripts/start-sandbox.sh | 2 +- scripts/test-all.sh | 2 +- scripts/upload.sh | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index e1e735f4..2e39cea3 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: bump-versions.sh diff --git a/scripts/clear-sandbox.sh b/scripts/clear-sandbox.sh index 440e603c..5e70e14f 100755 --- a/scripts/clear-sandbox.sh +++ b/scripts/clear-sandbox.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: clear-sandbox.sh diff --git a/scripts/generate-nix-files.sh b/scripts/generate-nix-files.sh index e72d772a..5865e02f 100755 --- a/scripts/generate-nix-files.sh +++ b/scripts/generate-nix-files.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: generate-nix-files.sh diff --git a/scripts/start-sandbox.sh b/scripts/start-sandbox.sh index b6e88759..5808f072 100755 --- a/scripts/start-sandbox.sh +++ b/scripts/start-sandbox.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: start-sandbox.sh diff --git a/scripts/test-all.sh b/scripts/test-all.sh index 04fd012b..59d24a97 100755 --- a/scripts/test-all.sh +++ b/scripts/test-all.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: test-all.sh diff --git a/scripts/upload.sh b/scripts/upload.sh index 91f0b665..344b8e4a 100755 --- a/scripts/upload.sh +++ b/scripts/upload.sh @@ -1,4 +1,4 @@ -#!/bin/bash - +#!/usr/bin/env bash #=============================================================================== # # FILE: upload.sh From d0cd0c8c2ff829b82a5cea668226b8c3c359e979 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 26 Dec 2015 14:32:43 +0100 Subject: [PATCH 4/5] Add Config parameter. This allows combinator instances to receive dynamic data that isn't constrained by the interface of Delayed etc. --- servant-server/example/greet.hs | 2 +- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 14 +++- servant-server/src/Servant/Server/Internal.hs | 83 ++++++++++--------- .../src/Servant/Server/Internal/Config.hs | 62 ++++++++++++++ .../test/Servant/Server/ErrorSpec.hs | 8 +- .../test/Servant/Server/Internal/EnterSpec.hs | 4 +- servant-server/test/Servant/ServerSpec.hs | 61 ++++++++------ .../test/Servant/Utils/StaticFilesSpec.hs | 4 +- 9 files changed, 160 insertions(+), 79 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Config.hs diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 3fda367d..37c3f674 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application -test = serve testApi server +test = serve testApi EmptyConfig server -- Run the server. -- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 7e36387e..33949fc9 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -36,6 +36,7 @@ library Servant Servant.Server Servant.Server.Internal + Servant.Server.Internal.Config Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index a26941ea..765008ad 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -35,6 +35,11 @@ module Servant.Server , generalizeNat , tweakResponse + -- * Config + , ConfigEntry(..) + , Config(..) + , (.:) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -96,14 +101,17 @@ import Servant.Server.Internal.Enter -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > +-- > cfg :: Config '[] +-- > cfg = EmptyConfig +-- > -- > app :: Application --- > app = serve myApi server +-- > app = serve myApi cfg server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p d)) +serve :: HasServer layout => Proxy layout -> Config a -> Server layout -> Application +serve p cfg server = toApplication (runRouter (route p cfg 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 4200d052..aee3306e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -14,6 +14,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal + , module Servant.Server.Internal.Config , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -52,6 +53,7 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.Server.Internal.Config import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -62,7 +64,7 @@ import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, class HasServer layout where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Delayed (Server layout) -> Router + route :: Proxy layout -> Config a -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -83,8 +85,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> b) -> b) <$> server)) + route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server)) + (route pb cfg ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -114,9 +116,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - route Proxy d = + route Proxy cfg d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) + cfg (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -215,7 +218,7 @@ instance type ServerT (Delete ctypes a) m = m a - route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -225,7 +228,7 @@ instance type ServerT (Delete ctypes ()) m = m () - route Proxy = methodRouterEmpty methodDelete + route Proxy _ = methodRouterEmpty methodDelete -- Add response headers instance @@ -237,7 +240,7 @@ instance type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' @@ -260,7 +263,7 @@ instance type ServerT (Get ctypes a) m = m a - route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 -- '()' ==> 204 No Content instance @@ -271,7 +274,7 @@ instance type ServerT (Get ctypes ()) m = m () - route Proxy = methodRouterEmpty methodGet + route Proxy _ = methodRouterEmpty methodGet -- Add response headers instance @@ -283,7 +286,7 @@ instance type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -311,9 +314,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy cfg subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) cfg (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | When implementing the handler for a 'Post' endpoint, @@ -338,7 +341,7 @@ instance type ServerT (Post ctypes a) m = m a - route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 + route Proxy _ = methodRouter methodPost (Proxy :: Proxy ctypes) created201 instance #if MIN_VERSION_base(4,8,0) @@ -348,7 +351,7 @@ instance type ServerT (Post ctypes ()) m = m () - route Proxy = methodRouterEmpty methodPost + route Proxy _ = methodRouterEmpty methodPost -- Add response headers instance @@ -360,7 +363,7 @@ instance type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 + route Proxy _ = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -383,7 +386,7 @@ instance type ServerT (Put ctypes a) m = m a - route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -393,7 +396,7 @@ instance type ServerT (Put ctypes ()) m = m () - route Proxy = methodRouterEmpty methodPut + route Proxy _ = methodRouterEmpty methodPut -- Add response headers instance @@ -405,7 +408,7 @@ instance type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 -- | When implementing the handler for a 'Patch' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -426,7 +429,7 @@ instance type ServerT (Patch ctypes a) m = m a - route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -436,7 +439,7 @@ instance type ServerT (Patch ctypes ()) m = m () - route Proxy = methodRouterEmpty methodPatch + route Proxy _ = methodRouterEmpty methodPatch -- Add response headers instance @@ -448,7 +451,7 @@ instance type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -477,7 +480,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy cfg subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -485,7 +488,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -513,14 +516,14 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy cfg subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters = filter looksLikeParam querytext values = mapMaybe (convert . snd) parameters - in route (Proxy :: Proxy sublayout) (passToServer subserver values) + in route (Proxy :: Proxy sublayout) cfg (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -544,13 +547,13 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy cfg subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -567,7 +570,7 @@ instance HasServer Raw where type ServerT Raw m = Application - route Proxy rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -601,8 +604,8 @@ instance ( AllCTUnrender list a, HasServer sublayout type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) + route Proxy cfg subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) cfg (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -624,36 +627,36 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy subserver = StaticRouter $ + route Proxy cfg subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) subserver) + (route (Proxy :: Proxy sublayout) cfg subserver) where proxyPath = Proxy :: Proxy path instance HasServer api => HasServer (RemoteHost :> api) where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) + route Proxy cfg subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) cfg (passToServer subserver $ remoteHost req) instance HasServer api => HasServer (IsSecure :> api) where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ secure req) + route Proxy cfg subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) cfg (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 - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ vault req) + route Proxy cfg subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) cfg (passToServer subserver $ vault req) instance HasServer api => HasServer (HttpVersion :> api) where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) + route Proxy cfg subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req) pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs new file mode 100644 index 00000000..fd9cbe97 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif +module Servant.Server.Internal.Config where + +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) + +instance Applicative (ConfigEntry tag) where + pure = ConfigEntry + ConfigEntry f <*> ConfigEntry a = ConfigEntry $ f a + +instance Monad (ConfigEntry tag) where + return = ConfigEntry + ConfigEntry a >>= f = f a + +-- | The entire configuration. +data Config a where + EmptyConfig :: Config '[] + ConsConfig :: x -> Config xs -> Config (x ': xs) + +(.:) :: x -> Config xs -> Config (ConfigEntry tag x ': xs) +e .: cfg = ConsConfig (ConfigEntry e) cfg +infixr 4 .: + +class HasConfigEntry (cfg :: [*]) a val | cfg a -> val where + getConfigEntry :: proxy a -> Config cfg -> val + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where + getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + HasConfigEntry (ConfigEntry tag val ': xs) tag val where + getConfigEntry _ (ConsConfig x _) = unConfigEntry x diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 2e93cc2a..81fdabbf 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do + $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet @@ -89,7 +89,7 @@ prioErrorsApi = Proxy prioErrorsSpec :: Spec prioErrorsSpec = describe "PrioErrors" $ do let server = return - with (return $ serve prioErrorsApi server) $ do + with (return $ serve prioErrorsApi EmptyConfig server) $ do let check (mdescr, method) path (cdescr, ctype, body) resp = it fulldescr $ Test.Hspec.Wai.request method path [(hContentType, ctype)] body @@ -154,7 +154,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi errorRetryServer) $ do + $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -194,7 +194,7 @@ errorChoiceServer = return 0 errorChoiceSpec :: Spec errorChoiceSpec = describe "Multiple handlers return errors" - $ with (return $ serve errorChoiceApi errorChoiceServer) $ do + $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do it "should respond with 404 if no path matches" $ do request methodGet "" [] "" `shouldRespondWith` 404 diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 973e1f89..f5e70356 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do - with (return (serve readerAPI readerServer)) $ do + with (return (serve readerAPI EmptyConfig readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } - with (return (serve combinedAPI combinedReaderServer)) $ do + with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e017d399..0bf7fdfc 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -23,14 +23,15 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hAccept, hContentType, - methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut, - ok200, parseQuery, Status(..)) +import Network.HTTP.Types (Status (..), hAccept, hContentType, + methodDelete, methodGet, + methodHead, methodPatch, + methodPost, methodPut, ok200, + parseQuery) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, - responseLBS, responseBuilder) -import Network.Wai.Internal (Response(ResponseBuilder)) + responseBuilder, responseLBS) +import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Servant.API ((:<|>) (..), (:>), Capture, Delete, @@ -40,15 +41,20 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, addHeader) -import Servant.Server (Server, serve, ServantErr(..), err404) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, post, request, shouldRespondWith, with, (<:>)) -import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) -import Servant.Server.Internal.Router - (tweakResponse, runRouter, - Router, Router'(LeafRouter)) + +import Servant.Server (Config(EmptyConfig), + ServantErr (..), + Server, err404, + serve) +import Servant.Server.Internal.Router (Router, Router' (LeafRouter), + runRouter, + tweakResponse) +import Servant.Server.Internal.RoutingApplication (RouteResult (..), + toApplication) -- * test data types @@ -112,7 +118,7 @@ captureServer legs = case legs of captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do - with (return (serve captureApi captureServer)) $ do + with (return (serve captureApi EmptyConfig captureServer)) $ do it "can capture parts of the 'pathInfo'" $ do response <- get "/2" @@ -123,6 +129,7 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) + EmptyConfig (\ "captured" request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do @@ -139,7 +146,7 @@ getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do + with (return $ serve getApi EmptyConfig server) $ do it "allows to GET a Person" $ do response <- get "/" @@ -162,7 +169,7 @@ headSpec :: Spec headSpec = do describe "Servant.API.Head" $ do let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do + with (return $ serve getApi EmptyConfig server) $ do it "allows to GET a Person" $ do response <- Test.Hspec.Wai.request methodHead "/" [] "" @@ -209,7 +216,7 @@ queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do it "allows to retrieve simple GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params1, @@ -221,7 +228,7 @@ queryParamSpec = do } it "allows to retrieve lists in GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params2, @@ -235,7 +242,7 @@ queryParamSpec = do it "allows to retrieve value-less GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3, @@ -281,7 +288,7 @@ postSpec :: Spec postSpec = do describe "Servant.API.Post and .ReqBody" $ do let server = return . age :<|> return . age :<|> return () - with (return $ serve postApi server) $ do + with (return $ serve postApi EmptyConfig server) $ do let post' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/json;charset=utf-8")] @@ -323,7 +330,7 @@ putSpec :: Spec putSpec = do describe "Servant.API.Put and .ReqBody" $ do let server = return . age :<|> return . age :<|> return () - with (return $ serve putApi server) $ do + with (return $ serve putApi EmptyConfig server) $ do let put' x = Test.Hspec.Wai.request methodPut x [(hContentType , "application/json;charset=utf-8")] @@ -365,7 +372,7 @@ patchSpec :: Spec patchSpec = do describe "Servant.API.Patch and .ReqBody" $ do let server = return . age :<|> return . age :<|> return () - with (return $ serve patchApi server) $ do + with (return $ serve patchApi EmptyConfig server) $ do let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType , "application/json;charset=utf-8")] @@ -410,13 +417,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" - with (return (serve headerApi expectsInt)) $ do + with (return (serve headerApi EmptyConfig expectsInt)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 204 - with (return (serve headerApi expectsString)) $ do + with (return (serve headerApi EmptyConfig expectsString)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] it "passes the header to the handler (String)" $ @@ -433,7 +440,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -441,7 +448,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } @@ -471,7 +478,7 @@ unionServer = unionSpec :: Spec unionSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve unionApi unionServer) $ do + with (return $ serve unionApi EmptyConfig unionServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -503,7 +510,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do - with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do + with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] @@ -562,7 +569,7 @@ miscServ = versionHandler hostHandler = return . show miscReqCombinatorsSpec :: Spec -miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ +miscReqCombinatorsSpec = with (return $ serve miscApi EmptyConfig miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 3630b313..0777e4ec 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -21,7 +21,7 @@ import Servant.API.Capture (Capture) import Servant.API.Get (Get) import Servant.API.Raw (Raw) import Servant.API.Sub ((:>)) -import Servant.Server (Server, serve) +import Servant.Server (Server, serve, Config(EmptyConfig)) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) @@ -34,7 +34,7 @@ api :: Proxy Api api = Proxy app :: Application -app = serve api server +app = serve api EmptyConfig server server :: Server Api server = From 0a5002eff5c9b3686bb839cc9fabddd6c908c450 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 26 Dec 2015 15:30:39 +0100 Subject: [PATCH 5/5] Tests for Config. --- servant-server/servant-server.cabal | 3 ++ .../src/Servant/Server/Internal/Config.hs | 18 ++++++++- .../Servant/Server/Internal/ConfigSpec.hs | 37 +++++++++++++++++++ stack.yaml | 1 + 4 files changed, 57 insertions(+), 2 deletions(-) create mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 33949fc9..6d6348df 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -48,6 +48,7 @@ library , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 + , deepseq == 1.4.* , http-api-data >= 0.1 && < 0.3 , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 @@ -94,6 +95,7 @@ test-suite spec main-is: Spec.hs other-modules: Servant.Server.Internal.EnterSpec + Servant.Server.Internal.ConfigSpec Servant.ServerSpec Servant.Utils.StaticFilesSpec Servant.Server.ErrorSpec @@ -114,6 +116,7 @@ test-suite spec , servant , servant-server , string-conversions + , should-not-typecheck == 2.* , temporary , text , transformers diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index fd9cbe97..5c2855d8 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -11,6 +11,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if !MIN_VERSION_base(4,8,0) @@ -18,6 +19,7 @@ #endif module Servant.Server.Internal.Config where +import Control.DeepSeq (NFData(rnf)) import GHC.Generics (Generic) import Data.Typeable (Typeable) @@ -25,7 +27,7 @@ import Data.Typeable (Typeable) -- 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) + , Num, Ord, Real, Functor, Foldable, Traversable, NFData) instance Applicative (ConfigEntry tag) where pure = ConfigEntry @@ -40,11 +42,23 @@ data Config a where EmptyConfig :: Config '[] ConsConfig :: x -> Config xs -> Config (x ': xs) +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 + +instance NFData (Config '[]) where + rnf EmptyConfig = () +instance (NFData a, NFData (Config as)) => NFData (Config (a ': as)) where + rnf (x `ConsConfig` ys) = rnf x `seq` rnf ys + + + (.:) :: x -> Config xs -> Config (ConfigEntry tag x ': xs) e .: cfg = ConsConfig (ConfigEntry e) cfg infixr 4 .: -class HasConfigEntry (cfg :: [*]) a val | cfg a -> val where +class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where getConfigEntry :: proxy a -> Config cfg -> val instance diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs new file mode 100644 index 00000000..01bccc44 --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -0,0 +1,37 @@ +{-# 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) +import Test.ShouldNotTypecheck (shouldNotTypecheck) + +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] + + it "gets the config if a matching one exists" $ do + + getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0 + + it "gets the first matching config" $ do + + getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1 + + it "does not typecheck if key does not exist" $ do + + let x = getConfigEntry (Proxy :: Proxy "b") cfg1 :: Int + shouldNotTypecheck x + + it "does not typecheck if key maps to a different type" $ do + + let x = getConfigEntry (Proxy :: Proxy "a") cfg1 :: String + shouldNotTypecheck x diff --git a/stack.yaml b/stack.yaml index f370da09..c1aea0a2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,4 +16,5 @@ packages: extra-deps: - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 +- should-not-typecheck-2.0.1 resolver: nightly-2015-10-08