Merge pull request #1556 from nbacquey/router_layout_captures
Display capture hints in router layout
This commit is contained in:
Gaël Deest
GitHub
commit
65de6f701c
|
|
@ -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)
|
||||
```
|
||||
}
|
||||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -144,12 +168,12 @@ staticRef = Proxy
|
|||
-- 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 @@ 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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue