attempt to express capabilities as a monad

caps.fsx

type RequestUser = 
    | Authenticated of id : int
    | Anonymouse

type UserEntity = {
    name : string
    isAdmin : bool
}
open System.Collections.Generic
type Db = Dictionary<int,UserEntity>

let dbSelect (db:Db) =
     seq{
        for kv in db do
            yield kv.Key, kv.Value
     }

let dbGetById (db:Db) id = 
    if db.ContainsKey id then Some(db.[id])
    else None

let dbDelete (db:Db) key = if db.ContainsKey key 
                           then db.Remove(key) |> ignore

let dbUpsert (db:Db) key value  = 
    if db.ContainsKey key then db.[key] <- value
    else db.Add(key,value)

type Context = {
    currentUser : RequestUser
    islocalTimeClockPresent : bool
    smtpServer : string option
    db : Db 
}

type CapRes<'a> = 
    | Ok of 'a
    | NotAuthenticated
    | NotAvailable
    | NotAuthorized
    | Error of string

type CapsM<'t> = Context ->  CapRes<'t>

let bind (v:CapsM<'t>) (f: 't -> CapsM<'t2>) : CapsM<'t2> =
        fun c ->
            match v c with
                | Ok(v) -> f v c
                | NotAuthenticated -> NotAuthenticated
                | NotAvailable -> NotAvailable
                | NotAuthorized -> NotAuthorized
                | Error(t) -> Error(t)
let (>>=) = bind
let ret v : CapsM<'t> = fun c -> Ok(v) 
let retRes v : CapsM<'t> = fun c -> v 
let getCtx : 'a -> CapsM<_> = fun _ -> fun ctx -> Ok(ctx)

type CapsBuilder()=
    member x.Bind(v,f) = bind v f
    member x.Return(v) : CapsM<'t> = ret v
    member x.ReturnFrom(v) = v
    member x.TryFinally(body: unit -> CapsM<'t>, compensation) : CapsM<'t> =
        fun c ->
            try 
                body () c
            finally 
                compensation() 

    member x.Using(disposable:#System.IDisposable, body) =
        let body' = fun () -> body disposable
        x.TryFinally(body', fun () -> 
            match disposable with 
                | null -> () 
                | disp -> disp.Dispose())

    member x.While(guard, body) =
        if (guard()) 
        then 
            x.Bind( body(), fun () -> 
                x.While(guard, body))  
        else
            x.Zero() 

    member x.For(sequence:seq<'a>, body:'a -> CapsM<_>) : CapsM<_> =
       x.Using(sequence.GetEnumerator(),fun enum -> 
            x.While(enum.MoveNext, 
                fun () -> body enum.Current))

    member x.Zero() = x.Return()

let caps = CapsBuilder()

let notAvailable () = retRes NotAvailable
let notAuthenticated () = retRes NotAuthenticated
let notAuthorized () = retRes NotAuthorized
let error txt = retRes (Error(txt))

let map f c = caps{
    let! x = c
    return f x
} 

let apply cap : CapsM<_>= cap >>= (fun f -> fun _ -> Ok(f ()))

let currentUserId = caps{
    let! c = getCtx()
    match c.currentUser with 
        | Authenticated(id) -> return fun () -> id
        | _ -> return! notAuthenticated ()
}



module Tokens =
    type Permisiion = 
        | Read = 1
        | UpSert = 2
        | Delete = 4

    type Token<'a>(id, ctx) =
         let getPermissions = caps{
                        let! uid = apply currentUserId
                        let u = dbGetById ctx.db uid
                        let! u = match u with
                                    | Some(u) -> ret u
                                    | None -> error "unable to get current user from db"
                        match (u.isAdmin, uid = id) with
                            | (true,_) -> return Permisiion.Read ||| Permisiion.UpSert ||| Permisiion.Delete
                            | (_,true) -> return Permisiion.Read ||| Permisiion.UpSert
                            | (_,_) -> return Permisiion.Read
                    } 
         let perms = getPermissions ctx
         member x.Check(perm) = caps{ 
                let! perms = retRes perms
                if perms.HasFlag(perm) 
                then return id
                else return! notAuthorized()
            }
         
    let getToken id = caps{
        let! c = getCtx()
        return Token(id,c)
     } 

    let checkPermission perm (token: Token<'a>) = token.Check perm



open Tokens

let getEntity token = caps{
    let! id = checkPermission Permisiion.Read token 
    let! c = getCtx()
    return fun () -> dbGetById c.db id
}

let updateEntity token =  caps{
    let! id = checkPermission Permisiion.UpSert token 
    let! c = getCtx()
    return fun e -> dbUpsert c.db id e
}
let deleteEntity token =  caps{
    let! id = checkPermission Permisiion.Delete token 
    let! c = getCtx()
    return fun e -> dbDelete c.db id
}

let evalToOption ctx sub = 
    match sub ctx with
        | Ok(v) -> Some(v)
        | _ -> None

let select perm = caps{
    let! c = getCtx()
    return fun () ->
                let all = dbSelect c.db
                seq{
                    for id,e in all do
                        yield getToken id >>= checkPermission perm 
                                          |> evalToOption c 
                                          |> Option.map (fun tkn -> tkn,e) 
                } |> Seq.choose id
} 

let smtpServer () = caps{
    let! c = getCtx()
    match c.smtpServer with 
        | Some(server) -> return fun () -> server
        | _ -> return! notAvailable ()
}

open System

let getTime () =caps{
    let! c = getCtx()
    if c.islocalTimeClockPresent 
    then return fun () -> DateTimeOffset.UtcNow
    else return! notAvailable ()
 }

let sendEmail = caps{
    let! server = smtpServer ()
    let! time = getTime ()
    return fun text ->
        let currTime = time()
        let currServer = server()
        printfn "sending email (%s:%A) : %s" currServer currTime text
} 

let sendEmailPrintEditable id = caps{
    let! currUser = apply currentUserId >>= getToken >>= getEntity |> apply
    let currUser = currUser |> Option.fold (fun _ x-> x) {name = "anonmouse"; isAdmin = false}
    let! user2readC = getToken id >>= getEntity
    let user2name = user2readC() |> Option.fold (fun _ x-> x.name) ""
    let! sendC = sendEmail
    sendC (sprintf "hello: from %s isadmin: %b to %s\n" currUser.name currUser.isAdmin user2name)
    let! selectAllowedToChangeC = select Permisiion.UpSert
    for id,e in selectAllowedToChangeC() do
        printfn "allowed %A" e
}
let createDb() =
    let db = Db()
    db.Add(0, { name = "admin"; isAdmin = true})
    db.Add(1, { name = "user1"; isAdmin = false})
    db.Add(2, { name = "user2"; isAdmin = false})
    db

let demoCtx user = 
    {
        currentUser = user
        islocalTimeClockPresent = true
        smtpServer = Some("some smtp server")
        db = createDb()
    }

let updateUser id name = caps{
    let! tkn = getToken id
    let! u =  getEntity tkn |> apply
    let u = u |> Option.map (fun x -> {x with name = name})
                    |> Option.fold (fun _ x-> x) {name = name; isAdmin = false}
    let! update = updateEntity tkn
    return update u
}

let tests = ["sendEmailPrintEditable", sendEmailPrintEditable 2;
             "updateUser", updateUser 2 "changedname"]

for name, test in tests do
    printfn "test - %s ------------------------" name
    for userid in createDb() |> dbSelect |> Seq.map fst do
        printfn "\n\nuser %d" userid
        test <| demoCtx (Authenticated(userid)) 
                                 |> printfn "result %A"

    printfn "\n\nanonym"
    test <| demoCtx Anonymouse 
                             |> printfn "result %A"

Interesting, thanks for sharing!