Inferred dependency injection over async bindings.

Effect.fs

open System

[<Struct>] type Effect<'env, 'out> = Effect of ('env -> Async<'out>)

[<RequireQualifiedAccess>]
module Effect =

    /// Create value with no dependency requirements.
    let inline value (x: 'out): Effect<'env,'out> = Effect (fun _ -> async.Return x)
    /// Create value which uses depenendency.
    let inline apply (fn: 'env -> Async<'out>): Effect<'env,'out> = Effect fn
    let run (env: 'env) (Effect fn): Async<'out> = fn env
    let inline bind (fn: 'a -> Effect<'env,'b>) effect =
        Effect (fun env -> async {
            let! x = run env effect // compute result of the first effect
            return! run env (fn x) // run second effect, based on result of first one
        })
        
[<Struct>]
type EffectBuilder =
    member inline __.Return value = Effect.value value
    member inline __.Zero () = Effect.value (Unchecked.defaultof<_>)
    member inline __.ReturnFrom (effect: Effect<'env, 'out>) = effect
    member inline __.Bind(effect, fn) = Effect.bind fn effect
    
[<AutoOpen>]
module EffectExpression =    
    
    let effect = EffectBuilder()
    
module Demo =
    
    type User =
        { Id: int
          Name: string
          Hash: byte[]
          Salt: byte[] }
        
    type ChangePassword =
        { UserId: int
          OldPass: string
          NewPass: string }
    
    [<RequireQualifiedAccess>]
    type LogLevel =
        | Debug
        | Info
        | Warn
        | Error
    
    [<Interface>]
    type ILogger =
        abstract Log: level:LogLevel * line:string -> unit

    [<Interface>] type ILog = abstract Logger: ILogger

    [<RequireQualifiedAccess>]
    module Log =
        let private log level line = Effect.apply (fun (env: #ILog) -> async.Return (env.Logger.Log(level, line)))
        let debug fmt = Printf.kprintf (log LogLevel.Debug) fmt
        let info fmt = Printf.kprintf (log LogLevel.Info) fmt
        let warn fmt = Printf.kprintf (log LogLevel.Warn) fmt
        let error fmt = Printf.kprintf (log LogLevel.Error) fmt
        
    [<Interface>]
    type IDatabase =
        abstract Query: string * 'i -> Async<'o>
        abstract Execute: string * 'i -> Async<unit>
  
    [<Interface>] type IDb = abstract Database: IDatabase

    [<RequireQualifiedAccess>]
    module Db = 
        let fetchUser userId = Effect.apply <| fun (env: #IDb) -> 
            env.Database.Query("select * from users where user_id = @userId", {| userId = userId |})
        let updateUser user = Effect.apply <| fun (env: #IDb) ->
            env.Database.Execute("update users set name = @Name, hash = @Hash, salt = @Salt where user_id = @UserId", user)
    
    [<Interface>] type IRandom = abstract Random: Random
    
    [<RequireQualifiedAccess>]
    module Random =
        let bytes length = Effect.apply <| fun (env: #IRandom) ->
            let buf = Array.zeroCreate length 
            env.Random.NextBytes buf
            async.Return buf
        
    let bcrypt salt pass = failwith "not impl"
    
    // changePass: ChangePassword -> Effect<'a, Result<unit,string>> when 'a :> IDb and 'a :> ILog and 'a:> IRandom
    let changePass req = effect {
        let! user = Db.fetchUser req.UserId
        if user.Hash = bcrypt user.Salt req.OldPass then
            let! salt = Random.bytes 32
            do! Db.updateUser { user with Salt = salt; Hash = bcrypt salt req.NewPass }
            do! Log.info "Changed password for user %i" user.Id
            return Ok ()
        else 
            do! Log.error "Password change unauthorized: user %i" user.Id
            return Error "Old password is invalid"
    }