Skip to content

Commit

Permalink
Merge pull request #1556 from nbacquey/router_layout_captures
Browse files Browse the repository at this point in the history
Display capture hints in router layout
  • Loading branch information
Gaël Deest authored Mar 25, 2022
2 parents f5a91d2 + a19cb84 commit 65de6f7
Show file tree
Hide file tree
Showing 5 changed files with 248 additions and 26 deletions.
81 changes: 81 additions & 0 deletions changelog.d/1556
Original file line number Diff line number Diff line change
@@ -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 changes: 3 additions & 2 deletions servant-server/src/Servant/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
-- > │ └─ e/
-- > │ └─•
-- > ├─ b/
-- > │ └─ <capture>/
-- > │ └─ <x::Int>/
-- > │ ├─•
-- > │ ┆
-- > │ └─•
Expand All @@ -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.
--
Expand Down
10 changes: 6 additions & 4 deletions servant-server/src/Servant/Server/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
)
Expand All @@ -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 ->
Expand All @@ -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
Expand All @@ -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
)
Expand All @@ -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 ->
Expand All @@ -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
Expand Down
45 changes: 31 additions & 14 deletions servant-server/src/Servant/Server/Internal/Router.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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

Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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.
Expand All @@ -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) =
Expand Down Expand Up @@ -169,15 +186,15 @@ 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.
[""] -> respond $ Fail $ fmt request
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
Expand Down
Loading

0 comments on commit 65de6f7

Please sign in to comment.