(* =================================== 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