server/config: implemented Config with optionally tagged entries

servant-server/src/Servant/Server.hs

@@ -38,6 +38,7 @@ module Servant.Server
 
   -- * Config
   , Config(..)
+  , Tagged(..)
 
     -- * Default error type
   , ServantErr(..)

servant-server/src/Servant/Server/Internal/Config.hs

@@ -10,8 +10,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
@@ -19,6 +19,9 @@
 
 module Servant.Server.Internal.Config where
 
+import           Data.Proxy
+import           GHC.TypeLits
+
 -- | The entire configuration.
 data Config a where
     EmptyConfig :: Config '[]
@@ -37,13 +40,20 @@ instance Eq (Config '[]) where
 instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where
     x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
 
-class HasConfigEntry (cfg :: [*]) (val :: *) where
-    getConfigEntry :: Config cfg -> val
+newtype Tagged (tag :: Symbol) a = Tag a
+  deriving (Show, Eq)
+
+class HasConfigEntry (cfg :: [*]) tag (val :: *) where
+    getConfigEntry :: Proxy tag -> Config cfg -> val
 
 instance OVERLAPPABLE_
-         HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where
-    getConfigEntry (_ :. xs) = getConfigEntry xs
+         HasConfigEntry xs tag val => HasConfigEntry (notIt ': xs) tag val where
+    getConfigEntry proxy (_ :. xs) = getConfigEntry proxy xs
 
 instance OVERLAPPABLE_
-         HasConfigEntry (val ': xs) val where
-    getConfigEntry (x :. _) = x
+         HasConfigEntry (val ': xs) () val where
+    getConfigEntry proxy (x :. _) = x
+
+instance OVERLAPPABLE_
+         HasConfigEntry (Tagged tag val ': xs) tag val where
+    getConfigEntry proxy (Tag x :. _) = x

servant-server/test/Servant/Server/Internal/ConfigSpec.hs

@@ -13,25 +13,31 @@ spec :: Spec
 spec = do
   getConfigEntrySpec
 
-newtype Wrapped a = Wrap { unwrap :: a }
-
 getConfigEntrySpec :: Spec
 getConfigEntrySpec = describe "getConfigEntry" $ do
 
-  let cfg1 = 0 :. EmptyConfig :: Config '[Int]
-      cfg2 = 1 :. cfg1 :: Config '[Int, Int]
+  let cfg1 = (0 :: Int) :. EmptyConfig
+      cfg2 = (1 :: Int) :. cfg1
 
   it "gets the config if a matching one exists" $ do
-
-    getConfigEntry cfg1 `shouldBe` (0 :: Int)
+    getConfigEntry (Proxy :: Proxy ()) cfg1 `shouldBe` (0 :: Int)
 
   it "gets the first matching config" $ do
-
-    getConfigEntry cfg2 `shouldBe` (1 :: Int)
+    getConfigEntry (Proxy :: Proxy ()) cfg2 `shouldBe` (1 :: Int)
 
   it "allows to distinguish between different config entries with the same type by tag" $ do
-    let cfg = 'a' :. Wrap 'b' :. EmptyConfig :: Config '[Char, Wrapped Char]
-    getConfigEntry cfg `shouldBe` 'a'
+    let cfg = 'a' :. (Tag 'b' :: Tagged "second" Char) :. EmptyConfig
+    getConfigEntry (Proxy :: Proxy ()) cfg `shouldBe` 'a'
+    getConfigEntry (Proxy :: Proxy "second") cfg `shouldBe` 'b'
+
+  it "does not typecheck if type does not exist" $ do
+    let x = getConfigEntry (Proxy :: Proxy ()) cfg1 :: Bool
+    shouldNotTypecheck x
+
+  it "does not typecheck if tag does not exist" $ do
+    let cfg = (Tag 'a' :: Tagged "foo" Char) :. EmptyConfig
+        x = getConfigEntry (Proxy :: Proxy "bar") cfg :: Char
+    shouldNotTypecheck x
 
   context "Show instance" $ do
     let cfg = 1 :. 2 :. EmptyConfig
@@ -44,8 +50,3 @@ getConfigEntrySpec = describe "getConfigEntry" $ do
     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 type does not exist" $ do
-
-    let x = getConfigEntry cfg1 :: Bool
-    shouldNotTypecheck x

servant-server/test/Servant/Server/UsingConfigSpec.hs

@@ -14,13 +14,8 @@ import           Servant.Server.UsingConfigSpec.CustomCombinator
 
 -- * API
 
-newtype Wrapped a = Wrap { unwrap :: a }
-
-instance ToCustomConfig (Wrapped String) where
-  toCustomConfig = unwrap
-
 type OneEntryAPI =
-  CustomCombinator String :> Get '[JSON] String
+  CustomCombinator () :> Get '[JSON] String
 
 testServer :: Server OneEntryAPI
 testServer s = return s
@@ -29,34 +24,31 @@ oneEntryApp :: Application
 oneEntryApp =
   serve (Proxy :: Proxy OneEntryAPI) config testServer
   where
-    config :: Config '[String]
-    config = "configValue" :. EmptyConfig
+    config = ("configValue" :: String) :. EmptyConfig
 
 type OneEntryTwiceAPI =
-  "foo" :> CustomCombinator String :> Get '[JSON] String :<|>
-  "bar" :> CustomCombinator String :> Get '[JSON] String
+  "foo" :> CustomCombinator () :> Get '[JSON] String :<|>
+  "bar" :> CustomCombinator () :> Get '[JSON] String
 
 oneEntryTwiceApp :: Application
 oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
   testServer :<|>
   testServer
   where
-    config :: Config '[String]
-    config = "configValueTwice" :. EmptyConfig
+    config = ("configValueTwice" :: String) :. EmptyConfig
 
 type TwoDifferentEntries =
-  "foo" :> CustomCombinator String :> Get '[JSON] String :<|>
-  "bar" :> CustomCombinator (Wrapped String) :> Get '[JSON] String
+  "foo" :> CustomCombinator "foo" :> Get '[JSON] String :<|>
+  "bar" :> CustomCombinator "bar" :> Get '[JSON] String
 
 twoDifferentEntries :: Application
 twoDifferentEntries = serve (Proxy :: Proxy TwoDifferentEntries) config $
   testServer :<|>
   testServer
   where
-    config :: Config '[String, Wrapped String]
     config =
-      "firstConfigValue" :.
-      Wrap "secondConfigValue" :.
+      (Tag "firstConfigValue" :: Tagged "foo" String) :.
+      (Tag "secondConfigValue" :: Tagged "bar" String) :.
       EmptyConfig
 
 -- * tests

servant-server/test/Servant/Server/UsingConfigSpec/CustomCombinator.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -15,22 +16,16 @@ import           Servant
 import           Servant.Server.Internal.Config
 import           Servant.Server.Internal.RoutingApplication
 
-data CustomCombinator (entryType :: *)
+data CustomCombinator (tag :: k)
 
-class ToCustomConfig entryType where
-  toCustomConfig :: entryType -> String
+instance forall subApi (c :: [*]) tag .
+  (HasServer subApi) =>
+  HasServer (CustomCombinator tag :> subApi) where
 
-instance ToCustomConfig String where
-  toCustomConfig = id
-
-instance forall subApi (c :: [*]) entryType .
-  (HasServer subApi, ToCustomConfig entryType) =>
-  HasServer (CustomCombinator entryType :> subApi) where
-
-  type ServerT (CustomCombinator entryType :> subApi) m =
+  type ServerT (CustomCombinator tag :> subApi) m =
     String -> ServerT subApi m
-  type HasCfg (CustomCombinator entryType :> subApi) c =
-    (HasConfigEntry c entryType, HasCfg subApi c)
+  type HasCfg (CustomCombinator tag :> subApi) c =
+    (HasConfigEntry c tag String, HasCfg subApi c)
 
   route Proxy config delayed =
     route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi))
@@ -38,4 +33,4 @@ instance forall subApi (c :: [*]) entryType .
       subProxy :: Proxy subApi
       subProxy = Proxy
 
-      inject config f = f (toCustomConfig (getConfigEntry config :: entryType))
+      inject config f = f (getConfigEntry (Proxy :: Proxy tag) config)