Test-Driven Development Freedom
Gautier DI FOLCO August 13, 2023 [dev] #haskell #design #engineering #test-driven developmentIn My previous log I mentioned my bad intuition regarding code design.
Let's task a real-world example.
I have written my log on Caddy after working with Mercure, which was used to push updates to users.
In a nutshell, Mercure is a hub which exposes an API to push messages on topics, each topic being able to be subscribed to by client (users' browser).
At some point, we wanted to approximate the online users (and their current interests).
Each topic having the following shape: /foo/bar/baz
, we want to match partial topic (i.e. /topic/{topicId}/edit
).
Note that matcher and topic have to have the same length (i.e. /topic/{topicId}
matches /topic/42
, but not /topic/42/edit
).
Intuitively, we can set up the following types:
data Subscription = Subscription
{ id :: SubscriptionId,
}
deriving stock (Eq, Show)
newtype SubscriptionId
= SubscriptionId { getSubscriptionId :: Text }
deriving stock (Eq, Show)
newtype TopicPart
= TopicPart { getTopicPart :: Text }
deriving stock (Eq, Show)
newtype Topic
= Topic { getTopic :: [TopicPart] }
deriving stock (Eq, Show)
data TopicMatcherPart
= TMExact Text
| TMWildcard
deriving stock (Eq, Show)
newtype TopicMatcher
= TopicMatcher { getTopicMatcher :: [TopicMatcherPart] }
deriving stock (Eq, Show)
subscriptionsMatches ms s = undefined
Then, here is what I had in mind:
= any (flip subscriptionMatches s) ms
subscriptionMatches m s = any (topicMatches m) s.topics
topicMatches m t = length m.getTopicMatcher == length t.getTopic && and (zipWith match m.getTopicMatcher t.getTopic)
where match mp tp =
case mp of
TMExact e -> e == tp.getTopicPart
TMWildcard -> True
subscriptionsMatches ms s
It's a bit big, let's restart in Test driven development.
Let's set up our first test:
=
describe "Matcher" $ do
forM_
[ (["/"], ["/"], True)
]
$ \(matchers, topics, matches) ->
it (show matchers <> " ~= " <> show topics <> " => " <> show matches) $ do
let rawParts = tail . T.splitOn "/"
mkMatcherPart x = if x == "*" then TMWildcard else TMExact x
matchers' = TopicMatcher . map mkMatcherPart . rawParts <$> matchers
subscription' = Subscription (SubscriptionId "...") (Topic . map TopicPart . rawParts <$> topics)
subscriptionsMatches matchers' subscription' `shouldBe` matches
spec
it's red, we can pursue with a naive implementation:
= True
subscriptionsMatches ms s
Then with unmatching urls:
-- (["/a"], ["/b"], False)
subscriptionsMatches ms s = any (flip subscriptionMatches s) ms
subscriptionMatches m s = any (topicMatches m) s.topics
topicMatches m t = map matcherString m.getTopicMatcher == map (.getTopicPart) t.getTopic
where
matcherString =
\case
TMExact e -> e
TMWildcard -> "*"
A lot of heavy-lifting, as we are constrained by the types:
We can then add wildcards:
-- (["/a/*"], ["/a/c"], True)
topicMatches m t = and (zipWith match m.getTopicMatcher t.getTopic)
where
match mp tp =
case mp of
TMExact e -> e == tp.getTopicPart
TMWildcard -> True
Well, we nearly reached initial implementation, except, there's a regression now:
-- (["/a/*"], ["/a/c/e"], False)
topicMatches m t = length m.getTopicMatcher == length t.getTopic && and (zipWith match m.getTopicMatcher t.getTopic)
where
match mp tp =
case mp of
TMExact e -> e == tp.getTopicPart
TMWildcard -> True
We get back to our initial implementation, except, now we are able to make experiment.
Especially, we would like to find a function which only work when to "containers" have the same size:
After a quick look at Hoogle:
Let's try that:
= liftEq match m.getTopicMatcher t.getTopic
where
match mp tp =
case mp of
TMExact e -> e == tp.getTopicPart
TMWildcard -> True
topicMatches m t
Here we are, we got a neater implementation, focused on the matching, not the data-structures.
That's one of the reason I go on Type-Driven Design (TyDD), then Test-Driven Development (TeDD), doing so constrains my code so much, I can only write a correct implementation, then it comes to the actual implementation (at value-level), that's when TeDD comes into play.
Especially because our code can be wrong, let's replace any
by all
:
= all (flip subscriptionMatches s) ms
subscriptionMatches m s = all (topicMatches m) s.topics
subscriptionsMatches ms s
And our tests are still passing, let's fix this:
We can fix the matchers first:
-- (["/a/*", "/a/*/e"], ["/a/c/e"], True)
subscriptionsMatches ms s = any (flip subscriptionMatches s) ms
And finally the subscriptions:
-- (["/a/*"], ["/b", "/a/c"], True)
subscriptionMatches m s = any (topicMatches m) s.topics
Note: it's the kind of bug mutation testing aims to detect