rules.fs

module RuleIt =

  type Navigator          = Navigator         of (unit -> unit)
  type UserIdentity       = UserIdentity      of uint64
  type ResourceIdentity   = ResourceIdentity  of uint64
  type UserAction         =
    | Create  of ResourceIdentity
    | Read    of ResourceIdentity
    | Update  of ResourceIdentity
    | Delete  of ResourceIdentity
  type UserAccessControl  = 
    {
      Allowed : Set<UserAction>
      Denied  : Set<UserAction>
    }
  type RuleContext      = 
    {
      AutenticatedUser  : UserIdentity        option
      AccessControl     : UserAccessControl
    }
    member x.CreateNavigator url : Navigator = id |> Navigator
  type RulePath         = RulePath    of string list
  type RuleFailure      =
    | Failure     of string
    | Group       of RuleFailure  list
    | NotAllowed  of UserAction   list
    | Denied      of UserAction   list
    | Expected    of string
    | Unexpected  of string
  type RuleFailureTree  = 
    | Empty
    | Leaf        of RulePath*RuleFailure
    | Fork        of RuleFailureTree*RuleFailureTree

    static member inline Join l r =
      match (l, r) with
      | Empty , _     -> r
      | _     , Empty -> l
      | _     , _     -> Fork (l, r)
  type RuleResult<'T>   = RuleResult  of RuleContext*'T option*RuleFailureTree
  type Rule<'T>         = Rule        of (RuleContext -> RulePath -> RuleResult<'T>)

  module Details =
    let inline adapt2 f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
    let uniqueId =
      let mutable i = 1L
      fun () ->
        System.Threading.Interlocked.Increment &i

  module Rule =
    open Details

    let inline rresult rc ov rft  = RuleResult (rc, ov, rft)
    let inline ryes rc v          = rresult rc (Some v) Empty
    let inline rno  rc rp rf      = rresult rc None     (Leaf (rp, rf))

    // Monad
    let inline rreturn v  : Rule<_> =
      Rule <| fun rc rp -> 
        ryes rc v
    let rbind (Rule t) uf : Rule<_> =
      let t = adapt2 t
      Rule <| fun rc rp ->
        let (RuleResult (trc, tov, trft)) = t.Invoke (rc, rp)
        match tov with
        | None      -> rresult trc None trft
        | Some tv   ->
          let (Rule u)                      = uf tv
          let u                             = adapt2 u
          let (RuleResult (urc, uov, urft)) = u.Invoke (rc, rp)
          rresult urc uov (RuleFailureTree.Join trft urft)

    // Arrow
    let inline rarr f v   : Rule<_> = rreturn (f v)
    let rkleisli tf uf              = fun tv -> rbind (tf tv) uf

    // Functor
    let rmap m t          : Rule<_> = rbind t (rarr m)
  
    // Applicative
    let inline rpure v    : Rule<_> = rreturn v
    let rap u t           : Rule<_> = rbind u (fun uf -> rmap uf t)
  
    // Option
    let ropt (Rule t)     : Rule<_> =
      let t = adapt2 t
      Rule <| fun rc rp -> 
        let (RuleResult (trc, tov, trft)) = t.Invoke (rc, rp)
        rresult trc (Some tov) trft

    // Label
    let rlabel l (Rule t) : Rule<_> =
      let t = adapt2 t
      Rule <| fun rc (RulePath rp) -> 
        t.Invoke (rc, l::rp |> RulePath)

    // Debug
    let rdebug l (Rule t) : Rule<_> =
      let t = adapt2 t
      Rule <| fun rc rp ->
        let uid = uniqueId ()
        printfn "BEFORE %s(%d): RC:%A, RP:%A" l uid rc rp
        let (RuleResult (trc, tov, trft)) as r = t.Invoke (rc, rp)
        printfn "AFTER  %s(%d): RC:%A, RFT:%A, V:%A" l uid trc trft tov
        r

    // Other
    let inline rfail rf   : Rule<_> =
      Rule <| fun rc rp -> 
        rresult rc None (Leaf (rp, rf))

    let rrun (Rule t) (trc : RuleContext) : RuleResult<_> =
      t trc (RulePath [])

    let inline rzero ()   : Rule<_> =
      Rule <| fun rc rp -> 
        ryes rc LanguagePrimitives.GenericZero

    type RuleBuilder() =
      member inline x.Bind        (t, uf) = rbind   t uf
      member inline x.Return      v       = rreturn v
      member inline x.ReturnFrom  t       = t
      member inline x.Zero        ()      = rzero   ()

    module Infixes =
      let inline (>>=) t uf   = rbind t uf
      let inline (>=>) tf uf  = rkleisli tf uf
      let inline (<*>) u t    = rap u t

  let rule = Rule.RuleBuilder ()

module Examples =
  open RuleIt
  open RuleIt.Rule
  open RuleIt.Rule.Infixes

  let resource_pricelist  = ResourceIdentity 1UL
  let resource_settings   = ResourceIdentity 2UL

  let expected_authorizedUser rc rp = rno rc rp (Expected "Authorized User")

  let userIdentity : Rule<UserIdentity> = 
    Rule <| fun rc rp -> 
      match rc.AutenticatedUser with
      | Some uid  -> ryes rc uid
      | None      -> expected_authorizedUser rc rp

  let accessControl : Rule<UserAccessControl> = 
    Rule <| fun rc rp -> 
      match rc.AutenticatedUser with
      | Some _    -> ryes rc rc.AccessControl
      | None      -> expected_authorizedUser rc rp

  let canPerformActions (actions : UserAction list) =
    accessControl >>= fun uacs ->
      let isNotAllowed  = actions |> List.filter (fun action -> uacs.Allowed.Contains action |> not)
      let isDenied      = actions |> List.filter (fun action -> uacs.Denied.Contains action)
      match isNotAllowed, isDenied with
      | []  , []  -> rreturn ()
      | _   , []  -> rfail (NotAllowed isNotAllowed)
      | []  , _   -> rfail (Denied isDenied)
      | _   , _   -> rfail (Group [NotAllowed isNotAllowed; Denied isDenied])

  let createNavigator url : Rule<Navigator> = 
    Rule <| fun rc rp -> 
      ryes rc (rc.CreateNavigator url)

  let viewSettings =
    rule {
      do!     canPerformActions [Read resource_settings]
      return! createNavigator "pages/settings/view"
    } |> rlabel "View Settings"

[<EntryPoint>]     
let main argv = 
  printfn "%A" argv
  0