Code examples from fsharpforfunandprofit.com/posts/dependencies-5/
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (* =================================== | |
| 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