servant-server 0.19.1 → 0.19.2
raw patch · 7 files changed
+191/−35 lines, 7 filesdep ~basedep ~base-compat
Dependency ranges changed: base, base-compat
Files
- CHANGELOG.md +5/−0
- example/greet.hs +0/−1
- servant-server.cabal +6/−6
- src/Servant/Server.hs +3/−2
- src/Servant/Server/Internal.hs +19/−6
- src/Servant/Server/Internal/Router.hs +31/−14
- test/Servant/Server/RouterSpec.hs +127/−6
CHANGELOG.md view
@@ -3,6 +3,11 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.19.2+------++Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).+ 0.19.1 ------
example/greet.hs view
@@ -18,7 +18,6 @@ import Servant import Servant.Server.Generic ()-import Servant.API.Generic -- * Example
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-server-version: 0.19.1+version: 0.19.2 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -60,7 +60,7 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.17+ base >= 4.9 && < 4.18 , bytestring >= 0.10.8.1 && < 0.12 , constraints >= 0.2 && < 0.14 , containers >= 0.5.7.1 && < 0.7@@ -72,8 +72,8 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.19- , http-api-data >= 0.4.1 && < 0.4.4+ servant >= 0.19 && < 0.20+ , http-api-data >= 0.4.1 && < 0.5.1 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions.@@ -159,7 +159,7 @@ build-depends: aeson >= 1.4.1.0 && < 3 , directory >= 1.3.0.0 && < 1.4- , hspec >= 2.6.0 && < 2.9+ , hspec >= 2.6.0 && < 2.10 , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2@@ -167,4 +167,4 @@ , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.9+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
src/Servant/Server.hs view
@@ -235,7 +235,7 @@ -- > │ └─ e/ -- > │ └─• -- > ├─ b/--- > │ └─ <capture>/+-- > │ └─ <x::Int>/ -- > │ ├─• -- > │ ┆ -- > │ └─•@@ -252,7 +252,8 @@ -- -- [@─•@] Leaves reflect endpoints. ----- [@\<capture\>/@] This is a delayed capture of a path component.+-- [@\<x::Int\>/@] This is a delayed capture of a single+-- path component named @x@, of expected type @Int@. -- -- [@\<raw\>@] This is a part of the API we do not know anything about. --
src/Servant/Server/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -94,6 +95,8 @@ import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, parseUrlPieces)+import Data.Kind+ (Type) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context@@ -173,7 +176,7 @@ -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ...-instance (KnownSymbol capture, FromHttpApiData a+instance (KnownSymbol capture, FromHttpApiData a, Typeable a , HasServer api context, SBoolI (FoldLenient mods) , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters )@@ -185,7 +188,7 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d =- CaptureRouter $+ CaptureRouter [hint] $ route (Proxy :: Proxy api) context (addCapture d $ \ txt -> withRequest $ \ request ->@@ -197,6 +200,7 @@ where rep = typeRep (Proxy :: Proxy Capture') formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a)) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a@@ -215,7 +219,7 @@ -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ...-instance (KnownSymbol capture, FromHttpApiData a+instance (KnownSymbol capture, FromHttpApiData a, Typeable a , HasServer api context , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters )@@ -227,7 +231,7 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d =- CaptureAllRouter $+ CaptureAllRouter [hint] $ route (Proxy :: Proxy api) context (addCapture d $ \ txts -> withRequest $ \ request ->@@ -238,6 +242,7 @@ where rep = typeRep (Proxy :: Proxy CaptureAll) formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a])) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead@@ -819,7 +824,11 @@ ------------------------------------------------------------------------------- -- Erroring instance for 'HasServer' when a combinator is not fully applied-instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context+instance TypeError (PartialApplication +#if __GLASGOW_HASKELL__ >= 904+ @(Type -> [Type] -> Constraint) +#endif+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context where type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr) route = error "unreachable"@@ -863,7 +872,11 @@ -- XXX: This omits the @context@ parameter, e.g.: -- -- "There is no instance for HasServer (Bool :> …)". Do we care ?-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub +#if __GLASGOW_HASKELL__ >= 904+ @(Type -> [Type] -> Constraint) +#endif+ HasServer ty) => HasServer (ty :> sub) context instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
src/Servant/Server/Internal/Router.hs view
@@ -9,12 +9,16 @@ import Data.Function (on)+import Data.List+ (nub) import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T+import Data.Typeable+ (TypeRep) import Network.Wai (Response, pathInfo) import Servant.Server.Internal.ErrorFormatter@@ -24,6 +28,18 @@ type Router env = Router' env RoutingApplication +data CaptureHint = CaptureHint+ { captureName :: Text+ , captureType :: TypeRep+ }+ deriving (Show, Eq)++toCaptureTag :: CaptureHint -> Text+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)++toCaptureTags :: [CaptureHint] -> Text+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"+ -- | Internal representation of a router. -- -- The first argument describes an environment type that is@@ -36,10 +52,10 @@ -- ^ the map contains routers for subpaths (first path component used -- for lookup and removed afterwards), the list contains handlers -- for the empty path, to be tried in order- | CaptureRouter (Router' (Text, env) a)+ | CaptureRouter [CaptureHint] (Router' (Text, env) a) -- ^ first path component is passed to the child router in its -- environment and removed afterwards- | CaptureAllRouter (Router' ([Text], env) a)+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a) -- ^ all path components are passed to the child router in its -- environment and are removed afterwards | RawRouter (env -> a)@@ -69,8 +85,8 @@ choice :: Router' env a -> Router' env a -> Router' env a choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)-choice (CaptureRouter router1) (CaptureRouter router2) =- CaptureRouter (choice router1 router2)+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2) choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 @@ -84,7 +100,7 @@ -- data RouterStructure = StaticRouterStructure (Map Text RouterStructure) Int- | CaptureRouterStructure RouterStructure+ | CaptureRouterStructure [CaptureHint] RouterStructure | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show)@@ -98,11 +114,11 @@ routerStructure :: Router' env a -> RouterStructure routerStructure (StaticRouter m ls) = StaticRouterStructure (fmap routerStructure m) (length ls)-routerStructure (CaptureRouter router) =- CaptureRouterStructure $+routerStructure (CaptureRouter hints router) =+ CaptureRouterStructure hints $ routerStructure router-routerStructure (CaptureAllRouter router) =- CaptureRouterStructure $+routerStructure (CaptureAllRouter hints router) =+ CaptureRouterStructure hints $ routerStructure router routerStructure (RawRouter _) = RawRouterStructure@@ -114,8 +130,8 @@ -- | Compare the structure of two routers. -- sameStructure :: Router' env a -> Router' env b -> Bool-sameStructure r1 r2 =- routerStructure r1 == routerStructure r2+sameStructure router1 router2 =+ routerStructure router1 == routerStructure router2 -- | Provide a textual representation of the -- structure of a router.@@ -126,7 +142,8 @@ where mkRouterLayout :: Bool -> RouterStructure -> [Text] mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n- mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)+ mkRouterLayout c (CaptureRouterStructure hints r) =+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ <raw>"] else ["└─ <raw>"] mkRouterLayout c (ChoiceStructure r1 r2) =@@ -169,7 +186,7 @@ -> let request' = request { pathInfo = rest } in runRouterEnv fmt router' env request' respond _ -> respond $ Fail $ fmt request- CaptureRouter router' ->+ CaptureRouter _ router' -> case pathInfo request of [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes.@@ -177,7 +194,7 @@ first : rest -> let request' = request { pathInfo = rest } in runRouterEnv fmt router' (first, env) request' respond- CaptureAllRouter router' ->+ CaptureAllRouter _ router' -> let segments = pathInfo request request' = request { pathInfo = [] } in runRouterEnv fmt router' (segments, env) request' respond
test/Servant/Server/RouterSpec.hs view
@@ -9,7 +9,9 @@ import Data.Proxy (Proxy (..)) import Data.Text- (unpack)+ (Text, unpack)+import Data.Typeable+ (typeRep) import Network.HTTP.Types (Status (..)) import Network.Wai@@ -27,6 +29,7 @@ spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec+ serverLayoutSpec routerSpec :: Spec routerSpec = do@@ -51,7 +54,7 @@ toApp = toApplication . runRouter (const err404) cap :: Router ()- cap = CaptureRouter $+ cap = CaptureRouter [hint] $ let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400) in leafRouter $ \env req res ->@@ -59,6 +62,9 @@ . const $ Route success + hint :: CaptureHint+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())+ router :: Router () router = leafRouter (\_ _ res -> res $ Route success) `Choice` cap@@ -98,12 +104,30 @@ it "properly handles mixing static paths at different levels" $ do level `shouldHaveSameStructureAs` levelRef +serverLayoutSpec :: Spec+serverLayoutSpec =+ describe "serverLayout" $ do+ it "correctly represents the example API" $ do+ exampleLayout `shouldHaveLayout` expectedExampleLayout+ it "aggregates capture hints when different" $ do+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes+ it "nubs capture hints when equal" $ do+ captureSameType `shouldHaveLayout` expectedCaptureSameType+ it "properly displays CaptureAll hints" $ do+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout+ shouldHaveSameStructureAs :: (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation shouldHaveSameStructureAs p1 p2 = unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) +shouldHaveLayout ::+ (HasServer api '[]) => Proxy api -> Text -> Expectation+shouldHaveLayout p l =+ unless (routerLayout (makeTrivialRouter p) == l) $+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))+ makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () makeTrivialRouter p = route p EmptyContext (emptyDelayed (FailFatal err501))@@ -144,12 +168,12 @@ -- structure: type Dynamic =- "a" :> Capture "foo" Int :> "b" :> End- :<|> "a" :> Capture "bar" Bool :> "c" :> End- :<|> "a" :> Capture "baz" Char :> "d" :> End+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "foo" Int :> "c" :> End+ :<|> "a" :> Capture "foo" Int :> "d" :> End type DynamicRef =- "a" :> Capture "anything" () :>+ "a" :> Capture "foo" Int :> ("b" :> End :<|> "c" :> End :<|> "d" :> End) dynamic :: Proxy Dynamic@@ -339,3 +363,100 @@ levelRef :: Proxy LevelRef levelRef = Proxy++-- The example API for the 'layout' function.+-- Should get factorized by the 'choice' smart constructor.+type ExampleLayout =+ "a" :> "d" :> Get '[JSON] NoContent+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool+ :<|> "c" :> Put '[JSON] Bool+ :<|> "a" :> "e" :> Get '[JSON] Int+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool+ :<|> Raw++exampleLayout :: Proxy ExampleLayout+exampleLayout = Proxy++-- The expected representation of the example API layout+--+expectedExampleLayout :: Text+expectedExampleLayout =+ "/\n\+ \├─ a/\n\+ \│ ├─ d/\n\+ \│ │ └─•\n\+ \│ └─ e/\n\+ \│ └─•\n\+ \├─ b/\n\+ \│ └─ <x::Int>/\n\+ \│ ├─•\n\+ \│ ┆\n\+ \│ └─•\n\+ \├─ c/\n\+ \│ └─•\n\+ \┆\n\+ \└─ <raw>\n"++-- A capture API with all capture types being the same+--+type CaptureSameType =+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "foo" Int :> "c" :> End+ :<|> "a" :> Capture "foo" Int :> "d" :> End++captureSameType :: Proxy CaptureSameType+captureSameType = Proxy++-- The expected representation of the CaptureSameType API layout.+--+expectedCaptureSameType :: Text+expectedCaptureSameType =+ "/\n\+ \└─ a/\n\+ \ └─ <foo::Int>/\n\+ \ ├─ b/\n\+ \ │ └─•\n\+ \ ├─ c/\n\+ \ │ └─•\n\+ \ └─ d/\n\+ \ └─•\n"++-- A capture API capturing different types+--+type CaptureDifferentTypes =+ "a" :> Capture "foo" Int :> "b" :> End+ :<|> "a" :> Capture "bar" Bool :> "c" :> End+ :<|> "a" :> Capture "baz" Char :> "d" :> End++captureDifferentTypes :: Proxy CaptureDifferentTypes+captureDifferentTypes = Proxy++-- The expected representation of the CaptureDifferentTypes API layout.+--+expectedCaptureDifferentTypes :: Text+expectedCaptureDifferentTypes =+ "/\n\+ \└─ a/\n\+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\+ \ ├─ b/\n\+ \ │ └─•\n\+ \ ├─ c/\n\+ \ │ └─•\n\+ \ └─ d/\n\+ \ └─•\n"++-- An API with a CaptureAll part++type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End++captureAllLayout :: Proxy CaptureAllLayout+captureAllLayout = Proxy++-- The expected representation of the CaptureAllLayout API.+--+expectedCaptureAllLayout :: Text+expectedCaptureAllLayout =+ "/\n\+ \└─ a/\n\+ \ └─ <foos::[Int]>/\n\+ \ └─•\n"