Examples of capability based design. Related blog post: http://fsharpforfunandprofit.com/posts/capability-based-security/

CapabilityBasedSecurity_ConfigExample.fsx

(*
CapabilityBasedSecurity_ConfigExample.fsx

An example of a simple capability-based design.

Related blog post: http://fsharpforfunandprofit.com/posts/capability-based-security/
*)
 
/// Configuration system
module Config =

    type MessageFlag  = ShowThisMessageAgain | DontShowThisMessageAgain
    type ConnectionString = ConnectionString of string
    type Color = System.Drawing.Color

    type ConfigurationCapabilities = {
        GetMessageFlag : unit -> MessageFlag 
        SetMessageFlag : MessageFlag -> unit
        GetBackgroundColor : unit -> Color 
        SetBackgroundColor : Color -> unit
        GetConnectionString  : unit -> ConnectionString 
        SetConnectionString : ConnectionString -> unit
        }

    // a private store for demo purposes
    module private ConfigStore =
        let mutable MessageFlag = ShowThisMessageAgain 
        let mutable BackgroundColor = Color.White
        let mutable ConnectionString = ConnectionString ""

    // public capabilities
    let configurationCapabilities = {
        GetMessageFlag = fun () -> ConfigStore.MessageFlag 
        SetMessageFlag = fun flag -> ConfigStore.MessageFlag <- flag
        GetBackgroundColor = fun () -> ConfigStore.BackgroundColor
        SetBackgroundColor = fun color -> ConfigStore.BackgroundColor <- color
        GetConnectionString = fun () -> ConfigStore.ConnectionString 
        SetConnectionString = fun connStr -> ConfigStore.ConnectionString <- connStr
        }

/// Logic for constructing an annoying popup message dialog everytime you click the main form
module AnnoyingPopupMessage = 
    open System.Windows.Forms
   
    let createLabel() = 
        new Label(Text="You clicked the main window", Dock=DockStyle.Top)

    let createMessageFlagCheckBox capabilities  = 
        let getFlag,setFlag = capabilities 
        let ctrl= new CheckBox(Text="Don't show this annoying message again", Dock=DockStyle.Bottom)
        ctrl.Checked <- getFlag()
        ctrl.CheckedChanged.Add (fun _ -> ctrl.Checked |> setFlag)
        ctrl    // return new control

    let createOkButton (dialog:Form) = 
        let ctrl= new Button(Text="OK",Dock=DockStyle.Bottom)
        ctrl.Click.Add (fun _ -> dialog.Close())
        ctrl

    let createForm capabilities = 
        let form = new Form(Text="Annoying Popup Message", Width=300, Height=150)
        form.FormBorderStyle <- FormBorderStyle.FixedDialog
        form.StartPosition <- FormStartPosition.CenterParent

        let label = createLabel()
        let messageFlag = createMessageFlagCheckBox capabilities
        let okButton = createOkButton form
        form.Controls.Add label 
        form.Controls.Add messageFlag 
        form.Controls.Add okButton 
        form

module UserInterface = 
    open System.Windows.Forms
    open System.Drawing

    let showPopupMessage capabilities owner = 
        let getFlag,setFlag = capabilities 
        let popupMessage = AnnoyingPopupMessage.createForm (getFlag,setFlag) 
        popupMessage.Owner <- owner 
        popupMessage.ShowDialog() |> ignore // don't care about result

    let showColorDialog capabilities owner = 
        let getColor,setColor = capabilities 
        let dlg = new ColorDialog(Color=getColor())
        let result = dlg.ShowDialog(owner)
        if result = DialogResult.OK then
            dlg.Color |> setColor

    let createClickMeLabel capabilities owner = 
        let getFlag,_ = capabilities 
        let ctrl= new Label(Text="Click me", Dock=DockStyle.Fill, TextAlign=ContentAlignment.MiddleCenter)
        ctrl.Click.Add (fun _ -> 
            if getFlag() then showPopupMessage capabilities owner)
        ctrl      // return new control

    let createChangeBackColorButton capabilities owner = 
        let ctrl= new Button(Text="Change background color", Dock=DockStyle.Bottom)
        ctrl.Click.Add (fun _ -> showColorDialog capabilities owner)
        ctrl

    let createResetMessageFlagButton capabilities = 
        let setFlag = capabilities 
        let ctrl= new Button(Text="Show popup message again", Dock=DockStyle.Bottom)
        ctrl.Click.Add (fun _ -> setFlag Config.ShowThisMessageAgain)
        ctrl 

    let createMainForm capabilities = 
        // get the individual component capabilities from the parameter
        let getFlag,setFlag,getColor,setColor = capabilities 

        let form = new Form(Text="Capability example", Width=500, Height=300)
        form.BackColor <- getColor() // update the form from the config

        // transform color capability to change form as well
        let newSetColor color = 
            setColor color           // change config
            form.BackColor <- color  // change form as well  

        // transform flag capabilities from domain type to bool
        let getBoolFlag() = 
            getFlag() = Config.ShowThisMessageAgain 
        let setBoolFlag bool = 
            if bool 
            then setFlag Config.ShowThisMessageAgain 
            else setFlag Config.DontShowThisMessageAgain 

        // set up capabilities for child objects
        let colorDialogCapabilities = getColor,newSetColor 
        let popupMessageCapabilities = getBoolFlag,setBoolFlag

        // setup controls with their different capabilities
        let clickMeLabel = createClickMeLabel popupMessageCapabilities form
        let changeColorButton = createChangeBackColorButton colorDialogCapabilities form
        let resetFlagButton = createResetMessageFlagButton setFlag 

        // add controls
        form.Controls.Add clickMeLabel 
        form.Controls.Add changeColorButton
        form.Controls.Add resetFlagButton 

        form  // return form

module Startup = 

    // set up capabilities
    let configCapabilities = Config.configurationCapabilities
    let formCapabilities = 
        configCapabilities.GetMessageFlag, 
        configCapabilities.SetMessageFlag,
        configCapabilities.GetBackgroundColor,
        configCapabilities.SetBackgroundColor

    // start
    let form = UserInterface.createMainForm formCapabilities 
    form.ShowDialog() |> ignore

    // open another form and the config is remembered
    //form.ShowDialog() |> ignore

CapabilityBasedSecurity_ConsoleExample.fsx

(*
CapabilityBasedSecurity_ConsoleExample.fsx

An example of a capability-based console application that also includes authorization.

Related blog post: http://fsharpforfunandprofit.com/posts/capability-based-security-2/
*)

open System.Security.Principal
open System

// ================================================
// A complete console application demonstrating capabilities
// ================================================

module Rop = 
    type SuccessFailure<'a,'b> = 
        | Success of 'a
        | Failure of 'b

    let bind f = function
        | Success x -> f x
        | Failure e -> Failure e 

    let map f = function
        | Success x -> Success (f x)
        | Failure e -> Failure e 

    let orElse errValue = function
        | Success x -> x
        | Failure _ -> errValue

/// Core domain types shares across the application
module Domain = 
    open Rop

    type CustomerId = CustomerId of int
    type CustomerData = CustomerData of string
    type Password = Password of string

    type FailureCase = 
        | AuthenticationFailed of string
        | AuthorizationFailed
        | CustomerNameNotFound of string
        | CustomerIdNotFound of CustomerId
        | OnlyAllowedOnce
        | CapabilityRevoked

// ----------------------------------------------

/// Capabilities that are available in the application
module Capabilities = 
    open Rop
    open Domain

    // capabilities
    type GetCustomerCap = unit -> SuccessFailure<CustomerData,FailureCase>
    type UpdateCustomerCap = unit -> CustomerData -> SuccessFailure<unit,FailureCase>
    type UpdatePasswordCap = Password -> SuccessFailure<unit,FailureCase>

    type CapabilityProvider = {
        /// given a customerId and IPrincipal, attempt to get the GetCustomer capability
        getCustomer : CustomerId -> IPrincipal -> GetCustomerCap option
        /// given a customerId and IPrincipal, attempt to get the UpdateCustomer capability
        updateCustomer : CustomerId -> IPrincipal -> UpdateCustomerCap option
        /// given a customerId and IPrincipal, attempt to get the UpdatePassword capability
        updatePassword : CustomerId -> IPrincipal -> UpdatePasswordCap option 
        }

                
// ----------------------------------------------

/// Functions related to authentication
module Authentication = 
    open Rop
    open Domain 

    let customerRole = "Customer"
    let customerAgentRole = "CustomerAgent"

    let makePrincipal name role = 
        let iden = GenericIdentity(name)
        let principal = GenericPrincipal(iden,[|role|])
        principal :> IPrincipal

    let authenticate name = 
        match name with
        | "Alice" | "Bob" -> 
            makePrincipal name customerRole  |> Success
        | "Zelda" -> 
            makePrincipal name customerAgentRole |> Success
        | _ -> 
            AuthenticationFailed name |> Failure 

    let customerIdForName name = 
        match name with
        | "Alice" -> CustomerId 1 |> Success
        | "Bob" -> CustomerId 2 |> Success
        | _ -> CustomerNameNotFound name |> Failure

    let customerIdOwnedByPrincipal customerId (principle:IPrincipal) = 
        principle.Identity.Name
        |> customerIdForName 
        |> Rop.map (fun principalId -> principalId = customerId)
        |> Rop.orElse false

// ----------------------------------------------

/// Functions related to authorization
module Authorization = 
    open Rop
    open Domain 

    let onlyForSameId (id:CustomerId) (principal:IPrincipal) (f:CustomerId -> 'a) = 
        if Authentication.customerIdOwnedByPrincipal id principal then
            Some (fun () -> f id)
        else
            None
 
    let onlyForAgents (id:CustomerId) (principal:IPrincipal) (f:CustomerId -> 'a) = 
        if principal.IsInRole(Authentication.customerAgentRole) then
            Some (fun () -> f id)
        else
            None

    let onlyIfDuringBusinessHours (time:DateTime) f = 
        if time.Hour >= 8 && time.Hour <= 17 then
            Some f
        else
            None

    // constrain who can call a password update function
    let passwordUpdate (id:CustomerId) (principal:IPrincipal) (f:CustomerId*Password -> 'a) = 
        if Authentication.customerIdOwnedByPrincipal id principal then
            Some (fun password -> f (id,password))
        else
            None

    // return the first good capability, if any
    let first capabilityList = 
        capabilityList |> List.tryPick id

    // given a capability option, restrict it
    let restrict filter originalCap = 
        originalCap
        |> Option.bind filter 

    /// Uses of the capability will be audited
    let auditable capabilityName principalName f = 
        fun x -> 
            // simple audit log!
            let timestamp = DateTime.UtcNow.ToString("u")
            printfn "AUDIT: User %s used capability %s at %s" principalName capabilityName timestamp 
            // use the capability
            f x

    /// Return a pair of functions: the revokable capability, 
    /// and the revoker function
    let revokable f = 
        let allow = ref true
        let capability = fun x -> 
            if !allow then  //! is dereferencing not negation!
                f x
            else
                Failure CapabilityRevoked
        let revoker() = 
            allow := false
        capability, revoker

// ----------------------------------------------

/// Functions related to database access
module CustomerDatabase = 
    open Rop
    open System.Collections.Generic
    open Domain 

    let private db = Dictionary<CustomerId,CustomerData>()

    let getCustomer id = 
        match db.TryGetValue id with
        | true, value -> Success value 
        | false, _ -> Failure (CustomerIdNotFound id)

    let updateCustomer id data = 
        db.[id] <- data
        Success ()

    let updatePassword (id:CustomerId,password:Password) = 
        Success ()   // dummy implementation

// ----------------------------------------------

module BusinessServices =
    open Rop
    open Domain

    // use the getCustomer capability
    let getCustomer capability =
        match capability() with
        | Success data -> printfn "%A" data
        | Failure err -> printfn ".. %A" err

    // use the updateCustomer capability
    let updateCustomer capability =
        printfn "Enter new data: "
        let customerData = Console.ReadLine() |> CustomerData
        match capability () customerData  with
        | Success _ -> printfn "Data updated" 
        | Failure err -> printfn ".. %A" err

    // use the updatePassword capability
    let updatePassword capability =
        printfn "Enter new password: "
        let password = Console.ReadLine() |> Password
        match capability password  with
        | Success _ -> printfn "Password updated" 
        | Failure err -> printfn ".. %A" err

// ----------------------------------------------

module UserInterface =
    open Rop
    open Domain
    open Capabilities

    type CurrentState = 
        | LoggedOut
        | LoggedIn of IPrincipal
        | CustomerSelected of IPrincipal * CustomerId
        | Exit

    /// do the actions available while you are logged out. Return the new state
    let loggedOutActions originalState = 
        printfn "[Login] enter Alice, Bob, Zelda, or Exit: "
        let action = Console.ReadLine()
        match action with
        | "Exit"  -> 
            // Change state to Exit
            Exit
        | name -> 
            // otherwise try to authenticate the name
            match Authentication.authenticate name with
            | Success principal -> 
                LoggedIn principal
            | Failure err -> 
                printfn ".. %A" err
                originalState

    /// do the actions available while you are logged in. Return the new state
    let loggedInActions originalState (principal:IPrincipal) = 
        printfn "[%s] Pick a customer to work on. Enter Alice, Bob, or Logout: " principal.Identity.Name
        let action = Console.ReadLine()

        match action with
        | "Logout"  -> 
            // Change state to LoggedOut
            LoggedOut
        // otherwise treat it as a customer name
        | customerName -> 
            // Attempt to find customer            
            match Authentication.customerIdForName customerName with
            | Success customerId -> 
                // found -- change state
                CustomerSelected (principal,customerId)
            | Failure err -> 
                // not found -- stay in originalState 
                printfn ".. %A" err
                originalState 

    let getAvailableCapabilities capabilityProvider customerId principal = 
        let getCustomer = capabilityProvider.getCustomer customerId principal 
        let updateCustomer = capabilityProvider.updateCustomer customerId principal 
        let updatePassword = capabilityProvider.updatePassword customerId principal 
        getCustomer,updateCustomer,updatePassword  

    /// do the actions available when a selected customer is available. Return the new state
    let selectedCustomerActions originalState capabilityProvider customerId principal = 
        
        // get the individual component capabilities from the provider
        let getCustomerCap,updateCustomerCap,updatePasswordCap = 
            getAvailableCapabilities capabilityProvider customerId principal

        // get the text for menu options based on capabilities that are present
        let menuOptionTexts = 
            [
            getCustomerCap |> Option.map (fun _ -> "(G)et");
            updateCustomerCap |> Option.map (fun _ -> "(U)pdate");
            updatePasswordCap |> Option.map (fun _ -> "(P)assword");
            ] 
            |> List.choose id

        // show the menu        
        let actionText =
            match menuOptionTexts with
            | [] -> " (no other actions available)"
            | texts -> texts |> List.reduce (fun s t -> s + ", " + t) 
        printfn "[%s] (D)eselect customer, %s" principal.Identity.Name actionText 

        // process the user action
        let action = Console.ReadLine().ToUpper()
        match action with
        | "D" -> 
            // revert to logged in with no selected customer
            LoggedIn principal
        | "G" -> 
            // use Option.iter in case we don't have the capability
            getCustomerCap 
              |> Option.iter BusinessServices.getCustomer 
            originalState  // stay in same state
        | "U" -> 
            updateCustomerCap 
              |> Option.iter BusinessServices.updateCustomer 
            originalState  
        | "P" -> 
            updatePasswordCap 
              |> Option.iter BusinessServices.updatePassword
            originalState  
        | _ -> 
            // unknown option
            originalState  

    let rec mainUiLoop capabilityProvider state =
        match state with
        | LoggedOut -> 
            let newState = loggedOutActions state 
            mainUiLoop capabilityProvider newState 
        | LoggedIn principal -> 
            let newState = loggedInActions state principal
            mainUiLoop capabilityProvider newState 
        | CustomerSelected (principal,customerId) ->
            let newState = selectedCustomerActions state capabilityProvider customerId principal 
            mainUiLoop capabilityProvider newState 
        | Exit -> 
            () // done 

    let start capabilityProvider  = 
        mainUiLoop capabilityProvider LoggedOut

// ----------------------------------------------

/// Top level module
module Application=
    open Rop
    open Domain
    open CustomerDatabase 
    open Authentication
    open Authorization
    open Capabilities

    let capabilities = 

        let getCustomerOnlyForSameId id principal  = 
            onlyForSameId id principal CustomerDatabase.getCustomer

        let getCustomerOnlyForAgentsInBusinessHours id principal = 
            let cap1 = onlyForAgents id principal CustomerDatabase.getCustomer
            let restriction f = onlyIfDuringBusinessHours (DateTime.Now) f
            cap1 |> restrict restriction 

        let getCustomerOnlyForSameId_OrForAgentsInBusinessHours id principal = 
            let cap1 = getCustomerOnlyForSameId id principal 
            let cap2 = getCustomerOnlyForAgentsInBusinessHours id principal 
            first [cap1; cap2]

        let updateCustomerOnlyForSameId id principal  = 
            onlyForSameId id principal CustomerDatabase.updateCustomer

        let updateCustomerOnlyForAgentsInBusinessHours id principal = 
            let cap1 = onlyForAgents id principal CustomerDatabase.updateCustomer
            // uncomment to get the restriction
            // let restriction f = onlyIfDuringBusinessHours (DateTime.Now) f
            let restriction = Some  // no restriction
            cap1 |> restrict restriction 

        let updateCustomerOnlyForSameId_OrForAgentsInBusinessHours id principal = 
            let cap1 = updateCustomerOnlyForSameId id principal 
            let cap2 = updateCustomerOnlyForAgentsInBusinessHours id principal 
            first [cap1; cap2]

        let updatePasswordOnlyForSameId id principal = 
            let cap = passwordUpdate id principal CustomerDatabase.updatePassword
            cap 
            |> Option.map (auditable "UpdatePassword" principal.Identity.Name) 

        // create the record that contains the capabilities
        {
        getCustomer = getCustomerOnlyForSameId_OrForAgentsInBusinessHours 
        updateCustomer = updateCustomerOnlyForSameId_OrForAgentsInBusinessHours 
        updatePassword = updatePasswordOnlyForSameId 
        }         

    let start() = 
        // pass capabilities to UI
        UserInterface.start capabilities 
// compile all the code above

// and then run this separately to start the app
Application.start()

CapabilityBasedSecurity_ConsoleExample_WithTypes.fsx

(*
CapabilityBasedSecurity_ConsoleExample_WithTypes.fsx

An example of a capability-based console application that also includes authorization and access tokens.

Related blog post: http://fsharpforfunandprofit.com/posts/capability-based-security-3/
*)

open System.Security.Principal
open System

// ================================================
// A complete console application demonstrating capabilities
// ================================================

module Rop = 
    type SuccessFailure<'a,'b> = 
        | Success of 'a
        | Failure of 'b

    let bind f = function
        | Success x -> f x
        | Failure e -> Failure e 

    let map f = function
        | Success x -> Success (f x)
        | Failure e -> Failure e 

    let orElse errValue = function
        | Success x -> x
        | Failure _ -> errValue

/// Core domain types shares across the application
module Domain = 
    open Rop

    type CustomerId = CustomerId of int
    type CustomerData = CustomerData of string
    type Password = Password of string

    type FailureCase = 
        | AuthenticationFailed of string
        | AuthorizationFailed
        | CustomerNameNotFound of string
        | CustomerIdNotFound of CustomerId
        | OnlyAllowedOnce
        | CapabilityRevoked

// ----------------------------------------------

/// Capabilities that are available in the application
module Capabilities = 
    open Rop
    open Domain

    // each access token gets its own type
    type AccessCustomer = AccessCustomer of CustomerId
    type UpdatePassword = UpdatePassword of CustomerId

    // capabilities
    type GetCustomerCap = unit -> SuccessFailure<CustomerData,FailureCase>
    type UpdateCustomerCap = CustomerData -> SuccessFailure<unit,FailureCase>
    type UpdatePasswordCap = Password -> SuccessFailure<unit,FailureCase>

    type CapabilityProvider = {
        /// given a customerId and IPrincipal, attempt to get the GetCustomer capability
        getCustomer : CustomerId -> IPrincipal -> GetCustomerCap option
        /// given a customerId and IPrincipal, attempt to get the UpdateCustomer capability
        updateCustomer : CustomerId -> IPrincipal -> UpdateCustomerCap option
        /// given a customerId and IPrincipal, attempt to get the UpdatePassword capability
        updatePassword : CustomerId -> IPrincipal -> UpdatePasswordCap option 
        }

                
// ----------------------------------------------

/// Functions related to authentication
module Authentication = 
    open Rop
    open Domain 

    let customerRole = "Customer"
    let customerAgentRole = "CustomerAgent"

    let makePrincipal name role = 
        let iden = GenericIdentity(name)
        let principal = GenericPrincipal(iden,[|role|])
        principal :> IPrincipal

    let authenticate name = 
        match name with
        | "Alice" | "Bob" -> 
            makePrincipal name customerRole  |> Success
        | "Zelda" -> 
            makePrincipal name customerAgentRole |> Success
        | _ -> 
            AuthenticationFailed name |> Failure 

    let customerIdForName name = 
        match name with
        | "Alice" -> CustomerId 1 |> Success
        | "Bob" -> CustomerId 2 |> Success
        | _ -> CustomerNameNotFound name |> Failure

    let customerIdOwnedByPrincipal customerId (principle:IPrincipal) = 
        principle.Identity.Name
        |> customerIdForName 
        |> Rop.map (fun principalId -> principalId = customerId)
        |> Rop.orElse false

// ----------------------------------------------

/// Functions related to authorization
module Authorization = 
    open Rop
    open Domain 
    open Capabilities

    // the constructor is protected
    type AccessToken<'data> = private {data:'data} with 
        // but do allow read access to the data
        member this.Data = this.data

    let onlyForSameId (id:CustomerId) (principal:IPrincipal) = 
        if Authentication.customerIdOwnedByPrincipal id principal then
            Some {data=AccessCustomer id}
        else
            None
 
    let onlyForAgents (id:CustomerId) (principal:IPrincipal)  = 
        if principal.IsInRole(Authentication.customerAgentRole) then
            Some {data=AccessCustomer id}
        else
            None

    let onlyIfDuringBusinessHours (time:DateTime) f = 
        if time.Hour >= 8 && time.Hour <= 17 then
            Some f
        else
            None

    // constrain who can call a password update function
    let passwordUpdate (id:CustomerId) (principal:IPrincipal) = 
        if Authentication.customerIdOwnedByPrincipal id principal then
            Some {data=UpdatePassword id}
        else
            None

    // return the first good capability, if any
    let first capabilityList = 
        capabilityList |> List.tryPick id

    // given a capability option, restrict it
    let restrict filter originalCap = 
        originalCap
        |> Option.bind filter 

    /// Uses of the capability will be audited
    let auditable capabilityName principalName f = 
        fun x -> 
            // simple audit log!
            let timestamp = DateTime.UtcNow.ToString("u")
            printfn "AUDIT: User %s used capability %s at %s" principalName capabilityName timestamp 
            // use the capability
            f x

    /// Return a pair of functions: the revokable capability, 
    /// and the revoker function
    let revokable f = 
        let allow = ref true
        let capability = fun x -> 
            if !allow then  //! is dereferencing not negation!
                f x
            else
                Failure CapabilityRevoked
        let revoker() = 
            allow := false
        capability, revoker

// ----------------------------------------------

/// Functions related to database access
module CustomerDatabase = 
    open Rop
    open System.Collections.Generic
    open Domain 
    open Capabilities
    open Authorization

    let private db = Dictionary<CustomerId,CustomerData>()

    let getCustomer (accessToken:AccessToken<AccessCustomer>) = 
        // get customer id
        let (AccessCustomer id) = accessToken.Data

        // now get customer data using the id
        match db.TryGetValue id with
        | true, value -> Success value 
        | false, _ -> Failure (CustomerIdNotFound id)

    let updateCustomer (accessToken:AccessToken<AccessCustomer>) (data:CustomerData) = 
        // get customer id
        let (AccessCustomer id) = accessToken.Data

        // update database
        db.[id] <- data
        Success ()

    let updatePassword (accessToken:AccessToken<UpdatePassword>) (password:Password) = 
        Success ()   // dummy implementation

// ----------------------------------------------

module BusinessServices =
    open Rop
    open Domain

    // use the getCustomer capability
    let getCustomer capability =
        match capability() with
        | Success data -> printfn "%A" data
        | Failure err -> printfn ".. %A" err

    // use the updateCustomer capability
    let updateCustomer capability =
        printfn "Enter new data: "
        let customerData = Console.ReadLine() |> CustomerData
        match capability customerData  with
        | Success _ -> printfn "Data updated" 
        | Failure err -> printfn ".. %A" err

    // use the updatePassword capability
    let updatePassword capability =
        printfn "Enter new password: "
        let password = Console.ReadLine() |> Password
        match capability password  with
        | Success _ -> printfn "Password updated" 
        | Failure err -> printfn ".. %A" err

// ----------------------------------------------

module UserInterface =
    open Rop
    open Domain
    open Capabilities

    type CurrentState = 
        | LoggedOut
        | LoggedIn of IPrincipal
        | CustomerSelected of IPrincipal * CustomerId
        | Exit

    /// do the actions available while you are logged out. Return the new state
    let loggedOutActions originalState = 
        printfn "[Login] enter Alice, Bob, Zelda, or Exit: "
        let action = Console.ReadLine()
        match action with
        | "Exit"  -> 
            // Change state to Exit
            Exit
        | name -> 
            // otherwise try to authenticate the name
            match Authentication.authenticate name with
            | Success principal -> 
                LoggedIn principal
            | Failure err -> 
                printfn ".. %A" err
                originalState

    /// do the actions available while you are logged in. Return the new state
    let loggedInActions originalState (principal:IPrincipal) = 
        printfn "[%s] Pick a customer to work on. Enter Alice, Bob, or Logout: " principal.Identity.Name
        let action = Console.ReadLine()

        match action with
        | "Logout"  -> 
            // Change state to LoggedOut
            LoggedOut
        // otherwise treat it as a customer name
        | customerName -> 
            // Attempt to find customer            
            match Authentication.customerIdForName customerName with
            | Success customerId -> 
                // found -- change state
                CustomerSelected (principal,customerId)
            | Failure err -> 
                // not found -- stay in originalState 
                printfn ".. %A" err
                originalState 

    let getAvailableCapabilities capabilityProvider customerId principal = 
        let getCustomer = capabilityProvider.getCustomer customerId principal 
        let updateCustomer = capabilityProvider.updateCustomer customerId principal 
        let updatePassword = capabilityProvider.updatePassword customerId principal 
        getCustomer,updateCustomer,updatePassword  

    /// do the actions available when a selected customer is available. Return the new state
    let selectedCustomerActions originalState capabilityProvider customerId principal = 
        
        // get the individual component capabilities from the provider
        let getCustomerCap,updateCustomerCap,updatePasswordCap = 
            getAvailableCapabilities capabilityProvider customerId principal

        // get the text for menu options based on capabilities that are present
        let menuOptionTexts = 
            [
            getCustomerCap |> Option.map (fun _ -> "(G)et");
            updateCustomerCap |> Option.map (fun _ -> "(U)pdate");
            updatePasswordCap |> Option.map (fun _ -> "(P)assword");
            ] 
            |> List.choose id

        // show the menu        
        let actionText =
            match menuOptionTexts with
            | [] -> " (no other actions available)"
            | texts -> texts |> List.reduce (fun s t -> s + ", " + t) 
        printfn "[%s] (D)eselect customer, %s" principal.Identity.Name actionText 

        // process the user action
        let action = Console.ReadLine().ToUpper()
        match action with
        | "D" -> 
            // revert to logged in with no selected customer
            LoggedIn principal
        | "G" -> 
            // use Option.iter in case we don't have the capability
            getCustomerCap 
              |> Option.iter BusinessServices.getCustomer 
            originalState  // stay in same state
        | "U" -> 
            updateCustomerCap 
              |> Option.iter BusinessServices.updateCustomer 
            originalState  
        | "P" -> 
            updatePasswordCap 
              |> Option.iter BusinessServices.updatePassword
            originalState  
        | _ -> 
            // unknown option
            originalState  

    let rec mainUiLoop capabilityProvider state =
        match state with
        | LoggedOut -> 
            let newState = loggedOutActions state 
            mainUiLoop capabilityProvider newState 
        | LoggedIn principal -> 
            let newState = loggedInActions state principal
            mainUiLoop capabilityProvider newState 
        | CustomerSelected (principal,customerId) ->
            let newState = selectedCustomerActions state capabilityProvider customerId principal 
            mainUiLoop capabilityProvider newState 
        | Exit -> 
            () // done 

    let start capabilityProvider  = 
        mainUiLoop capabilityProvider LoggedOut

// ----------------------------------------------

/// Top level module
module Application=
    open Rop
    open Domain
    open CustomerDatabase 
    open Authentication
    open Authorization
    open Capabilities

    let capabilities = 
        
        // apply the token, if present,
        // to a function which has only the token as a parameter
        let tokenToCap f token =
            token 
            |> Option.map (fun token -> 
                fun () -> f token)

        // apply the token, if present,
        // to a function which has the token and other parameters
        let tokenToCap2 f token =
            token 
            |> Option.map (fun token -> 
                fun x -> f token x)

        let getCustomerOnlyForSameId id principal  = 
            let accessToken = Authorization.onlyForSameId id principal
            accessToken |> tokenToCap CustomerDatabase.getCustomer 

        let getCustomerOnlyForAgentsInBusinessHours id principal = 
            let accessToken = Authorization.onlyForAgents id principal
            let cap1 = accessToken |> tokenToCap CustomerDatabase.getCustomer 
            let restriction f = onlyIfDuringBusinessHours (DateTime.Now) f
            cap1 |> restrict restriction 

        let getCustomerOnlyForSameId_OrForAgentsInBusinessHours id principal = 
            let cap1 = getCustomerOnlyForSameId id principal 
            let cap2 = getCustomerOnlyForAgentsInBusinessHours id principal 
            first [cap1; cap2]

        let updateCustomerOnlyForSameId id principal = 
            let accessToken = Authorization.onlyForSameId id principal
            accessToken |> tokenToCap2 CustomerDatabase.updateCustomer

        let updateCustomerOnlyForAgentsInBusinessHours id principal = 
            let accessToken = Authorization.onlyForAgents id principal
            let cap1 = accessToken |> tokenToCap2 CustomerDatabase.updateCustomer
            // uncomment to get the restriction
            // let restriction f = onlyIfDuringBusinessHours (DateTime.Now) f
            let restriction = Some  // no restriction
            cap1 |> restrict restriction 

        let updateCustomerOnlyForSameId_OrForAgentsInBusinessHours id principal = 
            let cap1 = updateCustomerOnlyForSameId id principal 
            let cap2 = updateCustomerOnlyForAgentsInBusinessHours id principal 
            first [cap1; cap2]

        let updatePasswordOnlyForSameId id principal = 
            let accessToken = Authorization.passwordUpdate id principal
            let cap = accessToken |> tokenToCap2 CustomerDatabase.updatePassword
            cap 
            |> Option.map (auditable "UpdatePassword" principal.Identity.Name) 

        // create the record that contains the capabilities
        {
        getCustomer = getCustomerOnlyForSameId_OrForAgentsInBusinessHours 
        updateCustomer = updateCustomerOnlyForSameId_OrForAgentsInBusinessHours 
        updatePassword = updatePasswordOnlyForSameId 
        }         


    let start() = 
        // pass capabilities to UI
        UserInterface.start capabilities 
// compile all the code above

// and then run this separately to start the app
Application.start()

CapabilityBasedSecurity_DbExample.fsx

(*
CapabilityBasedSecurity_DbExample.fsx

Code snippets from the blog post: http://fsharpforfunandprofit.com/posts/capability-based-security-2/
*)

open System.Security.Principal
open System

// ==============================
// dummy definitions
// ==============================
type CustomerId = int
type CustomerData = string

let customerIdBelongsToPrincipal (id:CustomerId) (principle:IPrincipal) = true

type SuccessFailure<'a,'b> = 
    | Success of 'a
    | Failure of 'b

type DbErrors = 
    | AuthorizationFailed
    | OnlyAllowedOnce
    | OnlyAllowedNTimes of int
    | Revoked

// ==============================
// end dummy definitions
// ==============================


// ==============================
// Example 1 - inlined authorization
// ==============================

module Example1 = 
    let getCustomer id principal = 
        if customerIdBelongsToPrincipal id principal ||
           principal.IsInRole("CustomerAgent") 
        then
            // get database
            Success "CustomerData"
        else
            Failure AuthorizationFailed

    let updateCustomer id data principal = 
        if customerIdBelongsToPrincipal id principal ||
           principal.IsInRole("CustomerAgent") 
        then
            // update database
            Success "OK"
        else
            Failure AuthorizationFailed

// ==============================
// Example 2 - separate CapabilityProvider
// ==============================

module Example2 = 

    module internal CustomerDatabase = 
        let getCustomer (id:CustomerId) :CustomerData = 
            // get customer data
            "CustomerData"

        let updateCustomer (id:CustomerId) (data:CustomerData) = 
            // update database
            ()

    /// accessible to the business layer        
    module CustomerDatabaseCapabilityProvider =         

        // Get the capability to call getCustomer
        let getGetCustomerCapability (id:CustomerId) (principal:IPrincipal) = 
            if customerIdBelongsToPrincipal id principal ||
               principal.IsInRole("CustomerAgent") 
            then
                Some ( fun () -> CustomerDatabase.getCustomer id )
            else
                None
 
        // Get the capability to call UpdateCustomer
        let getUpdateCustomerCapability (id:CustomerId) (principal:IPrincipal) = 
            if customerIdBelongsToPrincipal id principal ||
               principal.IsInRole("CustomerAgent") 
            then
                Some ( fun () -> CustomerDatabase.updateCustomer id )
            else
                None


// ==============================
// Example 3 - separate CapabilityFilter
// ==============================

module Example3 = 

    module internal CustomerDatabase = 
        let getCustomer (id:CustomerId) :CustomerData = 
            // get customer data
            "data"
        // val getCustomer : CustomerId -> CustomerData
    

        let updateCustomer (id:CustomerId) (data:CustomerData) = 
            // update database
            ()
        // val updateCustomer : CustomerId -> CustomerData -> unit


    module CustomerCapabilityFilter =         
 
        // Get the capability to use any function that has a CustomerId parameter
        // but only if the caller has the same customer id or is a member of the 
        // CustomerAgent role.
        let onlyForSameIdOrAgents (id:CustomerId) (principal:IPrincipal) (f:CustomerId -> 'a) = 
            if customerIdBelongsToPrincipal id principal ||
               principal.IsInRole("CustomerAgent") 
            then
                Some (fun () -> f id)
            else
                None

    module Startup =
        open CustomerCapabilityFilter 
                 
        let principal = WindowsPrincipal.Current // from context
        let id = 0 // from context

        let getCustomerOnlyForSameIdOrAgents = 
            onlyForSameIdOrAgents id principal CustomerDatabase.getCustomer
        // val getCustomerOnlyForSameIdOrAgents : (CustomerId -> CustomerData) option

        let updateCustomerOnlyForSameIdOrAgents = 
            onlyForSameIdOrAgents id principal CustomerDatabase.updateCustomer
        // val updateCustomerOnlyForSameIdOrAgents : (CustomerId -> CustomerData -> unit) option

        match getCustomerOnlyForSameIdOrAgents with
        | Some cap -> () // create child component and pass in the capability
        | None -> () // return error saying that you don't have the capability to get the data


// ==============================
// Example 4 - composable filters
// ==============================

module Example4 = 

    module internal CustomerDatabase = 
        let getCustomer (id:CustomerId) : CustomerData = 
            // get customer data
            "data"
        // val getCustomer : CustomerId -> CustomerData
    

        let updateCustomer (id:CustomerId) (data:CustomerData) = 
            // update database
            ()
        // val updateCustomer : CustomerId -> CustomerData -> unit


    module CustomerCapabilityFilter =         

        let onlyForSameId (id:CustomerId) (principal:IPrincipal) (f:CustomerId -> 'a) = 
            if customerIdBelongsToPrincipal id principal then
                Some (fun () -> f id)
            else
                None
 
        let onlyForAgents (id:CustomerId) (principal:IPrincipal) (f:CustomerId -> 'a) = 
            if principal.IsInRole("CustomerAgent") then
                Some (fun () -> f id)
            else
                None

        let onlyIfDuringBusinessHours (time:DateTime) f = 
            if time.Hour >= 8 && time.Hour <= 17 then
                Some f
            else
                None

        // given a list of capability options, 
        // return the first good one, if any
        let first capabilityList = 
            capabilityList |> List.tryPick id


        // given a capability option, restrict it
        let restrict filter originalCap = 
            originalCap
            |> Option.bind filter 
            

    module Startup =
        open CustomerCapabilityFilter 
                 
        let principal = WindowsPrincipal.Current // from context
        let id = 0 // from context

        let getCustomerOnlyForSameId = 
            let f = CustomerDatabase.getCustomer
            onlyForSameId id principal f
        // val getCustomerOnlyForSameId : (unit -> CustomerData) option

        let getCustomerOnlyForSameIdOrAgents = 
            let f = CustomerDatabase.getCustomer
            let cap1 = onlyForSameId id principal f
            let cap2 = onlyForAgents id principal f 
            first [cap1; cap2]
        // val getCustomerOnlyForSameIdOrAgents : (unit -> CustomerData) option

        let updateCustomerOnlyForSameIdOrAgents = 
            let f = CustomerDatabase.updateCustomer
            let cap1 = onlyForSameId id principal f
            let cap2 = onlyForAgents id principal f 
            first [cap1; cap2]
        // val updateCustomerOnlyForSameIdOrAgents : (unit -> CustomerData -> unit) option

        match getCustomerOnlyForSameIdOrAgents with
        | Some cap -> () // create child component and pass in the capability
        | None -> () // return error saying that you don't have the capability to get the data

        let getCustomerOnlyForAgentsInBusinessHours = 
            let f = CustomerDatabase.getCustomer
            let cap1 = onlyForAgents id principal f 
            let restriction f = onlyIfDuringBusinessHours (DateTime.Now) f
            cap1 |> restrict restriction 
        // val getCustomerOnlyForAgentsInBusinessHours : (unit -> CustomerData) option

        let getCustomerOnlyForSameId_OrForAgentsInBusinessHours = 
            let cap1 = getCustomerOnlyForSameId
            let cap2 = getCustomerOnlyForAgentsInBusinessHours 
            first [cap1; cap2]

// ==============================
// Example 5 - more transforms
// ==============================

module Example5 = 

    module internal CustomerDatabase = 
        let updatePassword (id,password) = 
            Success "OK"

    module GenericCapabilityFilter =         

        /// Uses of the capability will be audited
        let auditable capabilityName f = 
            fun x -> 
                // simple audit log!
                printfn "AUDIT: calling %s with %A" capabilityName  x
                // use the capability
                f x

        /// Allow the function to be called once only
        let onlyOnce f = 
            let allow = ref true
            fun x -> 
                if !allow then   //! is dereferencing not negation!
                    allow := false
                    f x
                else
                    Failure OnlyAllowedOnce

        /// Return a pair of functions: the revokable capability, 
        /// and the revoker function
        let revokable f = 
            let allow = ref true
            let capability = fun x -> 
                if !allow then  //! is dereferencing not negation!
                    f x
                else
                    Failure Revoked
            let revoker() = 
                allow := false
            capability, revoker

    module Startup =
        open GenericCapabilityFilter 

        // ----------------------------------------
        let updatePasswordWithAudit x = 
            auditable "updatePassword" CustomerDatabase.updatePassword x

        // test
        updatePasswordWithAudit (1,"password") 
        updatePasswordWithAudit (1,"new password") 

        // AUDIT: calling updatePassword with (1, "password")
        // AUDIT: calling updatePassword with (1, "new password")

        // ----------------------------------------
        let updatePasswordOnce = 
            onlyOnce CustomerDatabase.updatePassword 

        // test
        updatePasswordOnce (1,"password") |> printfn "Result 1st time: %A"
        updatePasswordOnce (1,"password") |> printfn "Result 2nd time: %A"

        // Result 1st time: Success "OK"
        // Result 2nd time: Failure OnlyAllowedOnce

        // ----------------------------------------
        let revokableUpdatePassword, revoker = 
            revokable CustomerDatabase.updatePassword 

        // test
        revokableUpdatePassword (1,"password") |> printfn "Result 1st time before revoking: %A"
        revokableUpdatePassword (1,"password") |> printfn "Result 2nd time before revoking: %A"
        revoker()
        revokableUpdatePassword (1,"password") |> printfn "Result 3nd time after revoking: %A"

        // Result 1st time before revoking: Success "OK"
        // Result 2nd time before revoking: Success "OK"
        // Result 3nd time after revoking: Failure Revoked

CapabilityBasedSecurity_TypeExample.fsx

(*
CapabilityBasedSecurity_TypeExample.fsx

Code snippets from the blog post: http://fsharpforfunandprofit.com/posts/capability-based-security-3/
*)

open System.Security.Principal
open System

// ==============================
// dummy definitions
// ==============================
type CustomerId = int
type CustomerData = CustomerData of string
type Password = Password of string

let myCustomerData = CustomerData "data"

let customerIdBelongsToPrincipal customerId (principle:IPrincipal) = true

type SuccessFailure<'a,'b> = 
    | Success of 'a
    | Failure of 'b

type DbErrors = 
    | AuthorizationFailed
    | CustomerIdNotFound of CustomerId

// ==============================
// end dummy definitions
// ==============================
     
// ==============================
// Example 1 - access token in same service
// ==============================

module Example1 = 

    /// Public database module
    module CustomerDatabase = 

        type DbAccessToken private() = 
            // create a DbAccessToken that allows access to a particular customer
            static member getAccessToCustomer id principal = 
                if customerIdBelongsToPrincipal id principal ||
                   principal.IsInRole("CustomerAgent") 
                then
                    Some <| DbAccessToken() 
                else
                    None   

        let getCustomer (accessToken:DbAccessToken) (id:CustomerId) = 
            // get customer data
            Success myCustomerData 

        let updateCustomer (accessToken:DbAccessToken) (id:CustomerId) (data:CustomerData) = 
            // update database
            Success "OK"


    /// Usage example
    module Startup = 
        let principal = WindowsPrincipal.Current // from context
        let id = 0 // from context

        // attempt to get an access token
        let accessToken = CustomerDatabase.DbAccessToken.getAccessToCustomer id principal

        // get the (optional) capabilities
        let getCustomerCap = 
            accessToken |> Option.map CustomerDatabase.getCustomer
        let updateCustomerCap = 
            accessToken |> Option.map CustomerDatabase.updateCustomer 

        // use the capabilities, if available               
        match getCustomerCap with
        | Some getCustomer -> getCustomer id
        | None -> Failure AuthorizationFailed // error

        match updateCustomerCap with
        | Some updateCustomer -> updateCustomer id myCustomerData
        | None -> Failure AuthorizationFailed // error


// ==============================
// Example 2 - access token from separate service
//
// Dangerous because (a) the access token can be reused
// and (b) the access token doesn't store the customer id
// ==============================

module Example2 = 

    /// OO version of AccessToken
    module AuthorizationService = 

        // the constructor is hidden using "private"
        type AccessToken private() = 

            // create a AccessToken that allows access to a particular customer
            static member getAccessToCustomer id principal = 
                if customerIdBelongsToPrincipal id principal ||
                   principal.IsInRole("CustomerAgent") 
                then
                    Some <| AccessToken() 
                else
                    None   

    /// Public database module
    module CustomerDatabase = 
        open AuthorizationService 

        let getCustomer (accessToken:AccessToken) (id:CustomerId) = 
            // get customer data
            Success myCustomerData 

        let updateCustomer (accessToken:AccessToken) (id:CustomerId) (data:CustomerData) = 
            // update database
            Success "OK"

    /// Usage example
    module Startup = 
        let principal = WindowsPrincipal.Current // from context
        let id = 0 // from context

        // attempt to get an access token
        let accessToken = AuthorizationService.AccessToken.getAccessToCustomer id principal

        // get the (optional) capabilities
        let getCustomerCap = 
            accessToken |> Option.map CustomerDatabase.getCustomer
        let updateCustomerCap = 
            accessToken |> Option.map CustomerDatabase.updateCustomer 

        // use the capabilities, if available               
        match getCustomerCap with
        | Some getCustomer -> getCustomer id
        | None -> Failure AuthorizationFailed // error

        match updateCustomerCap with
        | Some updateCustomer -> updateCustomer id myCustomerData 
        | None -> Failure AuthorizationFailed // error


// ==============================
// Example 3 - access token stores information
// ==============================

module Example3 = 

    module Capabilities = 

        // each capability gets a type
        type AccessCustomer = AccessCustomer of CustomerId
        type UpdatePassword = UpdatePassword of CustomerId

    // functional version of AccessToken
    module AuthorizationService = 
        open Capabilities

        // the constructor is protected
        type AccessToken<'data> = private {data:'data} with 
            // but do allow read access to the data
            member this.Data = this.data

        // create a AccessToken that allows access to a particular customer
        let getAccessCustomerToken id principal = 
            if customerIdBelongsToPrincipal id principal ||
                principal.IsInRole("CustomerAgent") 
            then
                Some {data=AccessCustomer id}
            else
                None   

        // create a AccessToken that allows access to UpdatePassword 
        let getUpdatePasswordToken id principal = 
            if customerIdBelongsToPrincipal id principal then
                Some {data=UpdatePassword id}
            else
                None

    /// Public database module
    module CustomerDatabase = 
        open Capabilities
        open AuthorizationService
        open System.Collections.Generic

        let private db = Dictionary<CustomerId,CustomerData>()

        let getCustomer (accessToken:AccessToken<AccessCustomer>) = 
            // get customer id
            let (AccessCustomer id) = accessToken.Data

            // now get customer data using the id
            match db.TryGetValue id with
            | true, value -> Success value 
            | false, _ -> Failure (CustomerIdNotFound id)

        let updateCustomer (accessToken:AccessToken<AccessCustomer>) (data:CustomerData) = 
            // get customer id
            let (AccessCustomer id) = accessToken.Data

            // update database
            db.[id] <- data
            Success ()

        let updatePassword (accessToken:AccessToken<UpdatePassword>) (password:Password) = 
            Success ()   // dummy implementation


    /// Usage example
    module Startup = 
        open AuthorizationService

        let principal = WindowsPrincipal.Current // from context
        let customerId = 0 // from context

        // attempt to get a capability
        let getCustomerCap = 
            // attempt to get a token
            let accessToken = AuthorizationService.getAccessCustomerToken customerId principal
            match accessToken with
            // if token is present pass the token to CustomerDatabase.getCustomer, 
            // and return a unit->CustomerData 
            | Some token -> 
                Some (fun () -> CustomerDatabase.getCustomer token)
            | None -> None

        // use the capability, if available               
        match getCustomerCap with
        | Some getCustomer -> getCustomer()
        | None -> Failure AuthorizationFailed // error

        // attempt to get a capability
        let getUpdatePasswordCap = 
            let accessToken = AuthorizationService.getAccessCustomerToken customerId principal
            match accessToken with
            | Some token -> 
                Some (fun password -> CustomerDatabase.updatePassword token password)
            | None -> None

        match getUpdatePasswordCap with
        | Some updatePassword -> 
            let password = Password "p@ssw0rd"
            updatePassword password 
        | None -> 
            Failure AuthorizationFailed // error