Skip to content

Instantly share code, notes, and snippets.

@Luiz-Monad

Luiz-Monad/Config.fs

Created June 15, 2023 17:01
Show Gist options
  • Save Luiz-Monad/10afdde804e384efa7ff1920b8171218 to your computer and use it in GitHub Desktop.
Save Luiz-Monad/10afdde804e384efa7ff1920b8171218 to your computer and use it in GitHub Desktop.
Download ZIP
EventHorizon is a framework for creating MVVM applications [WIP in progress] (all rights reserved for now)
Raw
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 )
Raw
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
Raw
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
Raw
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 )
Raw
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
) )
Raw
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 )
Raw
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 ()
}
Raw
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
Raw
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 )
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment