Code examples from fsharpforfunandprofit.com/posts/dependencies-5/
(* =================================== | |
Code from my series of posts "Six approaches to dependency injection" | |
=================================== *) | |
open System | |
(* | |
## The requirements | |
Say that we have some kind of web app with users, and each user has a "profile" with their name, email, preferences, etc. | |
A use-case for updating their profile might be something like this: | |
1. Receive a new profile (parsed from a JSON request, say) | |
2. Read the user's current profile from the database | |
3. If the profile has changed, update the user's profile in the database | |
4. If the email has changed, send a verification email message to the user's new email | |
We will also add a little bit of logging into the mix. | |
*) | |
(* ====================================================================== | |
Common types used thoughout the examples | |
====================================================================== *) | |
module Domain = | |
type UserId = UserId of int | |
type UserName = string | |
type EmailAddress = EmailAddress of string | |
type Profile = { | |
UserId : UserId | |
Name : UserName | |
EmailAddress : EmailAddress | |
} | |
type EmailMessage = { | |
To : EmailAddress | |
Body : string | |
} | |
module Infrastructure = | |
open Domain | |
type ILogger = | |
abstract Info : string -> unit | |
abstract Error : string -> unit | |
type InfrastructureError = | |
| DbError of string | |
| SmtpError of string | |
type DbConnection = DbConnection of unit // dummy definition | |
type IDbService = | |
abstract NewDbConnection : | |
unit -> DbConnection | |
abstract QueryProfile : | |
DbConnection -> UserId -> Async<Result<Profile,InfrastructureError>> | |
abstract UpdateProfile : | |
DbConnection -> Profile -> Async<Result<unit,InfrastructureError>> | |
type SmtpCredentials = SmtpCredentials of unit // dummy definition | |
type IEmailService = | |
abstract SendChangeNotification : | |
SmtpCredentials -> EmailMessage -> Async<Result<unit,InfrastructureError>> | |
let globalLogger = {new ILogger with | |
member __.Info str = printfn "INFO %s" str | |
member __.Error str = printfn "ERROR %s" str | |
} | |
let defaultDbService = {new IDbService with | |
member __.NewDbConnection() = DbConnection() | |
member __.QueryProfile dbConnection (UserId userId) = | |
printfn "DB.QueryProfile: %A" userId | |
async { | |
let profile = { | |
UserId = UserId userId | |
Name = "" | |
EmailAddress = EmailAddress (sprintf "user%i@example.com" userId) | |
} | |
return Ok profile | |
} | |
member __.UpdateProfile dbConnection profileDto = | |
printfn "DB.UpdateProfile: %A" profileDto | |
async { | |
return Ok () | |
} | |
} | |
let defaultSmtpCredentials = SmtpCredentials() // dummy | |
let defaultEmailService = {new IEmailService with | |
member __.SendChangeNotification smtpCreditials emailMessage = | |
printfn "Email.SendEmailChangedNotification: %A" emailMessage | |
async { | |
return Ok () | |
} | |
} | |
(* ====================================================================== | |
Result library | |
====================================================================== *) | |
type AsyncResult<'Success,'Failure> = | |
Async<Result<'Success,'Failure>> | |
module AsyncResult = | |
/// Lift a function to AsyncResult | |
let map f (xAS:AsyncResult<_,_>) : AsyncResult<_,_> = | |
async { | |
let! x = xAS | |
return (Result.map f) x | |
} | |
/// Lift a value to AsyncResult | |
let retn x : AsyncResult<_,_> = | |
x |> Result.Ok |> async.Return | |
let bind (f: 'a -> AsyncResult<'b,'c>) (xAsyncResult : AsyncResult<_, _>) :AsyncResult<_,_> = async { | |
let! xResult = xAsyncResult | |
match xResult with | |
| Ok x -> return! f x | |
| Error err -> return (Error err) | |
} | |
[<AutoOpen>] | |
module AsyncResultComputationExpression = | |
type AsyncResultBuilder() = | |
member __.Return(x) = AsyncResult.retn x | |
member __.Bind(x, f) = AsyncResult.bind f x | |
member __.ReturnFrom(x) = x | |
member this.Zero() = this.Return () | |
member this.Combine (a:AsyncResult<_,_>, b:unit->AsyncResult<_,_>) = AsyncResult.bind b a | |
member this.Combine (a:AsyncResult<_,_>, b:AsyncResult<_,_>) = AsyncResult.bind (fun () -> b) a | |
member __.Delay(f) = async.Delay(f) | |
let asyncResult = AsyncResultBuilder() | |
(* ====================================================================== | |
Approach 1. Dependency Retention | |
====================================================================== *) | |
module test = | |
let step1() = async {return 1} | |
let step2 x = async {return ()} | |
let y = async { | |
let! x = step1() | |
if x > 0 then | |
do! step2 x | |
} | |
module DependencyRetention = | |
open Domain | |
open Infrastructure | |
// val updateCustomerProfile : newProfile:Domain.Profile -> AsyncResult<unit,Infrastructure.InfrastructureError> | |
let updateCustomerProfile (newProfile:Profile) :AsyncResult<unit,InfrastructureError> = | |
let dbConnection = defaultDbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
asyncResult { | |
let! currentProfile = defaultDbService.QueryProfile dbConnection newProfile.UserId | |
if currentProfile <> newProfile then | |
globalLogger.Info("Updating Profile") | |
do! defaultDbService.UpdateProfile dbConnection newProfile | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
globalLogger.Info("Sending email") | |
do! defaultEmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
(* ====================================================================== | |
Approach 2. Dependency Rejection | |
====================================================================== *) | |
module DependencyRejection = | |
open Domain | |
// ----------------------------------------------- | |
// Pure core | |
// ----------------------------------------------- | |
module Pure = | |
let globalLogger = Infrastructure.globalLogger | |
type Decision = | |
| NoAction | |
| UpdateProfileOnly of Profile | |
| UpdateProfileAndNotify of Profile * EmailMessage | |
// pure code, which is easy to test | |
// (assuming globalLogger is allowed) | |
let updateCustomerProfile (newProfile:Profile) (currentProfile:Profile) = | |
if currentProfile <> newProfile then | |
globalLogger.Info("Updating Profile") | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
globalLogger.Info("Sending email") | |
UpdateProfileAndNotify (newProfile, emailMessage) | |
else | |
UpdateProfileOnly newProfile | |
else | |
NoAction | |
// ----------------------------------------------- | |
// Impure shell | |
// ----------------------------------------------- | |
module Shell = | |
open Infrastructure | |
open Pure | |
// infrastructure services are hard-coded inline | |
let updateCustomerProfile (newProfile:Profile) :AsyncResult<unit,InfrastructureError> = | |
let dbConnection = defaultDbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
asyncResult { | |
// ----------- impure ---------------- | |
let! currentProfile = defaultDbService.QueryProfile dbConnection newProfile.UserId | |
// ----------- pure ---------------- | |
let decision = Pure.updateCustomerProfile newProfile currentProfile | |
// ----------- impure ---------------- | |
match decision with | |
| NoAction -> | |
() | |
| UpdateProfileOnly profile -> | |
do! defaultDbService.UpdateProfile dbConnection profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
do! defaultDbService.UpdateProfile dbConnection profile | |
do! defaultEmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
(* ====================================================================== | |
Approach 3. Dependency Parameterization | |
====================================================================== *) | |
module DependencyParameterization = | |
open Domain | |
// ----------------------------------------------- | |
// Pure core | |
// ----------------------------------------------- | |
module Pure = | |
type ILogger = Infrastructure.ILogger | |
type Decision = | |
| NoAction | |
| UpdateProfileOnly of Profile | |
| UpdateProfileAndNotify of Profile * EmailMessage | |
let updateCustomerProfile (logger:ILogger) (newProfile:Profile) (currentProfile:Profile) = | |
if currentProfile <> newProfile then | |
logger.Info("Updating Profile") | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
logger.Info("Sending email") | |
UpdateProfileAndNotify (newProfile, emailMessage) | |
else | |
UpdateProfileOnly newProfile | |
else | |
NoAction | |
// ----------------------------------------------- | |
// Impure shell | |
// ----------------------------------------------- | |
module Shell = | |
open Infrastructure | |
open Pure | |
type IServices = { | |
Logger : ILogger | |
DbService : IDbService | |
EmailService : IEmailService | |
} | |
// Uses infrastructure but all interfaces are passed in as parameters | |
// This is easy to mock, or to change infrastructure implementation | |
let updateCustomerProfile (services:IServices) (newProfile:Profile) :AsyncResult<unit,InfrastructureError> = | |
let dbConnection = services.DbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
let logger = services.Logger | |
asyncResult { | |
// ----------- Impure ---------------- | |
let! currentProfile = services.DbService.QueryProfile dbConnection newProfile.UserId | |
// ----------- pure ---------------- | |
let decision = Pure.updateCustomerProfile logger newProfile currentProfile | |
// ----------- Impure ---------------- | |
match decision with | |
| NoAction -> | |
() | |
| UpdateProfileOnly profile -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
do! services.EmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
/// Top-level "composition root" | |
let updateCustomerProfileApi (newProfile:Profile) = | |
let services = { | |
Logger = globalLogger | |
DbService = defaultDbService | |
EmailService = defaultEmailService | |
} | |
updateCustomerProfile services newProfile | |
(* ====================================================================== | |
Approach 4. Dependency Injection -- OO Style | |
====================================================================== *) | |
module DependencyInjection = | |
open Domain | |
// ----------------------------------------------- | |
// Pure core | |
// ----------------------------------------------- | |
module Pure = | |
type ILogger = Infrastructure.ILogger | |
type Decision = | |
| NoAction | |
| UpdateProfileOnly of Profile | |
| UpdateProfileAndNotify of Profile * EmailMessage | |
let updateCustomerProfile (logger:ILogger) (newProfile:Profile) (currentProfile:Profile) = | |
if currentProfile <> newProfile then | |
logger.Info("Updating Profile") | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
logger.Info("Sending email") | |
UpdateProfileAndNotify (newProfile, emailMessage) | |
else | |
UpdateProfileOnly newProfile | |
else | |
NoAction | |
// ----------------------------------------------- | |
// Impure shell | |
// ----------------------------------------------- | |
module Shell = | |
open Infrastructure | |
open Pure | |
type IServices = { | |
Logger : ILogger | |
DbService : IDbService | |
EmailService : IEmailService | |
} | |
// define a class with a constructor that accepts the dependencies | |
type MyWorkflow (services:IServices) = | |
member this.UpdateCustomerProfile (newProfile:Profile) = | |
let dbConnection = services.DbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
let logger = services.Logger | |
asyncResult { | |
// ----------- Impure ---------------- | |
let! currentProfile = services.DbService.QueryProfile dbConnection newProfile.UserId | |
// ----------- pure ---------------- | |
let decision = Pure.updateCustomerProfile logger newProfile currentProfile | |
// ----------- Impure ---------------- | |
match decision with | |
| NoAction -> | |
() | |
| UpdateProfileOnly profile -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
do! services.EmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
/// Top-level "composition root" | |
let updateCustomerProfileApi (newProfile:Profile) = | |
let services = { | |
Logger = globalLogger | |
DbService = defaultDbService | |
EmailService = defaultEmailService | |
} | |
let myWorkflow = MyWorkflow(services) | |
myWorkflow.UpdateCustomerProfile newProfile | |
(* ====================================================================== | |
Approach 4b. Dependency Injection -- Reader style | |
====================================================================== *) | |
type Reader<'env,'a> = Reader of action:('env -> 'a) | |
module Reader = | |
/// Run a Reader with a given environment | |
let run env (Reader action) = | |
action env // simply call the inner function | |
/// Create a Reader which returns the environment itself | |
let ask = Reader id | |
/// Map a function over a Reader | |
let map f reader = | |
Reader (fun env -> f (run env reader)) | |
/// flatMap a function over a Reader | |
let bind f reader = | |
let newAction env = | |
let x = run env reader | |
run env (f x) | |
Reader newAction | |
/// Transform a Reader's environment. | |
/// Known as `withReader` in Haskell | |
let withEnv (f:'env2->'env1) reader = | |
Reader (fun env' -> (run (f env') reader)) | |
[<AutoOpen>] | |
module ReaderCE = | |
type ReaderBuilder() = | |
member __.Return(x) = Reader (fun _ -> x) | |
member __.Bind(x,f) = Reader.bind f x | |
member __.Zero() = Reader (fun _ -> ()) | |
member this.Combine (a,b) = Reader.bind b a | |
// the builder instance | |
let reader = ReaderBuilder() | |
module ReaderInjection = | |
open Domain | |
// ----------------------------------------------- | |
// Pure core | |
// ----------------------------------------------- | |
module Pure = | |
type ILogger = Infrastructure.ILogger | |
type Decision = | |
| NoAction | |
| UpdateProfileOnly of Profile | |
| UpdateProfileAndNotify of Profile * EmailMessage | |
let updateCustomerProfile (newProfile:Profile) (currentProfile:Profile) :Reader<ILogger,Decision> = | |
reader { | |
let! (logger:ILogger) = Reader.ask | |
let decision = | |
if currentProfile <> newProfile then | |
logger.Info("Updating Profile") | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
logger.Info("Sending email") | |
UpdateProfileAndNotify (newProfile, emailMessage) | |
else | |
UpdateProfileOnly newProfile | |
else | |
NoAction | |
return decision | |
} | |
// ----------------------------------------------- | |
// Impure shell WITHOUT using Reader for top-level IO | |
// ----------------------------------------------- | |
module Shell_v1 = | |
open Infrastructure | |
open Pure | |
type IServices = { | |
Logger : ILogger | |
DbService : IDbService | |
EmailService : IEmailService | |
} | |
// Infrastructure services are passed in as a parameter | |
let updateCustomerProfile (services:IServices) (newProfile:Profile) :AsyncResult<unit,InfrastructureError> = | |
let dbConnection = services.DbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
let logger = services.Logger | |
asyncResult { | |
// ----------- impure ---------------- | |
let! currentProfile = services.DbService.QueryProfile dbConnection newProfile.UserId | |
// ----------- pure ---------------- | |
let decision = | |
Pure.updateCustomerProfile newProfile currentProfile | |
|> Reader.run logger | |
// ----------- impure ---------------- | |
match decision with | |
| NoAction -> | |
() | |
| UpdateProfileOnly profile -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
do! services.EmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
/// Top-level "composition root" | |
let updateCustomerProfileApi (newProfile:Profile) = | |
let services = { | |
Logger = globalLogger | |
DbService = defaultDbService | |
EmailService = defaultEmailService | |
} | |
updateCustomerProfile services newProfile | |
// ----------------------------------------------- | |
// Impure shell using Reader for top-level I/O | |
// ----------------------------------------------- | |
module Shell_v2 = | |
open Infrastructure | |
open Pure | |
type IServices = { | |
Logger : ILogger | |
DbService : IDbService | |
EmailService : IEmailService | |
} | |
// first step in our mini-app | |
let getProfile (userId:UserId) :Reader<IServices, AsyncResult<Profile,InfrastructureError>> = | |
reader { | |
let! (services:IServices) = Reader.ask | |
let dbConnection = services.DbService.NewDbConnection() | |
return services.DbService.QueryProfile dbConnection userId | |
} | |
// last step in our mini-app | |
let handleDecision (decision:Decision) :Reader<IServices, AsyncResult<unit,InfrastructureError>> = | |
reader { | |
let! (services:IServices) = Reader.ask | |
let dbConnection = services.DbService.NewDbConnection() | |
let smtpCredentials = defaultSmtpCredentials | |
let action = asyncResult { | |
match decision with | |
| NoAction -> | |
() | |
| UpdateProfileOnly profile -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
do! services.DbService.UpdateProfile dbConnection profile | |
do! services.EmailService.SendChangeNotification smtpCredentials emailMessage | |
} | |
return action | |
} | |
// Infrastructure services are passed in via a Reader | |
let updateCustomerProfile (newProfile:Profile) = | |
reader { | |
let! (services:IServices) = Reader.ask | |
let getLogger services = services.Logger | |
return asyncResult { | |
// ----------- impure ---------------- | |
let! currentProfile = | |
getProfile newProfile.UserId | |
|> Reader.run services | |
// ----------- pure ---------------- | |
let decision = | |
Pure.updateCustomerProfile newProfile currentProfile | |
|> Reader.withEnv getLogger | |
|> Reader.run services | |
// ----------- impure ---------------- | |
do! (handleDecision decision) |> Reader.run services | |
} | |
} | |
/// Top-level "composition root" | |
let updateCustomerProfileApi (newProfile:Profile) = | |
let services = { | |
Logger = globalLogger | |
DbService = defaultDbService | |
EmailService = defaultEmailService | |
} | |
(updateCustomerProfile newProfile) | |
|> Reader.run services | |
(* ====================================================================== | |
Approach 5. Dependency Interpretation | |
====================================================================== *) | |
//---------------------------------------- | |
// A generic program that does not know about specific instructions | |
//---------------------------------------- | |
module GenericProgram = | |
// 1. Define a instruction interface that contains a "map" | |
type IInstruction<'a> = | |
abstract member Map : ('a->'b) -> IInstruction<'b> | |
// 2, Use the interface in the Program type | |
type Program<'a> = | |
| Instruction of IInstruction<Program<'a>> | |
| Stop of 'a | |
// 3. Define the corresponding "bind" | |
module Program = | |
let rec bind f program = | |
match program with | |
| Instruction inst -> | |
inst.Map (bind f) |> Instruction | |
| Stop x -> f x | |
// 4. Define the computation expression | |
type ProgramBuilder() = | |
member __.Return(x) = Stop x | |
member __.ReturnFrom(x) = x | |
member __.Bind(x,f) = Program.bind f x | |
member __.Zero() = Stop () | |
member this.Combine (a:Program<_>, b:unit->Program<_>) = Program.bind b a | |
member this.Combine (a:Program<_>, b:Program<_>) = Program.bind (fun () -> b) a | |
// and the builder instance | |
let program = ProgramBuilder() | |
//---------------------------------------- | |
// A specific program based on the common requirements | |
//---------------------------------------- | |
module DependencyInterpretation = | |
open Domain | |
open GenericProgram | |
// ----------------------------------------------- | |
// Instructions used in the pure core | |
// ----------------------------------------------- | |
module PureInstructions = | |
type LoggerInstruction<'a> = | |
| LogInfo of string * next:(unit -> 'a) | |
| LogError of string * next:(unit -> 'a) | |
interface IInstruction<'a> with | |
member this.Map f = | |
match this with | |
| LogInfo (str,next) -> | |
LogInfo (str,next >> f) | |
| LogError (str,next) -> | |
LogError (str,next >> f) | |
:> IInstruction<_> | |
// helpers to use within the computation expression | |
let logInfo str = Instruction (LogInfo (str,Stop)) | |
let logError str = Instruction (LogError (str,Stop)) | |
// ----------------------------------------------- | |
// Pure core | |
// ----------------------------------------------- | |
module Pure = | |
open PureInstructions | |
type Decision = | |
| NoAction | |
| UpdateProfileOnly of Profile | |
| UpdateProfileAndNotify of Profile * EmailMessage | |
let updateCustomerProfile (newProfile:Profile) (currentProfile:Profile) :Program<Decision> = | |
if currentProfile <> newProfile then program { | |
do! logInfo("Updating Profile") | |
if currentProfile.EmailAddress <> newProfile.EmailAddress then | |
let emailMessage = { | |
To = newProfile.EmailAddress | |
Body = "Please verify your email" | |
} | |
do! logInfo("Sending email") | |
return UpdateProfileAndNotify (newProfile, emailMessage) | |
else | |
return UpdateProfileOnly newProfile | |
} | |
else program { | |
return NoAction | |
} | |
// ----------------------------------------------- | |
// Instructions used in the impure shell | |
// ----------------------------------------------- | |
module ImpureInstructions = | |
// 1. Define the set of instructions we want to support, and their map | |
type DbInstruction<'a> = | |
| QueryProfile of UserId * next:(Profile -> 'a) | |
| UpdateProfile of Profile * next:(unit -> 'a) | |
interface IInstruction<'a> with | |
member this.Map f = | |
match this with | |
| QueryProfile (userId,next) -> | |
QueryProfile (userId,next >> f) | |
| UpdateProfile (profile,next) -> | |
UpdateProfile (profile, next >> f) | |
:> IInstruction<_> | |
type EmailInstruction<'a> = | |
| SendChangeNotification of EmailMessage * next:(unit-> 'a) | |
interface IInstruction<'a> with | |
member this.Map f = | |
match this with | |
| SendChangeNotification (message,next) -> | |
SendChangeNotification (message,next >> f) | |
:> IInstruction<_> | |
// helpers to use within the computation expression | |
let queryProfile userId = Instruction (QueryProfile(userId,Stop)) | |
let updateProfile profile = Instruction (UpdateProfile(profile,Stop)) | |
let sendChangeNotification message = Instruction (SendChangeNotification(message,Stop)) | |
// ----------------------------------------------- | |
// Impure shell | |
// ----------------------------------------------- | |
module Shell = | |
open Pure | |
open ImpureInstructions | |
let getProfile (userId:UserId) :Program<Profile> = | |
program { | |
return! queryProfile userId | |
} | |
let handleDecision (decision:Decision) :Program<unit> = | |
match decision with | |
| NoAction -> | |
program.Zero() | |
| UpdateProfileOnly profile -> | |
updateProfile profile | |
| UpdateProfileAndNotify (profile,emailMessage) -> | |
program { | |
do! updateProfile profile | |
do! sendChangeNotification emailMessage | |
} | |
let updateCustomerProfile (newProfile:Profile) = | |
program { | |
let! currentProfile = getProfile newProfile.UserId | |
let! decision = Pure.updateCustomerProfile newProfile currentProfile | |
do! handleDecision decision | |
} | |
// ----------------------------------------------- | |
// The interpreter | |
// ----------------------------------------------- | |
module Interpreter = | |
open PureInstructions | |
open ImpureInstructions | |
open Infrastructure | |
// modular interpreter for LoggerInstruction | |
let interpretLogger interpret inst = | |
match inst with | |
| LogInfo (str, next) -> | |
globalLogger.Info str | |
let newProgramAS = next() |> asyncResult.Return | |
interpret newProgramAS | |
| LogError (str, next) -> | |
globalLogger.Error str | |
let newProgramAS = next() |> asyncResult.Return | |
interpret newProgramAS | |
// modular interpreter for DbInstruction | |
let interpretDbInstruction (dbConnection:DbConnection) interpret inst = | |
match inst with | |
| QueryProfile (userId, next) -> | |
let profileAS = defaultDbService.QueryProfile dbConnection userId | |
let newProgramAS = (AsyncResult.map next) profileAS | |
interpret newProgramAS // returns an :AsyncResult<'a,InfrastructureError> | |
| UpdateProfile (profile, next) -> | |
let unitAS = defaultDbService.UpdateProfile dbConnection profile | |
let newProgramAS = (AsyncResult.map next) unitAS | |
interpret newProgramAS | |
// modular interpreter for EmailInstruction | |
let interpretEmailInstruction (smtpCredentials:SmtpCredentials) interpret inst = | |
match inst with | |
| SendChangeNotification (message, next) -> | |
let unitAS = defaultEmailService.SendChangeNotification smtpCredentials message | |
let newProgramAS = (AsyncResult.map next) unitAS | |
interpret newProgramAS | |
let interpret program = | |
// 1. get the extra parameters and partially apply them to make all the interpreters | |
// have a consistent shape | |
let smtpCredentials = defaultSmtpCredentials | |
let dbConnection = defaultDbService.NewDbConnection() | |
let interpretDbInstruction' = interpretDbInstruction dbConnection | |
let interpretEmailInstruction' = interpretEmailInstruction smtpCredentials | |
// 2. define a recursive loop function. It has signature: | |
// AsyncResult<Program<'a>,InfrastructureError>) -> AsyncResult<'a,InfrastructureError> | |
let rec loop programAS = | |
asyncResult { | |
let! program = programAS | |
return! | |
match program with | |
| Instruction inst -> | |
match inst with | |
| :? LoggerInstruction<Program<_>> as inst -> interpretLogger loop inst | |
| :? DbInstruction<Program<_>> as inst -> interpretDbInstruction' loop inst | |
| :? EmailInstruction<Program<_>> as inst -> interpretEmailInstruction' loop inst | |
| _ -> failwithf "unknown instruction type %O" (inst.GetType()) | |
| Stop value -> | |
value |> asyncResult.Return | |
} | |
// 3. start the loop | |
let initialProgram = program |> asyncResult.Return | |
loop initialProgram | |
/// Top-level "composition root" | |
let updateCustomerProfileApi (newProfile:Profile) = | |
Shell.updateCustomerProfile newProfile | |
|> interpret | |
|> Async.RunSynchronously | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment