eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1556 from nbacquey/router_layout_captures

Browse source 
Display capture hints in router layout
This commit is contained in:
Gaël Deest 2022-03-25 10:42:33 +01:00 committed by GitHub
commit 65de6f701c
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 248 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
changelog.d/1556 Normal file
View file

@ -0,0 +1,81 @@
synopsis: Display capture hints in router layout
prs: #1556
description: {
This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.
Example:
For the following API
```haskell
type API =
"a" :> "d" :> Get '[JSON] NoContent
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
:<|> "a" :> "e" :> Get '[JSON] Int
```
we previously got the following output:
```
/
├─ a/
│ ├─ d/
│ │ └─•
│ └─ e/
│ └─•
└─ b/
└─ <capture>/
├─•
┆
└─•
```
now we get:
```
/
├─ a/
│ ├─ d/
│ │ └─•
│ └─ e/
│ └─•
└─ b/
└─ <x::Int>/
├─•
┆
└─•
```
This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.
CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
N.B.:
Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.
This PR also introduces Spec tests for the routerLayout function.
Warning:
This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.
In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
For instance, the following code will no longer compile:
```haskell
type MyAPI a = Capture "foo" a :> Get '[JSON] ()
myServer :: forall a. Server (MyAPI a)
myServer = const $ return ()
myApi :: forall a. Proxy (MyAPI a)
myApi = Proxy
app :: forall a. (FromHttpApiData a) => Application
app = serve (myApi @a) (myServer @a)
```
Indeed, `app` should be replaced with:
```haskell
app :: forall a. (FromHttpApiData a, Typeable a) => Application
app = serve (myApi @a) (myServer @a)
```
}

5
servant-server/src/Servant/Server.hs
View file

@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
-- > │ └─ e/
-- > │ └─•
-- > ├─ b/
-- > │ └─ <capture>/
-- > │ └─ <x::Int>/
-- > │ ├─•
-- > │ ┆
-- > │ └─•
@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
--
-- [@─•@] 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.
--

10
servant-server/src/Servant/Server/Internal.hs
View file

@ -173,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
-- > 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 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a
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 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a
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 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a
-- > 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 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a
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 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a
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

45
servant-server/src/Servant/Server/Internal/Router.hs
View file

@ -9,12 +9,16 @@ import Prelude.Compat
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 @@ import Servant.Server.Internal.ServerError
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 @@ data Router' env a =
-- ^ 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 @@ leafRouter l = StaticRouter M.empty [l]
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 @@ choice router1 router2 = Choice router1 router2
--
data RouterStructure =
StaticRouterStructure (Map Text RouterStructure) Int
| CaptureRouterStructure RouterStructure
| CaptureRouterStructure [CaptureHint] RouterStructure
| RawRouterStructure
| ChoiceStructure RouterStructure RouterStructure
deriving (Eq, Show)
@ -98,11 +114,11 @@ data RouterStructure =
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 @@ routerStructure (Choice r1 r2) =
-- | 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 @@ routerLayout router =
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 @@ runRouterEnv fmt router env request respond =
-> 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 @@ runRouterEnv fmt router env request respond =
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

131
servant-server/test/Servant/Server/RouterSpec.hs
View file

@ -9,7 +9,9 @@ import Control.Monad
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 :: Spec
spec = describe "Servant.Server.Internal.Router" $ do
routerSpec
distributivitySpec
serverLayoutSpec
routerSpec :: Spec
routerSpec = do
@ -51,7 +54,7 @@ routerSpec = do
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 @@ routerSpec = do
. 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 @@ distributivitySpec =
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))
@ -145,11 +169,11 @@ staticRef = Proxy
type Dynamic =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "bar" Bool :> "c" :> End
:<|> "a" :> Capture "baz" Char :> "d" :> 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 @@ level = Proxy
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"