EventHorizon is a framework for creating MVVM applications [WIP in progress] (all rights reserved for now)

Config.fs

namespace EventHorizon.Backend.Model

open System
open System.Data.Entity

open EventHorizon.Backend.Extension.DbContextModule
open EventHorizon.Backend.Extension.DbModelBuilderModule

module Config =

    //Extend with new members.
    type DbModelBuilder with

        //Set some defaults so we can have convention over configuration.
        member this.DefaultConfiguration ( context : DbContext ) =
            this.PrimaryKey( "Id" )
                .Require<DateTime>()
                .Require<decimal>()
                .Require<int>()
                .Require( "Name" )
                .Require( "Description" ) 
                .HasDefaultSchema ( context.Name )

Context.fs

namespace EventHorizon.Backend.Extension

open System
open System.Linq
open System.Data.Common
open System.Data.Entity
open Microsoft.FSharp.Quotations
open System.Data.Entity.Migrations
open System.Data.Entity.Infrastructure
open System.Data.Entity.Core.Metadata.Edm

open EventHorizon.Backend.ExpressionHelpers

module DbContextModule =
    
    exception RelationShipException of string

    //Return if an entity of type T is attached to this context.
    let isAttached ( context : DbContext, getId, entity ) =
        let memberSet = context.Set<'T> ()
        memberSet.Local.Any ( fun e -> getId e = getId entity )
        
    //Return an entity of type T that is attached to this context.
    let getAttached ( context : DbContext, getId, entity ) =
        let memberSet = context.Set<'T> ()
        memberSet.Local.Single ( fun e -> getId e = getId entity )
    
    //Classify our entity state.
    let (| NewEntity | AttachedEntity | DetachedEntity |) 
            ( context : DbContext, getId, entity ) =
        match entity with
        | e when getId e = 0 -> NewEntity
        | e when isAttached ( context, getId, e ) -> 
            AttachedEntity ( getAttached ( context, getId, e ) )
        | _ -> DetachedEntity

    //Table creation facility type.
    type Table<'T when 'T : not struct> () =  
        [<DefaultValue>]
        val mutable table : DbSet<'T>

    //Function used to declare Tables on DbContext.
    let inline table<'T when 'T : not struct> () = 
        let table = new Table<'T> ()
        table.table
        
    //Extend with new members.
    type DbContext with
    
        //Don't mutate the context in case of errors.
        member this.SafeSaveChanges () =
            try
                this.SaveChanges ()
            with e ->
                let entries = this.ChangeTracker.Entries ()
                entries |> Seq.iter ( fun entry ->
                    entry.State <- EntityState.Detached )
                raise e

        //list all the entities.
        member this.Seq () =
            this.Set<'T> () |> seq

        //Add an entity or update based on its state.
        member this.AddOrUpdate getId entity =
            let memberSet = this.Set<'T> ()
            let newState =
                match this, getId, entity with
                | NewEntity -> 
                    memberSet.Add entity
                | AttachedEntity attached ->
                    let entry = this.Entry<'T> attached
                    let o = box entity 
                    entry.CurrentValues.SetValues o
                    attached
                | _ ->
                    let entry = this.Entry<'T> entity
                    memberSet.Attach entity |> ignore
                    entry.State <- EntityState.Modified
                    entity
//            try
            this.SafeSaveChanges () |> ignore
//            with 
//            | :? System.Data.SqlClient.SqlException as s ->
//                RelationShipException s.Message |> raise
            newState

        //Remove an entity or delete it based on its state.
        member this.Delete getId entity =
            let entry = this.Entry<'T> entity
            let memberSet = this.Set<'T> ()
            match this, getId, entity with
            | AttachedEntity attached ->
                memberSet.Remove attached |> ignore
            | _ ->
                memberSet.Attach entity |> ignore
                entry.State <- EntityState.Deleted
//            try
            this.SafeSaveChanges () |> ignore
//            with 
//            | :? System.Data.SqlClient.SqlException as s ->
//                RelationShipException s.Message |> raise
            
        //Add or update a list of entities.
        member this.AddOrUpdateMany getId entities =
            let save = this.AddOrUpdate getId 
            entities |> List.map save 
            
        //Add or update a list of entities.
        member this.DeleteMany getId entities =
            let delete = this.Delete getId
            entities |> List.iter delete
            entities

        //Name of the context.
        member this.Name = this.GetType().Name
        
    //Eager load an entity.
    let eagerLoad ( loader : ('T -> 'R) Expr ) ( query : 'T IQueryable ) =
        query.Include ( loader |> toLinq )

    //Eager load an entity.
    let eagerLoadEntry ( loader : Func<'T, 'R> Expr ) ( context : DbContext ) =
        let p = match loader with QuotedProperty pi -> pi
        let r = p.PropertyType.Name
        fun ( entity : 'T ) ->
            context.Entry( entity ).Reference( r ).Load ()
            entity

    //Eager load an entity.
    let eagerLoadSubEntry extractor loader context =
        fun entity -> 
            entity |> extractor |> eagerLoadEntry loader context |> ignore
            entity

    //Fake load a child entity, only used to avoid null errors on GetHashCode.
    let fakeLoadEntry ( loader : Func<'T, 'R> Expr ) ( context : DbContext ) =
        let p = match loader with QuotedProperty pi -> pi
        let setter = p.GetSetMethod ()
        fun ( entity : 'T ) ->
            let subEntity = Activator.CreateInstance p.PropertyType
            setter.Invoke ( entity, [| subEntity |] ) |> ignore
            entity
                
    //Finds the associated relationship between two entities in the model.
    let getRelationShip ( parentType : Type ) ( entityType : Type ) ( context : DbContext ) =
        let adp = context :> IObjectContextAdapter
        let ctx = adp.ObjectContext
        let space = Core.Metadata.Edm.DataSpace.CSpace
        let items = ctx.MetadataWorkspace.GetItems<AssociationType> ( space )
        items
        |> Seq.filter ( fun a -> a.IsForeignKey )
        |> Seq.map ( fun a -> 
            let refc = a.ReferentialConstraints |> Seq.exactlyOne
            let pk = refc.FromProperties |> Seq.exactlyOne
            let fk = refc.ToProperties |> Seq.exactlyOne
            ( pk, fk ) )
        |> Seq.filter ( fun ( pk, fk ) -> 
            let e1 = pk.DeclaringType.Name
            let e2 = fk.DeclaringType.Name
            ( e1 = parentType.Name && e2 = entityType.Name ) )
        |> Seq.map ( fun ( pk, fk ) -> 
            ( pk.Name, fk.Name ) )
        |> Seq.exactlyOne

    //Define the query used for navigation.
    let inline navigatorQuery ( tmpContext : 'C ) ( t : 'T ) ( r : 'R ) =
        let ( pkName, fkName ) = getRelationShip typeof<'T> typeof<'R> tmpContext
        let queryPrimaryKey = quotedProperty<'T, int> pkName
        let queryForeignKey = quotedProperty<'R, int> fkName
        fun ( context : 'C ) parentEntity -> 
            let id = queryPrimaryKey |> runExpr <| parentEntity
            <@ query { 
                for entity in context.Set<'R> () do
                where ( (%queryForeignKey) entity = id )
                select entity } @>

    //Define our EF navigator type.
    type NavigatorMemoize<'C, 'T, 'R when 'T : not struct
                                     and 'R : not struct
                                     and 'C : (new : unit -> 'C)
                                     and 'C :> DbContext> () =
        static let query =
            let tmpContext = new 'C ()
            let t = Unchecked.defaultof<'T>
            let r = Unchecked.defaultof<'R>
            navigatorQuery tmpContext t r
        static member Query = query

    //Function used to declare an EF navigator property.
    let navigator<'C, 'T, 'R when 'T : not struct
                             and 'R : not struct
                             and 'C : (new : unit -> 'C)
                             and 'C :> DbContext> entity =
        //TODO: new context not a good idea, it made things simpler though.
        let context = new 'C ()
        let q = NavigatorMemoize<'C, 'T, 'R>.Query
        entity |> q context |> runQuery

    //Seed function to run when the context is initialized.
    type ContextSeed =
    
        //Execute some data seeding on preparation.
        abstract OnSeed : unit -> unit

    //Migrate the context database if needed.
    type DatabaseCreate<'C when 'C :> DbContext 
                           and 'C :> ContextSeed> () =
        inherit CreateDatabaseIfNotExists<'C> ()

        //Seed the database when it's created for the first time.
        override this.Seed context =
            context.OnSeed ()            
 
    //Base connection
    type BaseDbConnection () = 
        [<ThreadStatic>] [<DefaultValue>] 
        static val mutable private instance : BaseDbConnection
        static member Instance = 
            if obj.ReferenceEquals ( BaseDbConnection.instance, null )
            then BaseDbConnection.instance <- new BaseDbConnection ()
            BaseDbConnection.instance
        member val Cns : DbConnection option = None with get, set

    //Setup the connection, inherit from this on contexts.
    //We replace the EF's default initialization behavior.
    type BaseDbContext<'C when 'C :> DbContext 
                           and 'C :> ContextSeed> () =
        inherit DbContext ( BaseDbContext<'C>.Connect () , false )
        
        //Use that specific database connection (per Thread).
        static member Connect () : DbConnection = 
            match BaseDbConnection.Instance.Cns with
            | Some i -> i
            | _ ->
                let d = System.Configuration.ConfigurationManager.ConnectionStrings
                let cns = d.Item "DefaultConnection"
                let prov = cns.ProviderName
                let factory = DbProviderFactories.GetFactory prov
                let cn = factory.CreateConnection ()
                cn.ConnectionString <- cns.ConnectionString
                cn

        //Do some preparation before.
        abstract PrepareDatabase : unit -> unit

        //We replace the default initializer with ours so we can get the Seed hook.
        default this.PrepareDatabase () =
            //FIXME: hack, find a better way to know if we are a debug build.
            #if DEBUG
            let lastest = new DatabaseCreate<'C> ()
            #else
            let lastest = new NullDatabaseInitializer<'C> ()
            #endif
            Database.SetInitializer<'C> lastest |> ignore
            this.Database.Initialize false

        //Forward a seed function.
        interface ContextSeed with

            //Do nothing here for now.
            override this.OnSeed () = ()

    //This is used only to create the database itself, regardless of the context.
    type EmptyContext () = 
        inherit BaseDbContext<EmptyContext> ()

        //Create the database when the preparation happens.
        override this.PrepareDatabase () =
            this.Database.CreateIfNotExists () |> ignore

DataSelection.fs

namespace EventHorizon.Backend.Model.Selection

open EventHorizon.Backend.Helpers
open EventHorizon.Backend.TypeHelpers

[<AutoOpen>]
module DataSelectionModule = 
 
    //Column name.
    type DataColumn = string

    //Column ordering.
    type Operator = 
        | LessThan 
        | LessOrEqualThan 
        | Equal 
        | GreaterOrEqualThan 
        | GreaterThan 
        | Like 

    //List of filters, filter are combined by logical AND.
    [<CLIMutable>]
    type DataFiltering<'T> = {
        Filters : ( DataColumn * obj * Operator ) list
    }
      
    //Column ordering.
    type Ordering = Ascending | Descending    

    //Data sorting.
    [<CLIMutable>]
    type DataSorting = {
        Columns : ( DataColumn * Ordering ) list
    }
      
    //Paging.
    [<CLIMutable>]
    type DataPaging = {
        PageNumber : int
        PageCount : int
        RecordCount : int
        TotalRecordCount : int
    }

    //Relational algebra selection (where/order).    
    [<CLIMutable>]
    type DataSelection<'T> = { 
        Sorter : DataSorting
        Paginator : DataPaging
        Filter : 'T DataFiltering
    } 
      
    //An input type to filter data.
    type DataSelect<'T> = 
        | AllData
        | Key of int
        | Selector of 'T DataSelection
        | Total of 'T DataFiltering
      
    //An output type for processed data.
    type DataReturn<'T> = 
        | Records of 'T seq
        | Totals of int
            
    //Helper function.
    let ofRecords = function
        | Records r -> r |> Seq.filter isNotNull
        | _ -> Seq.empty

    let nullListCheck l = l |> nullCheck |> whenNone ( fun _ -> [] )

    //Deep copy.
    let inline sortingDeepCopy o = 
        match nullCheck o with
        | Some s -> { Columns = s.Columns |> nullListCheck |> ( List.map id ) }
        | _ -> { Columns = [] }

    //Deep copy.
    let inline pagingDeepCopy o = 
        match nullCheck o with
        | Some p -> { PageNumber = p.PageNumber
                      PageCount = p.PageCount
                      RecordCount = p.RecordCount
                      TotalRecordCount = p.TotalRecordCount }
        | _ -> { PageNumber = 1
                 PageCount = 1
                 RecordCount = 10
                 TotalRecordCount = -1 }
        
    //Deep copy.
    let inline filteringDeepCopy o =
        match nullCheck o with
        | Some f -> 
            let copy ( columns, template, operator ) = ( columns, cloneObject template, operator )
            { Filters = f.Filters |> nullListCheck |> List.map copy }
        | _ -> 
            { Filters = [] }

    //Deep copy.
    let inline selectionDeepCopy s =
        { Sorter = s.Sorter |> sortingDeepCopy
          Paginator = s.Paginator |> pagingDeepCopy
          Filter = s.Filter |> filteringDeepCopy }

    //Deep copy.
    let inline selectorDeepCopy selector =
        match selector with
        | AllData -> AllData
        | Key i -> Key i
        | Selector s -> s |> selectionDeepCopy |> Selector
        | Total i -> i |> filteringDeepCopy |> Total

    //Provide a constructor for the cloning framework.    
    type DataSelection<'T> with
        static member Create ( from : obj ) = 
            let o = from :?> DataSelection<obj>
            selectionDeepCopy o
    
    //Provide a constructor for the cloning framework.    
    type DataFiltering<'T> with
        static member Create ( from : obj ) = 
            let o = from :?> DataFiltering<obj>
            filteringDeepCopy o

DataStore.fs

namespace EventHorizon.Backend.Model.ChangedData

open EventHorizon.Backend.Helpers

[<AutoOpen>]
module DataStoreModule = 
    
    //Type used to tell what kind of data we're working with,
    //used to avoid errors when misordering some parameters that have
    //the same type.
    type NewData<'T> = NewData of 'T with 
        member this.value = match this with NewData d -> d

    //Type used to encapsulate new data besides old data.
    type ChangedData<'T> = ChangedData of 'T option * 'T NewData option with 
        member this.value = match this with ChangedData ( a, b ) -> ( a, b )

    //Function used to encapsulate new data with no old data.
    let changedData data = 
        ChangedData ( None, Some ( NewData data ) )
    
    //Function used to create the before mentioned type.
    let toChangedData ( data, newData ) = 
        ( ChangedData ( data, newData ) )

    //Function used to retrieve new data from the encapsulated type or
    //the old one if there isn't any new data.
    let fromChangedData data = 
        match data with 
        | ChangedData ( _, Some ( NewData d ) ) -> d
        | ChangedData ( Some d, _ ) -> d
        | _ -> dbNull None

    //Obtain old data.
    let obtainChangedData readSome entity =
        let oldData = readSome entity
        let newData = NewData entity
        ( oldData, Some newData ) |> toChangedData
        
    //Mark old data as deleter.
    let markDeletedData entity =
        match entity with 
        | ChangedData ( Some d, _ ) -> 
            ChangedData ( Some d, None )
        | _ -> 
            ChangedData ( None, None )

EntitiesControllers.fs

namespace EventHorizon.Backend.Controller.Entity

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

type OldIdSelector = { Id : int }

type SubKeyType = int

type EntityController<'T when 'T : not struct> ( controller ) =
    inherit Controller<Entities, 'T, 'T> ( controller )

type ProcessEntityController<'T when 'T : not struct> ( controller ) =
    inherit ReadWriteController<Entities, 'T, 'T> ( controller )

type ReadOnlyEntityController<'T when 'T : not struct> ( controller ) =
    inherit ReadOnlyController<Entities, 'T, 'T> ( controller )

type SubEntityController<'T, 'S when 'T : not struct
                                 and 'S : not struct> ( controller ) =
    inherit ParametrizedReadOnlyController<Entities, 'S, SubKeyType, 'S> ( controller
        (
            fun context λ ->
                let tmp = entitySet context
                let entity : 'T = tmp.Create ()
                { entity with Id = id }
        ) )

type SubSubEntityController<'T, 'I, 'S when 'T : not struct
                                        and 'I : not struct
                                        and 'S : not struct> ( controller ) =
    inherit ParametrizedReadOnlyController<Entities, 'S, SubKeyType, 'S> ( controller )

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

module EntityModule =

    //Filter some input mask.
    let filterMask s =
        [| "/"; "."; "-"; "_" |]
        |> Seq.fold ( fun ( p : string ) i -> p.Replace ( i, String.Empty ) ) s

open EntityModule

type AddressController () =
    inherit EntityController<Address> ( controller simpleMapper )

type CustomerController () =
    inherit EntityController<Customer> ( controller
        <| onResult
        (
            eagerLoadEntry <@ Func<_, _> ( fun λ -> λ.Address ) @>
        )
        @+ onAddOrUpdate
        (
            fun ctx λ ->
                let changes =
                    { λ with
                        Eid = filterMask λ.Eid
                        Address =
                            { λ.Address with
                                PostalCode = filterMask λ.Address.PostalCode } }
                ctx.AddOrUpdate getId changes.Address |> ignore
                changes
        ) )

EntityController.fs

namespace EventHorizon.Backend.Controller.Entity

open System

open EventHorizon.Backend.Helpers
open EventHorizon.Backend.Controller
open EventHorizon.Backend.TypeHelpers
open EventHorizon.Backend.Model.Entities
open EventHorizon.Backend.Model.Selection
open EventHorizon.Backend.Model.ChangedData
open EventHorizon.Backend.ExpressionHelpers
open EventHorizon.Backend.Controller.Selector
open EventHorizon.Backend.Extension.DbContextModule
open EventHorizon.Backend.Model.HighOrder.EntitySetModule

[<AutoOpen>]
module EntityControllerModule =

    //Add traits and connect to the store.
    let inline controller mapper context operation =
        let table = entitySet context
        selectorController table.Query restController table.FindById operation
        |> mapper context
        |> mapResult table.AddOrUpdateMany table.DeleteMany

    //Add traits and connect to the store.
    let inline postController mapper context operation =
        let table = entitySet context
        let readSome = getId >> table.FindById
        let obtain = obtainChangedData readSome
        let deleted _ = markDeletedData
        selectorController table.Query rpcController table.FindById operation
        |> applyOperation ( Seq.map obtain )
        |> onRemove deleted None
        |> mapper context
        |> applyOperation ( Seq.map fromChangedData )
        |> mapResult table.AddOrUpdateMany table.DeleteMany

    //Add traits and connect to the store.
    let inline readOnlyController mapper context operation =
        let table = entitySet context
        selectorController table.Query readController table.FindById operation
        |> mapper context
        |> mapResult pass pass

    open SingleControllerModule

    //This is the relationship navigator controller.
    let subController mapper convert context operation parameter =
        let navigate = navigatorQuery context _tp<'T> _tp<'R>
        let readOne _ = None
        let readData _ =
            parameter
            |> convert context
            |> navigate context
            |> runQuery
            |> Seq.toList //stop lazy loading, fetch the IEnumerable
            |> Seq.ofList
            |> Records
        readController readData readOne <| Get None
        |> mapper context
        |> mapResult pass pass

    //Parametrized controller, inverse curried.
    let inline subSubController convert mapper =
        subController mapper convert

    //Custom query controller.
    let queryController query mapper context operation parameter =
        let readOne _ = None
        let readData _ =
            parameter
            |> query context
            |> runQuery
            |> Seq.toList //stop lazy loading, fetch the IEnumerable
            |> Seq.ofList
            |> Records
        readController readData readOne <| Get None
        |> mapper context
        |> mapResult pass pass

    //Encapsulate function to pass to onResult
    let onChangedResult fn ctx =
        let wrap c = fromChangedData >> fn c >> changedData
        onResult wrap ctx

    //Encapsulate function to pass to onOperation
    let onOperationResult filter ctx =
        onOperation ( fun _ -> filter ) ctx
        >> applyOperation ( Seq.filter Option.isSome )
        >> applyOperation ( Seq.map Option.get )

EntitySet.fs

namespace EventHorizon.Backend.Model.HighOrder

open System
open System.Linq
open System.Data.Entity
open Microsoft.FSharp.Quotations

open EventHorizon.Backend.ExpressionHelpers
open EventHorizon.Backend.Extension.DbContextModule

module EntitySetModule =

    //Just a type helper.
    type KeyType = int

    //Just a type helper.
    type EntityKey<'T> = ('T -> KeyType)
    
    //Just a type helper.
    type CompareEntity<'T> = ('T -> 'T -> bool)
            
    //Type T must have a member called Id that is a property 
    //of the type of the key.
    let inline getId ( entity : ^T ) =
        (^T : (member Id : KeyType) entity)

    //Type T must have a member called queryId that returns a
    //lambda expression that gets the value of a property of
    //the type of the key.
    let inline queryId () =
        (^T : (static member queryId : 'T EntityKey Expr) ())

    //Extended entity set for all the entities types.
    //This is our high-order type extended with the needed
    //functions that are common to all entities of that type.
    //We are actually emulating Haskell's type-classes here.
    type EntitySet<'T, 'C 
            when 'T : not struct
            and 'C :> DbContext> = {
        context : 'C
        getId : 'T EntityKey
        queryId : 'T EntityKey Expr
    } with
            
        //Add an entity or update an entity.
        member this.Create () =
            Activator.CreateInstance<'T> ()
  
        //Return a fresh entity for the specified id.
        member this.FindById id =
            <@ query { 
                for entity in this.context.Set<'T> () do
                where ( (%this.queryId) entity = id )
                select entity } @>
            |> runQuery |> Seq.tryHead
            
        //List all the entities of the type.
        member this.Seq () =
            this.context.Seq<'T> ()

        //Add an entity or update an entity.
        member this.AddOrUpdate entity =
            this.context.AddOrUpdate<'T> this.getId entity

        //Add or update a list of entities.
        member this.AddOrUpdateMany entities =
            this.context.AddOrUpdateMany<'T> this.getId entities

        //Remove or delete an entity.
        member this.DeleteMany entity =
            this.context.DeleteMany<'T> this.getId entity
                        
        //Return an IQueryable for the type.
        member this.Query () =
            <@ query { 
                for entity in this.context.Set<'T> () do
                select entity } @>

        //Count the records.
        member this.Count () =
            <@ query { 
                for entity in this.context.Set<'T> () do
                count } @>
            |> runQueryValue

    //This function specialize the type because the dotnet framework doesn't 
    //support generalized high-order types on object definitions.
    //Template is only used to know the correct entity type, you can use None
    //for F# to infer it, it will return an infered EntitySet type.
    let inline entitySet context =
        {   
            context = context
            getId = getId
            queryId = queryId ()
        }

FrontendController.fs

namespace EventHorizon.Frontend.Controller

open System
open System.Net
open System.Web
open System.Linq
open System.Web.Mvc
open System.Net.Http

open EventHorizon.Backend.Helpers
open EventHorizon.Backend.Controller
open EventHorizon.Backend.TypeHelpers
open EventHorizon.Backend.Model.Queues
open EventHorizon.Backend.WebApiHelpers
open EventHorizon.Backend.Model.Entities
open EventHorizon.Backend.Model.Selection
open EventHorizon.Backend.Controller.Queue
open EventHorizon.Backend.Controller.Entity
open EventHorizon.Backend.Controller.Selector
open EventHorizon.Backend.Controller.Identity

open EventHorizon.Frontend.Model
open EventHorizon.Frontend.Extension.ViewDataExtension

[<AutoOpen>]
module RouteControllerModule =

    type InputOverload = 
        | All 
        | Id of int Nullable
        | Filter of string
        | Total of string
        | Parameter of (int * int Nullable)

    let inline fGetAll ( controller : ^C ) =
        fun () -> (^C : (member GetAll : unit -> 'T seq) ( controller ) )
        
    let inline fGetById ( controller : ^C ) =
        fun id -> (^C : (member GetById : int Nullable -> 'T seq) ( controller, id ) )

    let inline fGetByFilter ( controller : ^C ) =
        fun query -> (^C : (member GetByFilter : string -> 'T seq) ( controller, query ) )

    let inline fGetTotal ( controller : ^C ) =
        fun query -> (^C : (member GetTotal : string -> int) ( controller, query ) )
        
    let inline fGetParameter ( controller : ^C ) =
        fun i1 i2 -> (^C : (member Get : int * int Nullable -> 'T seq) ( controller, i1, i2 ) )

    type Backend ( m : Type , vm : Type, f : InputOverload -> obj seq ) = 
        member this.M = m
        member this.VM = vm
        member this.Fn = f

    let inline backend<'M, 'C, 'VM when 'C : (new : unit -> 'C) 
                                    and 'C : (member GetAll : unit -> 'M seq) 
                                    and 'C : (member GetById : int Nullable -> 'M seq)
                                    and 'C : (member GetByFilter : string -> 'M seq)
                                    and 'C : (member GetTotal : string -> int) > () = 
        let c = new 'C ()
        let outp = Seq.map ( cloneObject<'VM> >> box )
        let outv = box >> Seq.singleton
        let runController input = 
            match input with 
            | All         -> () |> fGetAll c |> outp
            | Id i        -> i  |> fGetById c |> outp
            | Filter f    -> f  |> fGetByFilter c |> outp
            | Total t     -> t  |> fGetTotal c |> outv
            | _ -> Seq.empty
        Backend ( typeof<'M>, typeof<'VM>, runController )
        
    let inline backend2<'M, 'C, 'VM when 'C : (new : unit -> 'C) 
                                    and 'C : (member Get : int * int Nullable -> 'M seq) > () = 
        let c = new 'C ()
        let outp = Seq.map ( cloneObject<'VM> >> box )
        let runController input = 
            match input with 
            | Parameter ( p1, p2 ) -> fGetParameter c p1 p2 |> outp
            | _ -> Seq.empty
        Backend ( typeof<'M>, typeof<'VM>, runController )

    let typeList = [|
        backend< Address         , AddressController         , AddressModel         > ()
        backend< Customer        , CustomerController        , CustomerModel        > ()
        backend< Journal         , JournalController         , JournalModel         > ()
    |]
    
    let typeList2 = [|
        backend2< CustomerProduct     , CustomerCustomerProductController    , CustomerProductModel     > ()
        backend2< UserPermission      , UserUserPermissionController         , UserPermissionModel      > ()
        backend2< SaleProduct         , SaleSaleProductController            , SaleProductModel         > ()
        backend2< PaymentItem         , PaymentPaymentItemController         , PaymentItemModel         > ()
        backend2< PaymentItemSelector , PaymentPaymentItemSelectorController , PaymentItemSelectorModel > ()
    |]
    
    let tryFind ( name : string ) types =
        types 
        |> Seq.tryFind ( fun ( b : Backend ) -> b.VM.Name.ToLower () = name + "model" )

    let mapController controllers name input =
        controllers
        |> tryFind name
        |> whenSome ( fun i -> i.Fn input )
        |> whenNone ( fun _ -> Seq.empty )
    
    let noLazy = Seq.toList >> Seq.ofList

    let controllerGetAll this entity =
        All 
        |> mapController typeList entity
        |> noLazy
        
    let controllerGetId this entity id =
        Id id 
        |> mapController typeList entity
        |> noLazy
        |> Seq.head
        
    let controllerGetFilter this entity selector =
        selector 
        |> encodeParameter 
        |> Filter 
        |> mapController typeList entity
        |> noLazy

    let controllerGetTotal this entity filter =
        filter  
        |> encodeParameter 
        |> Total 
        |> mapController typeList entity
        |> Seq.tryHead 
        |> whenSome unbox
        |> whenNone ( fun _ -> 0 )
                
    let controllerGetParameter this entity parameter id =
        ( parameter, id )
        |> Parameter  
        |> mapController typeList2 entity
        |> noLazy

[<Authorize>]
[<HandleError>]
type EntityController () =
    inherit Controller ()
        
    member this.Create ( entity, parent : int Nullable ) =
        SetEntity this entity
        SetParentEntity this parent
        this.PartialView ( entity + "/Create" )
        :> ActionResult
    
    member this.Update ( entity, id ) =
        let data = controllerGetId this entity id
        SetEntity this entity
        this.PartialView ( entity + "/Update", data )
        :> ActionResult

    member this.Delete ( entity, id ) =
        let data = controllerGetId this entity id
        SetEntity this entity
        this.PartialView ( entity + "/Delete", data )
        :> ActionResult

    member this.List ( entity, selector : Selector ) =
        let sel = selector.ToBackEnd ()
        let tot = controllerGetTotal this entity sel.Filter
        let data = controllerGetFilter this entity sel
        let nsel = selector.UpdateTotal tot
        SetEntity this entity
        SetEntityData this data
        SetParameter this nsel
        this.PartialView ( entity + "/List" )
        :> ActionResult
        
    member this.ListBy ( entity, parent : int Nullable ) =
        let key = parent.GetValueOrDefault ()
        let data = controllerGetParameter this entity key parent
        SetEntity this entity
        SetEntityData this data
        SetParentEntity this parent
        this.PartialView ( entity + "/List" )
        :> ActionResult

Model.fs

namespace EventHorizon.Backend.Model.Entities

open System
open System.ComponentModel.DataAnnotations
open System.ComponentModel.DataAnnotations.Schema

open EventHorizon.Backend.Helpers
open EventHorizon.Backend.Model.Config
open EventHorizon.Backend.Extension.DbContextModule
open EventHorizon.Backend.Extension.DbModelBuilderModule
open EventHorizon.Backend.Model.HighOrder.EntitySetModule

[<CLIMutable>]
type Address = {
    Id : int
    StreetName : string
    StreetNumber : string
    Complement : string
    Region : string
    City : string
    State : string
    Country : string
    PostalCode : string
}

[<CLIMutable>]
type Customer = {
    Id : int
    Name : string
    SocialName : string
    Eid : string
    AddressId : int
    Address : Address
}

[<CLIMutable>]
type Journal = {
    Id : int
    Key : int
    EquipmentId : int
    Customer : Customer
    CustomerId : int
    Quantity : Decimal Nullable
    SalePrice : Decimal Nullable
    Total : Decimal Nullable
}

type Entities () =
    inherit BaseDbContext<Entities> ()
    
    member val Addresses        = table<Address> ()          with get, set
    member val Customers        = table<Customer> ()         with get, set
    member val Journals         = table<Journal> ()          with get, set

    override this.OnModelCreating modelBuilder =
        modelBuilder
            .DefaultConfiguration( this )
            .Require( fun ( λ : User )      -> λ.Salt )
            .Relationship( (fun ( λ : Customer )          -> λ.Address),     (fun λ -> λ.AddressId)     )
            .Relationship( (fun ( λ : Journal )           -> λ.Customer),    (fun λ -> λ.CustomerId)    )
            .UniqueKey( (fun ( λ : Journal )              -> λ.EquipmentId), (fun λ -> λ.Key)           )
        |> ignore

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

type Address with
    static member queryId = <@ fun ( λ : Address ) -> λ.Id @>

type Journal with
    static member queryId = <@ fun ( λ : Journal ) -> λ.Id @>

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

type Journal with
    static member queryUniqueKey = <@ fun ( λ : Journal ) customer key ->
        λ.CustomerId = customer && λ.Key = key @>

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

type Journal with
    member λ.UniqueKey = ( λ.EquipmentId, λ.Key )

Server.fs

namespace EventHorizon.Backend

open Owin
open System
open log4net
open System.Web
open Newtonsoft.Json
open System.Web.Http
open System.Web.Routing
open Elmah.Contrib.WebApi
open System.Web.Http.Tracing
open Microsoft.Owin.Security
open System.Web.Http.Controllers
open System.Web.Http.ModelBinding
open Microsoft.Owin.Security.OAuth
open Microsoft.Owin.Security.Cookies
open System.Web.Http.ExceptionHandling
open System.Web.Http.ModelBinding.Binders

open EventHorizon.Backend.Model
open EventHorizon.Backend.Helpers
open EventHorizon.Backend.Controller
open EventHorizon.Backend.TypeHelpers
open EventHorizon.Backend.Authorization
open EventHorizon.Backend.WebApiHelpers

type ApiRouteTerminal = { 
    controller : string
    key : RouteParameter
    action : string }

module GlobalConfig =

    // Maps a route to a controller that inherits from a the specified base type in some namespace.
    let mapHttpRoute addRoutes name isInNamespace ( route : string ) ( tbase : Type ) =
        let assemb = System.Reflection.Assembly.GetCallingAssembly ()
        assemb.GetTypes () 
        |> Seq.filter ( fun t -> not t.IsAbstract && not t.IsGenericType && 
                                 t.IsDerivedFromOpenGenericType tbase )
        |> Seq.filter ( fun t -> isInNamespace t.Namespace )
        |> Seq.iter ( fun t ->
            let tpath = 
                t.BaseType.GetGenericArguments () 
                |> Seq.map ( fun i -> i.Name )
                |> Seq.reduce ( fun l i -> l + "/" + i ) 
            let tCustomPath =
                t.GetCustomAttributes ( typeof<CustomRoute>, true )
                |> Seq.cast<CustomRoute>
                |> Seq.tryHead
                |> whenSome ( fun i -> i.Template )
            let routeName = name + "_" + t.FullName
            let routeArityPath = tCustomPath |> whenNone ( fun () -> tpath )
            let routePath = route.Replace ( "{controller}", routeArityPath )
            let controllerName = t.Name.Replace ( "Controller", String.Empty )
            addRoutes 
                routeName
                routePath
                { controller = controllerName
                  key = RouteParameter.Optional
                  action = String.Empty } )
            |> ignore