Haskell Legacy: Testing
Gautier DI FOLCO July 16, 2024 [Haskell] #haskell #design #legacyIn the previous log, we have seen a legacy API to create trains and book/withdraw tickets.
Whenever I land in a new codebase I have to work on, I try to add some tests in order to stabilize the current behavior. So, if I break tests, I can make the conscious decision to change or keep the behavior.
The thing is, we have a code which is mainly dealing with IO
.
For reference, the API is launched like this:
=
runStderrLoggingT $
withSqlitePool "trainsMaster.db" openConnectionCount $ \pool -> liftIO $ do
runResourceT $ flip runSqlPool pool $ do
runMigration migrateAll
putStrLn "Listening on port 3000"
warp 3000 $ TrainMasterAPI pool
main
Hopefully Yesod comes with testing capabilities.
Similarly, we have to wrap our test cases
to provide an initialized site
(which is more or less a Yesod app):
runStderrLoggingT $
withSqlitePool ":memory:" openConnectionCount $ \pool -> liftIO $ do
runResourceT $ flip runSqlPool pool $ do
runMigration migrateAll
hspec $
yesodSpec (TrainMasterAPI pool) spec
SQLite is a great embedded SQL database, it usually work on a file, but
:memory:
create a purely in-memory database.
We can come up with two kind of test cases.
The nominal scenario:
- Creating a Train
- Make two bookings
- Withdrawing one
- Displaying the train
yit "Nominal case: creating a train, adding/withdraw reservation and looking up" $ do
postJson CreateTrainR CreateTrainRequest {departureDate = "2024-06-01", departureStation = "Lyon", arrivalStation = "Zurich"}
statusIs 200
trainCreation <- requireJSONResponse @(CreatedResponse (Key Train))
liftIO $ print trainCreation.id
postJson (CreateBookingR trainCreation.id) CreateBookingRequest {travelerName = "Alice"}
statusIs 200
traveler0Creation <- requireJSONResponse @(CreatedResponse (Key Booking))
postJson (CreateBookingR trainCreation.id) CreateBookingRequest {travelerName = "Bob"}
statusIs 200
traveler1Creation <- requireJSONResponse @(CreatedResponse (Key Booking))
deleteJson $ ManageBookingR traveler0Creation.id
statusIs 200
getJson $ DisplayTrainR trainCreation.id
statusIs 200
trainResponse <- requireJSONResponse @DisplayTrainResponse
assertEq
"Displayed train is valid"
trainResponse
DisplayTrainResponse
{ departureDate = "2024-06-01",
departureStation = "Lyon",
arrivalStation = "Zurich",
travelers =
[ TravelerRef
{ bookingId = traveler1Creation.id,
travelerName = "Bob"
}
]
}
And edge cases, when you deal with unknown trains.
yit "Edge case: booking an unknow train should fail" $ do
postJson (CreateBookingR $ TrainKey $ SqlBackendKey 42) CreateBookingRequest {travelerName = "Alice"}
statusIs 500
yit "Edge case: showing an unknow train should fail" $ do
getJson $ DisplayTrainR $ TrainKey $ SqlBackendKey 42
statusIs 500
Those one will change as error codes are neither explicit nor valid from an HTTP point of view (the semantic is invalid).
Note: If you are curious, you'll notice getJson
/postJson
/deleteJson
are
not defined in Yesod.Test
.
I think Yesod did not put RESTFul APIs (JSON-based ones at least) first, I had to come up with few helpers:
=
request $ do
setRequestBody (encode body)
addRequestHeader ("Accept", "application/json")
addRequestHeader ("Content-Type", "application/json")
setUrl route
setMethod "POST"
getJson = noBodyJson "GET"
deleteJson = noBodyJson "DELETE"
noBodyJson verb route =
request $ do
addRequestHeader ("Accept", "application/json")
addRequestHeader ("Content-Type", "application/json")
setUrl route
setMethod verb
postJson route body