Haskell Legacy: Extracting business logic and introducing effects
Gautier DI FOLCO July 23, 2024 [Haskell] #haskell #design #legacy #polysemyOne of the issue of our API is the
direct implementation of the "business logic" (which is quite thin and coupled
to the persistence) directly in Handler
s.
It's quite problematic as, not only our tests are slow, but having everything (framework plumbing, business logic, persistence) at the same place is an issue:
- changing one thing might silently change another, e.g. changing persistence might affect business logic
- coupling degrades readability
- coupling will make maintenance and evolution costly
The first easy step is to go from all-at-once Handler
s:
= do
train <- runDB $ get404 trainId
bookings <- runDB $ selectList [BookingTrainId ==. trainId] []
returnJson $
DisplayTrainResponse
{ departureDate = train.trainDepartureDate,
departureStation = train.trainDepartureStation,
arrivalStation = train.trainArrivalStation,
travelers =
map
( \entity ->
TravelerRef
{ bookingId = entity.entityKey,
travelerName = entity.entityVal.bookingTravelerName
}
)
bookings
}
getDisplayTrainR trainId
To an Handler
dedicated to plumbing:
= do
booking <- requireCheckJsonBody @_ @CreateBookingRequest
bookingId <- bookingCreate trainId booking.travelerName
returnJson $ CreatedResponse bookingId
postCreateBookingR trainId
And a function dedicated to logic:
=
runDB $
insert400
Booking
{ bookingTrainId = trainId,
bookingTravelerName = travelerName
}
bookingCreate trainId travelerName
That's a start, the next step is to get out of HandlerFor
, so we can gain in
flexibility regarding the underlying implementation.
We can introduce an effect having a similar type definition:
data BookingEffect (m :: Type -> Type) (a :: Type) where
BookingCreate :: TrainId -> T.Text -> BookingEffect m BookingId
BookingDelete :: BookingId -> BookingEffect m ()
makeSem ''BookingEffect
Now we have an integration issue: working with polysemy
(the effects system library), will give you Sem r a
, while Yesod expects
HandlerFor TrainMasterAPI a
.
In order to simplify that, let's define some types, one for the effects we will use, another one for effect interpretation:
type APIEffects = '[TrainEffect, BookingEffect, Embed (ReaderT SqlBackend IO), Embed IO]
type EffectsRunner a = Sem APIEffects a -> HandlerFor TrainMasterAPI a
The most efficient way to pass it around (and to make it parameterizable) is to store it directly in the API configuration type:
data TrainMasterAPI = TrainMasterAPI (forall a. EffectsRunner a)
So, eventually, we can come up with a helper:
= do
TrainMasterAPI f <- getYesod
f sem
runEffect sem
We can then substitute it in the Handler
s:
= do
booking <- requireCheckJsonBody @_ @CreateBookingRequest
bookingId <- runEffect $ bookingCreate trainId booking.travelerName
returnJson $ CreatedResponse bookingId
deleteManageBookingR bookingId = do
runEffect $ bookingDelete bookingId
returnJson ()
postCreateBookingR trainId
Until now, I have left something aside: interpreters.
One of the benefit of effects systems is to be able to decouple interface/contract (the effect definition), from the implementations (interpreters).
Actually, interpreters are just the old logic we had extracted earlier:
=
interpret $
\case
BookingCreate trainId travelerName ->
embed @(ReaderT SqlBackend m) $
insert400
Booking
{ bookingTrainId = trainId,
bookingTravelerName = travelerName
}
BookingDelete bookingId ->
embed @(ReaderT SqlBackend m) $ delete bookingId
interpretBookingEffectPersistent
To be complete, let's write a composed interpreter for the whole API:
=
liftIO
. runM
. runEmbedded (flip runSqlPool pool)
. interpretBookingEffectPersistent
. interpretTrainEffectPersistent
runPersistent pool
So we can use it in the API launch:
=
runStderrLoggingT $
withSqlitePool "repl.db" openConnectionCount $ \pool -> liftIO $ do
runResourceT $ flip runSqlPool pool $ do
runMigration migrateAll
putStrLn "Listening on port 3000"
warp 3000 $ TrainMasterAPI $ runPersistent pool
main