Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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