diff --git a/.travis.yml b/.travis.yml index 62501f7a..9cddf7ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ install: - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config script: - - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done cache: directories: diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 335f6094..f0cdd2eb 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it! We are currently moving to a more aggresive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major releases it may take some time in between releases. + +## Reporting security issues + +Please email haskell-servant-maintainers AT googlegroups DOT com. This group is +private, and accessible only to known maintainers. We will then discuss how to +proceed. Please do not make the issue public before we inform you that we have +a patch ready. diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index a18992a3..b55d4a66 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 083ac57b..4703b0ec 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -735,6 +735,15 @@ instance OVERLAPPING_ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a +instance (KnownSymbol sym, HasDocs sublayout) + => HasDocs (Header sym a :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + action' = over headers (|> headername) action + headername = T.pack $ symbolVal (Proxy :: Proxy sym) + instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) => HasDocs (QueryParam sym a :> sublayout) where diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index d37f78c9..703ea795 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -63,6 +63,7 @@ spec = describe "Servant.Docs" $ do , ("zwei, kaks, kaks",(TT2,UT2,UT2)) ] + where tests md = do it "mentions supported content-types" $ do @@ -76,11 +77,15 @@ spec = describe "Servant.Docs" $ do md `shouldContain` "POST" md `shouldContain` "GET" + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." + it "contains response samples" $ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" it "contains request body samples" $ md `shouldContain` "17" + -- * APIs data Datatype1 = Datatype1 { dt1field1 :: String @@ -103,6 +108,7 @@ instance MimeRender PlainText Int where type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> Header "X-Test" Int :> Put '[JSON] Int data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 51ba7329..6c63c0e4 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api $ mock api) +main = run 8080 (serve api EmptyConfig $ mock api) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 7d8589d0..af444527 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -18,8 +18,7 @@ cabal-version: >=1.10 flag example description: Build the example too - manual: True - default: False + default: True library exposed-modules: diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index e4437fba..7d17dca5 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index ad7c6bde..5a57f172 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -99,11 +99,13 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: - Servant.Server.Internal.EnterSpec - Servant.Server.Internal.ConfigSpec - Servant.ServerSpec - Servant.Utils.StaticFilesSpec Servant.Server.ErrorSpec + Servant.Server.Internal.ConfigSpec + Servant.Server.Internal.EnterSpec + Servant.ServerSpec + Servant.Server.UsingConfigSpec + Servant.Server.UsingConfigSpec.TestCombinators + Servant.Utils.StaticFilesSpec build-depends: base == 4.* , aeson diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index dde4acb3..8fbe25ac 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -35,11 +36,6 @@ module Servant.Server , generalizeNat , tweakResponse - -- * Config - , ConfigEntry(..) - , Config(..) - , (.:.) - -- * General Authentication , AuthHandler(unAuthHandler) , AuthReturnType @@ -49,6 +45,10 @@ module Servant.Server , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) , BasicAuthResult(..) + -- * Config + , Config(..) + , NamedConfig(..) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -77,7 +77,7 @@ module Servant.Server , err415 , err416 , err417 - -- * 5XX + -- ** 5XX , err500 , err501 , err502 @@ -110,18 +110,18 @@ import Servant.Server.Internal.Enter -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > cfg :: Config '[] --- > cfg = EmptyConfig +-- > config :: Config '[] +-- > config = EmptyConfig -- > -- > app :: Application --- > app = serve myApi cfg server +-- > app = serve myApi config server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasCfg layout a, HasServer layout) +serve :: (HasConfig layout a, HasServer layout) => Proxy layout -> Config a -> Server layout -> Application -serve p cfg server = toApplication (runRouter (route p cfg d)) +serve p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r r (\ _ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 8c616c80..2e04307f 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -53,7 +54,8 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Ba Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault) + Raw, RemoteHost, ReqBody, Vault, + WithNamedConfig) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -71,9 +73,9 @@ import Servant.Server.Internal.ServantErr class HasServer layout where type ServerT layout (m :: * -> *) :: * - type HasCfg layout (c :: [*]) :: Constraint + type HasConfig layout (c :: [*]) :: Constraint - route :: HasCfg layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router + route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -93,10 +95,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - type HasCfg (a :<|> b) c = (HasCfg a c, HasCfg b c) + type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c) - route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server)) - (route pb cfg ((\ (_ :<|> b) -> b) <$> server)) + route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) + (route pb config ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -125,12 +127,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - type HasCfg (Capture capture a :> sublayout) c = (HasCfg sublayout c) + type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c) - route Proxy cfg d = + route Proxy config d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) - cfg + config (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -202,7 +204,7 @@ instance OVERLAPPABLE_ ) => HasServer (Verb method status ctypes a) where type ServerT (Verb method status ctypes a) m = m a - type HasCfg (Verb method status ctypes a) c = () + type HasConfig (Verb method status ctypes a) c = () route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -214,7 +216,7 @@ instance OVERLAPPING_ ) => HasServer (Verb method status ctypes (Headers h a)) where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - type HasCfg (Verb method status ctypes (Headers h a)) c = () + type HasConfig (Verb method status ctypes (Headers h a)) c = () route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -245,11 +247,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasCfg (Header sym a :> sublayout) c = HasCfg sublayout c + type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) cfg (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -278,9 +280,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasCfg (QueryParam sym a :> sublayout) c = HasCfg sublayout c + type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -288,7 +290,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -315,16 +317,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - type HasCfg (QueryParams sym a :> sublayout) c = HasCfg sublayout c + type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters = filter looksLikeParam querytext values = mapMaybe (convert . snd) parameters - in route (Proxy :: Proxy sublayout) cfg (passToServer subserver values) + in route (Proxy :: Proxy sublayout) config (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -347,15 +349,15 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - type HasCfg (QueryFlag sym :> sublayout) c = HasCfg sublayout c + type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) cfg (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -371,7 +373,7 @@ instance (KnownSymbol sym, HasServer sublayout) instance HasServer Raw where type ServerT Raw m = Application - type HasCfg Raw c = () + type HasConfig Raw c = () route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication @@ -406,10 +408,10 @@ instance ( AllCTUnrender list a, HasServer sublayout type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - type HasCfg (ReqBody list a :> sublayout) c = HasCfg sublayout c + type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) cfg (addBodyCheck subserver (bodyCheck request)) + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -430,67 +432,67 @@ instance ( AllCTUnrender list a, HasServer sublayout instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type ServerT (path :> sublayout) m = ServerT sublayout m - type HasCfg (path :> sublayout) c = HasCfg sublayout c + type HasConfig (path :> sublayout) c = HasConfig sublayout c - route Proxy cfg subserver = StaticRouter $ + route Proxy config subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) cfg subserver) + (route (Proxy :: Proxy sublayout) config subserver) where proxyPath = Proxy :: Proxy path instance HasServer api => HasServer (RemoteHost :> api) where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - type HasCfg (RemoteHost :> api) c = HasCfg api c + type HasConfig (RemoteHost :> api) c = HasConfig api c - route Proxy cfg subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) cfg (passToServer subserver $ remoteHost req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) instance HasServer api => HasServer (IsSecure :> api) where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - type HasCfg (IsSecure :> api) c = HasCfg api c + type HasConfig (IsSecure :> api) c = HasConfig api c - route Proxy cfg subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) cfg (passToServer subserver $ secure req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure instance HasServer api => HasServer (Vault :> api) where type ServerT (Vault :> api) m = Vault -> ServerT api m - type HasCfg (Vault :> api) c = HasCfg api c + type HasConfig (Vault :> api) c = HasConfig api c - route Proxy cfg subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) cfg (passToServer subserver $ vault req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ vault req) instance HasServer api => HasServer (HttpVersion :> api) where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - type HasCfg (HttpVersion :> api) c = HasCfg api c + type HasConfig (HttpVersion :> api) c = HasConfig api c - route Proxy cfg subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) -- | Basic Authentication instance (KnownSymbol realm, HasServer api) => HasServer (BasicAuth tag realm usr :> api) where type ServerT (BasicAuth tag realm usr :> api) m = usr -> ServerT api m - type HasCfg (BasicAuth tag realm usr :> api) c - = (HasConfigEntry c tag (BasicAuthCheck usr), HasCfg api c) + type HasConfig (BasicAuth tag realm usr :> api) c + = (HasConfigEntry c (BasicAuthCheck usr), HasConfig api c) - route Proxy cfg subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request) + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) - baCfg = getConfigEntry (Proxy :: Proxy tag) cfg - authCheck req = runBasicAuth req realm baCfg + basicAuthConfig = getConfigEntry config + authCheck req = runBasicAuth req realm basicAuthConfig -- | General Authentication instance HasServer api => HasServer (AuthProtect tag :> api) where type ServerT (AuthProtect tag :> api) m = AuthReturnType (AuthProtect tag) -> ServerT api m - type HasCfg (AuthProtect tag :> api) c - = (HasConfigEntry c tag (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasCfg api c) + type HasConfig (AuthProtect tag :> api) c + = (HasConfigEntry c (AuthHandler Request (AuthReturnType (AuthProtect tag))), HasConfig api c) - route Proxy cfg subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request) + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) where - authHandler = unAuthHandler (getConfigEntry (Proxy :: Proxy tag) cfg) + authHandler = unAuthHandler (getConfigEntry config) authCheck = fmap (either FailFatal Route) . runExceptT . authHandler pathIsEmpty :: Request -> Bool @@ -501,3 +503,20 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +-- * configs + +instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where + type ServerT (WithNamedConfig name subConfig subApi) m = + ServerT subApi m + type HasConfig (WithNamedConfig name subConfig subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index 94807693..e710de4b 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -1,62 +1,57 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" module Servant.Server.Internal.Config where -import Control.DeepSeq (NFData) -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - --- | A single entry in the configuration. The first parameter is phantom, and --- is used to lookup a @ConfigEntry@ in a @Config@. -newtype ConfigEntry tag a = ConfigEntry { unConfigEntry :: a } - deriving ( Eq, Show, Read, Enum, Integral, Fractional, Generic, Typeable - , Num, Ord, Real, Functor, Foldable, Traversable, NFData) +import Data.Proxy +import GHC.TypeLits -- | The entire configuration. data Config a where EmptyConfig :: Config '[] - ConsConfig :: x -> Config xs -> Config (x ': xs) + (:.) :: x -> Config xs -> Config (x ': xs) +infixr 5 :. instance Show (Config '[]) where show EmptyConfig = "EmptyConfig" -instance (Show a, Show (Config as)) => Show (Config (ConfigEntry tag a ': as)) where - showsPrec outerPrecedence (ConsConfig (ConfigEntry a) as) = +instance (Show a, Show (Config as)) => Show (Config (a ': as)) where + showsPrec outerPrecedence (a :. as) = showParen (outerPrecedence > 5) $ - shows a . showString " .:. " . shows as + shows a . showString " :. " . shows as instance Eq (Config '[]) where _ == _ = True instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where - ConsConfig x1 y1 == ConsConfig x2 y2 = x1 == x2 && y1 == y2 + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 -(.:.) :: x -> Config xs -> Config (ConfigEntry tag x ': xs) -e .:. cfg = ConsConfig (ConfigEntry e) cfg -infixr 5 .:. - -class HasConfigEntry (cfg :: [*]) (a :: k) (val :: *) | cfg a -> val where - getConfigEntry :: proxy a -> Config cfg -> val +class HasConfigEntry (config :: [*]) (val :: *) where + getConfigEntry :: Config config -> val instance OVERLAPPABLE_ - HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where - getConfigEntry p (ConsConfig _ xs) = getConfigEntry p xs + HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where + getConfigEntry (_ :. xs) = getConfigEntry xs -instance OVERLAPPABLE_ - HasConfigEntry (ConfigEntry tag val ': xs) tag val where - getConfigEntry _ (ConsConfig x _) = unConfigEntry x +instance OVERLAPPING_ + HasConfigEntry (val ': xs) val where + getConfigEntry (x :. _) = x + +-- * support for named subconfigs + +data NamedConfig (name :: Symbol) (subConfig :: [*]) + = NamedConfig (Config subConfig) + +descendIntoNamedConfig :: forall config name subConfig . + HasConfigEntry config (NamedConfig name subConfig) => + Proxy (name :: Symbol) -> Config config -> Config subConfig +descendIntoNamedConfig Proxy config = + let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig + in subConfig diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs index 3083691d..182d91a8 100644 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -11,42 +11,51 @@ import Servant.Server.Internal.Config spec :: Spec spec = do - getConfigEntrySpec + describe "getConfigEntry" $ do + it "gets the config if a matching one exists" $ do + let config = 'a' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' -getConfigEntrySpec :: Spec -getConfigEntrySpec = describe "getConfigEntry" $ do + it "gets the first matching config" $ do + let config = 'a' :. 'b' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' - let cfg1 = 0 .:. EmptyConfig :: Config '[ConfigEntry "a" Int] - cfg2 = 1 .:. cfg1 :: Config '[ConfigEntry "a" Int, ConfigEntry "a" Int] + it "does not typecheck if type does not exist" $ do + let config = 'a' :. EmptyConfig + x = getConfigEntry config :: Bool + shouldNotTypecheck x - it "gets the config if a matching one exists" $ do + context "Show instance" $ do + let config = 'a' :. True :. EmptyConfig + it "has a Show instance" $ do + show config `shouldBe` "'a' :. True :. EmptyConfig" - getConfigEntry (Proxy :: Proxy "a") cfg1 `shouldBe` 0 + context "bracketing" $ do + it "works" $ do + show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)" - it "gets the first matching config" $ do + it "works with operators" $ do + let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig) + show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)" - getConfigEntry (Proxy :: Proxy "a") cfg2 `shouldBe` 1 + 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 to distinguish between different config entries with the same type by tag" $ do - let cfg = 'a' .:. 'b' .:. EmptyConfig :: Config '[ConfigEntry 1 Char, ConfigEntry 2 Char] - getConfigEntry (Proxy :: Proxy 1) cfg `shouldBe` 'a' + it "allows extracting entries from subconfigs" $ do + getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char]) + `shouldBe` 'b' - context "Show instance" $ do - let cfg = 1 .:. 2 .:. EmptyConfig - it "has a Show instance" $ do - show cfg `shouldBe` "1 .:. 2 .:. EmptyConfig" + it "does not typecheck if subConfig has the wrong type" $ do + let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int] + shouldNotTypecheck (show x) - it "bracketing works" $ do - show (Just cfg) `shouldBe` "Just (1 .:. 2 .:. EmptyConfig)" - - it "bracketing works with operators" $ do - let cfg = (1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig) - show cfg `shouldBe` "(1 .:. 'a' .:. EmptyConfig) :<|> ('b' .:. True .:. EmptyConfig)" - - it "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 + 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/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs new file mode 100644 index 00000000..a6c7ae43 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingConfigSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingConfigSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromConfig :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serve (Proxy :: Proxy OneEntryAPI) config testServer + where + config :: Config '[String] + config = "configEntry" :. EmptyConfig + +type OneEntryTwiceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String] + config = "configEntryTwice" :. EmptyConfig + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing config entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ConfigEntry" $ do + get "/" `shouldRespondWith` "\"configEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ConfigEntry twice" $ do + get "/foo" `shouldRespondWith` "\"configEntryTwice\"" + get "/bar" `shouldRespondWith` "\"configEntryTwice\"" + +type InjectAPI = + InjectIntoConfig :> "untagged" :> ExtractFromConfig :> + Get '[JSON] String :<|> + InjectIntoConfig :> "tagged" :> ExtractFromConfig :> + Get '[JSON] String + +injectApp :: Application +injectApp = serve (Proxy :: Proxy InjectAPI) config $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + config = EmptyConfig + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting config entries with custom combinators" $ do + it "allows to inject config entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged config entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + NamedConfigWithBirdface "sub" '[String] :> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String, (NamedConfig "sub" '[String])] + config = + "firstEntry" :. + (NamedConfig ("secondEntry" :. EmptyConfig)) :. + EmptyConfig + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ConfigEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedConfigAPI = + WithNamedConfig "sub" '[String] ( + ExtractFromConfig :> Get '[JSON] String) + +namedConfigApp :: Application +namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return + where + config :: Config '[NamedConfig "sub" '[String]] + config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig + +spec4 :: Spec +spec4 = do + with (return namedConfigApp) $ do + describe "WithNamedConfig" $ do + it "allows descending into a subconfig for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs new file mode 100644 index 00000000..53f00f21 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingConfigSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Config, you don't. This module is +-- separate from Servant.Server.UsingConfigSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingConfigSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.Config +import Servant.Server.Internal.RoutingApplication + +data ExtractFromConfig + +instance (HasServer subApi) => + HasServer (ExtractFromConfig :> subApi) where + + type ServerT (ExtractFromConfig :> subApi) m = + String -> ServerT subApi m + type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) = + (HasConfigEntry c String, HasConfig subApi c) + + route Proxy config delayed = + route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject config f = f (getConfigEntry config) + +data InjectIntoConfig + +instance (HasServer subApi) => + HasServer (InjectIntoConfig :> subApi) where + + type ServerT (InjectIntoConfig :> subApi) m = + ServerT subApi m + type HasConfig (InjectIntoConfig :> subApi) c = + (HasConfig subApi (String ': c)) + + route Proxy config delayed = + route subProxy newConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newConfig = ("injected" :: String) :. config + +data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) + +instance (HasServer subApi) => + HasServer (NamedConfigWithBirdface name subConfig :> subApi) where + + type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = + ServerT subApi m + type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 41b7792b..964d26fa 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -48,10 +48,10 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Bas QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) -import Servant.Server ((.:.), AuthHandler, AuthReturnType, +import Servant.Server (AuthHandler, AuthReturnType, BasicAuthCheck (BasicAuthCheck), BasicAuthResult (Authorized, Unauthorized), - Config (EmptyConfig), ConfigEntry, ServantErr (..), + Config ((:.), EmptyConfig), ServantErr (..), mkAuthHandler, Server, err401, err404, serve) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) @@ -226,7 +226,7 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do - it "allows to retrieve simple GET parameters" $ + it "allows retrieving simple GET parameters" $ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ @@ -238,7 +238,7 @@ queryParamSpec = do name = "bob" } - it "allows to retrieve lists in GET parameters" $ + it "allows retrieving lists in GET parameters" $ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ @@ -252,7 +252,7 @@ queryParamSpec = do } - it "allows to retrieve value-less GET parameters" $ + it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ @@ -339,13 +339,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString Nothing = error "Expected a string" with (return (serve headerApi EmptyConfig expectsInt)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi EmptyConfig expectsString)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 @@ -537,8 +537,8 @@ authServer = const (return jerry) :<|> const (return tweety) type instance AuthReturnType (AuthProtect "auth") = () -authConfig :: Config '[ ConfigEntry "basic" (BasicAuthCheck ()) - , ConfigEntry "auth" (AuthHandler Request ()) +authConfig :: Config '[ BasicAuthCheck () + , AuthHandler Request () ] authConfig = let basicHandler = BasicAuthCheck $ (\usr pass -> @@ -551,7 +551,7 @@ authConfig = then return () else throwE err401 ) - in basicHandler .:. mkAuthHandler authHandler .:. EmptyConfig + in basicHandler :. mkAuthHandler authHandler :. EmptyConfig authSpec :: Spec authSpec = do diff --git a/servant/.ghci b/servant/.ghci new file mode 100644 index 00000000..e5c6777e --- /dev/null +++ b/servant/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/servant/servant.cabal b/servant/servant.cabal index c71dc913..13f13fdb 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -41,6 +41,7 @@ library Servant.API.Sub Servant.API.Vault Servant.API.Verbs + Servant.API.WithNamedConfig Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 9c76d460..ca2acd89 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,6 +23,8 @@ module Servant.API ( -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware + module Servant.API.WithNamedConfig, + -- | Access config entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -92,6 +94,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) +import Servant.API.WithNamedConfig (WithNamedConfig) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs new file mode 100644 index 00000000..3f234292 --- /dev/null +++ b/servant/src/Servant/API/WithNamedConfig.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedConfig where + +import GHC.TypeLits + +data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi