Brought in data model / dependencies

A combination of the previous effort plus a few things swiped from
Quatro
This commit is contained in:
Daniel J. Summers 2016-12-12 22:29:05 -06:00
parent 864777a831
commit da6910e055
7 changed files with 332 additions and 36 deletions

36
src/App.fs Normal file
View File

@ -0,0 +1,36 @@
/// Main server module for myPrayerJournal
module MyPrayerJournal.App
open Reader
open System.IO
open Suave
open Suave.Filters
open Suave.Operators
/// Data Configuration singleton
let lazyCfg = lazy (DataConfig.FromJson <| try File.ReadAllText "data-config.json" with _ -> "{}")
/// RethinkDB connection singleton
let lazyConn = lazy lazyCfg.Force().CreateConnection ()
/// Application dependencies
let deps = {
new IDependencies with
member __.Conn with get () = lazyConn.Force ()
}
/// Suave application
let app : WebPart =
choose [
GET >=> Files.browseHome
GET >=> Files.browseFileHome "index.html"
RequestErrors.NOT_FOUND "Page not found."
]
let suaveCfg = { defaultConfig with homeFolder = Some (Path.GetFullPath "./wwwroot/") }
[<EntryPoint>]
let main argv =
// Establish the data environment
liftDep getConn (Data.establishEnvironment >> Async.RunSynchronously)
|> run deps
startWebServer suaveCfg app
0

130
src/Data.fs Normal file
View File

@ -0,0 +1,130 @@
namespace MyPrayerJournal
open Chiron
open RethinkDb.Driver
open RethinkDb.Driver.Net
open System
type ConfigParameter =
| Hostname of string
| Port of int
| AuthKey of string
| Timeout of int
| Database of string
type DataConfig = { Parameters : ConfigParameter list }
with
member this.CreateConnection () : IConnection =
let folder (builder : Connection.Builder) block =
match block with
| Hostname x -> builder.Hostname x
| Port x -> builder.Port x
| AuthKey x -> builder.AuthKey x
| Timeout x -> builder.Timeout x
| Database x -> builder.Db x
let bldr =
this.Parameters
|> Seq.fold folder (RethinkDB.R.Connection ())
upcast bldr.Connect()
member this.Database =
match this.Parameters
|> List.filter (fun x -> match x with Database _ -> true | _ -> false)
|> List.tryHead with
| Some (Database x) -> x
| _ -> RethinkDBConstants.DefaultDbName
static member FromJson json =
match Json.parse json with
| Object config ->
let options =
config
|> Map.toList
|> List.map (fun item ->
match item with
| "Hostname", String x -> Hostname x
| "Port", Number x -> Port <| int x
| "AuthKey", String x -> AuthKey x
| "Timeout", Number x -> Timeout <| int x
| "Database", String x -> Database x
| key, value ->
invalidOp <| sprintf "Unrecognized RethinkDB configuration parameter %s (value %A)" key value)
{ Parameters = options }
| _ -> { Parameters = [] }
/// Tables for data storage
module DataTable =
/// The table for prayer requests
[<Literal>]
let Request = "Request"
/// The table for users
[<Literal>]
let User = "User"
/// Extensions for the RethinkDB connection
[<RequireQualifiedAccess>]
module Data =
let private r = RethinkDB.R
/// Set up the environment for MyPrayerJournal
let establishEnvironment (conn : IConnection) =
/// Shorthand for the database
let db () = r.Db "myPrayerJournal"
// Be chatty about what we're doing
let mkStep = sprintf "[MyPrayerJournal] %s"
let logStep = mkStep >> Console.WriteLine
let logStepStart = mkStep >> Console.Write
let logStepEnd () = Console.WriteLine " done"
/// Ensure the database exists
let checkDatabase () =
async {
logStep "|> Checking database"
let! dbList = r.DbList().RunResultAsync<string list> conn
match dbList |> List.contains "myPrayerJournal" with
| true -> ()
| _ ->
logStepStart " Database not found - creating..."
do! r.DbCreate("myPrayerJournal").RunResultAsync conn
logStepEnd ()
}
/// Ensure all tables exit
let checkTables () =
async {
logStep "|> Checking tables"
let! tables = db().TableList().RunResultAsync<string list> conn
[ DataTable.Request; DataTable.User ]
|> List.filter (fun tbl -> not (tables |> List.contains tbl))
|> List.map (fun tbl ->
async {
logStepStart <| sprintf " %s table not found - creating..." tbl
do! db().TableCreate(tbl).RunResultAsync conn
logStepEnd()
})
|> List.iter Async.RunSynchronously
}
/// Ensure the proper indexes exist
let checkIndexes () =
async {
logStep "|> Checking indexes"
let! reqIdx = db().Table(DataTable.Request).IndexList().RunResultAsync<string list> conn
match reqIdx |> List.contains "UserId" with
| true -> ()
| _ ->
logStepStart <| sprintf " %s.UserId index not found - creating..." DataTable.Request
do! db().Table(DataTable.Request).IndexCreate("UserId").RunResultAsync conn
logStepEnd ()
let! usrIdx = db().Table(DataTable.User).IndexList().RunResultAsync<string list> conn
match usrIdx |> List.contains "Email" with
| true -> ()
| _ ->
logStepStart <| sprintf " %s.Email index not found - creating..." DataTable.User
do! db().Table(DataTable.User).IndexCreate("Email").RunResultAsync conn
logStepEnd ()
}
async {
logStep "Database checks starting"
do! checkDatabase ()
do! checkTables ()
do! checkIndexes ()
logStep "Database checks complete"
}

48
src/Dependencies.fs Normal file
View File

@ -0,0 +1,48 @@
namespace MyPrayerJournal
open RethinkDb.Driver.Net
// -- begin code lifted from #er demo --
type ReaderM<'d, 'out> = 'd -> 'out
module Reader =
// basic operations
let run dep (rm : ReaderM<_,_>) = rm dep
let constant (c : 'c) : ReaderM<_,'c> = fun _ -> c
// lifting of functions and state
let lift1 (f : 'd -> 'a -> 'out) : 'a -> ReaderM<'d, 'out> = fun a dep -> f dep a
let lift2 (f : 'd -> 'a -> 'b -> 'out) : 'a -> 'b -> ReaderM<'d, 'out> = fun a b dep -> f dep a b
let lift3 (f : 'd -> 'a -> 'b -> 'c -> 'out) : 'a -> 'b -> 'c -> ReaderM<'d, 'out> = fun a b c dep -> f dep a b c
let liftDep (proj : 'd2 -> 'd1) (rm : ReaderM<'d1, 'output>) : ReaderM<'d2, 'output> = proj >> rm
// functor
let fmap (f : 'a -> 'b) (g : 'c -> 'a) : ('c -> 'b) = g >> f
let map (f : 'a -> 'b) (rm : ReaderM<'d, 'a>) : ReaderM<'d,'b> = rm >> f
let (<?>) = map
// applicative-functor
let apply (f : ReaderM<'d, 'a->'b>) (rm : ReaderM<'d, 'a>) : ReaderM<'d, 'b> =
fun dep ->
let f' = run dep f
let a = run dep rm
f' a
let (<*>) = apply
// monad
let bind (rm : ReaderM<'d, 'a>) (f : 'a -> ReaderM<'d,'b>) : ReaderM<'d, 'b> =
fun dep ->
f (rm dep)
|> run dep
let (>>=) = bind
type ReaderMBuilder internal () =
member __.Bind(m, f) = m >>= f
member __.Return(v) = constant v
member __.ReturnFrom(v) = v
member __.Delay(f) = f ()
let reader = ReaderMBuilder()
// -- end code lifted from #er demo --
type IDependencies =
abstract Conn : IConnection
[<AutoOpen>]
module DependencyExtraction =
let getConn (deps : IDependencies) = deps.Conn

74
src/Entities.fs Normal file
View File

@ -0,0 +1,74 @@
namespace MyPrayerJournal
open Newtonsoft.Json
/// A user
type User = {
/// The Id of the user
[<JsonProperty("id")>]
Id : string
/// The user's e-mail address
Email : string
/// The user's name
Name : string
/// The time zone in which the user resides
TimeZone : string
/// The last time the user logged on
LastSeenOn : int64
}
with
/// An empty User
static member Empty =
{ Id = ""
Email = ""
Name = ""
TimeZone = ""
LastSeenOn = int64 0 }
/// Request history entry
type History = {
/// The instant at which the update was made
AsOf : int64
/// The action that was taken on the request
Action : string list
/// The status of the request (filled if it changed)
Status : string option
/// The text of the request (filled if it changed)
Text : string option
}
/// A prayer request
type Request = {
/// The Id of the request
[<JsonProperty("id")>]
Id : string
/// The Id of the user to whom this request belongs
UserId : string
/// The instant this request was entered
EnteredOn : int64
/// The history for this request
History : History list
}
with
/// The current status of the prayer request
member this.Status =
this.History
|> List.sortBy (fun item -> -item.AsOf)
|> List.map (fun item -> item.Status)
|> List.filter Option.isSome
|> List.map Option.get
|> List.head
/// The current text of the prayer request
member this.Text =
this.History
|> List.sortBy (fun item -> -item.AsOf)
|> List.map (fun item -> item.Text)
|> List.filter Option.isSome
|> List.map Option.get
|> List.head
member this.LastActionOn =
this.History
|> List.sortBy (fun item -> -item.AsOf)
|> List.map (fun item -> item.AsOf)
|> List.head

16
src/Extensions.fs Normal file
View File

@ -0,0 +1,16 @@
[<AutoOpen>]
module MyPrayerJournal.Extensions
open System.Threading.Tasks
// H/T: Suave
type AsyncBuilder with
/// An extension method that overloads the standard 'Bind' of the 'async' builder. The new overload awaits on
/// a standard .NET task
member x.Bind(t : Task<'T>, f:'T -> Async<'R>) : Async<'R> = async.Bind (Async.AwaitTask t, f)
/// An extension method that overloads the standard 'Bind' of the 'async' builder. The new overload awaits on
/// a standard .NET task which does not commpute a value
member x.Bind(t : Task, f : unit -> Async<'R>) : Async<'R> = async.Bind (Async.AwaitTask t, f)
member x.ReturnFrom(t : Task<'T>) : Async<'T> = Async.AwaitTask t

View File

@ -1,22 +0,0 @@
// Learn more about F# at http://fsharp.org
open System.IO
open Suave
open Suave.Filters
open Suave.Operators
let app : WebPart =
choose [
//GET >=> path "/" >=> Files.file "index.html"
//GET >=> path "" >=> Files.file "index.html"
GET >=> Files.browseHome
GET >=> Files.browseFileHome "index.html"
RequestErrors.NOT_FOUND "Page not found."
]
[<EntryPoint>]
let main argv =
let config =
{ defaultConfig with homeFolder = Some (Path.GetFullPath "./wwwroot/") }
startWebServer config app
0 // return an integer exit code

View File

@ -1,30 +1,44 @@
{
"version": "1.0.0-*",
"buildOptions": {
"debugType": "portable",
"emitEntryPoint": true,
"compilerName": "fsc",
"compile": {
"includeFiles": [
"Program.fs"
"Extensions.fs",
"Entities.fs",
"Dependencies.fs",
"Data.fs",
"App.fs"
]
}
},
"compilerName": "fsc",
"debugType": "portable",
"emitEntryPoint": true,
"outputName": "myPrayerJournal"
},
"dependencies": {
"Chiron": "6.2.1",
"Newtonsoft.Json": "9.0.1",
"RethinkDb.Driver": "2.3.15",
"Suave": "2.0.0-rc2"
},
"tools": {
"dotnet-compile-fsc": "1.0.0-preview2.1-*"
},
"frameworks": {
"netcoreapp1.1": {
"dependencies": {
"Microsoft.FSharp.Core.netcore": "1.0.0-alpha-161111",
"Microsoft.NETCore.App": {
"type": "platform",
"version": "1.1.0"
},
"Microsoft.FSharp.Core.netcore": "1.0.0-alpha-161111"
}
}
},
"imports": [
"portable-net45+win8+dnxcore50",
"portable-net45+win8",
"net452",
"dnxcore50"
]
}
}
}
},
"tools": {
"dotnet-compile-fsc": "1.0.0-preview2.1-*"
},
"version": "0.8.1-*"
}