diff --git a/src/App.fs b/src/App.fs new file mode 100644 index 0000000..16b209e --- /dev/null +++ b/src/App.fs @@ -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/") } + +[] +let main argv = + // Establish the data environment + liftDep getConn (Data.establishEnvironment >> Async.RunSynchronously) + |> run deps + + startWebServer suaveCfg app + 0 diff --git a/src/Data.fs b/src/Data.fs new file mode 100644 index 0000000..9a00f7e --- /dev/null +++ b/src/Data.fs @@ -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 + [] + let Request = "Request" + /// The table for users + [] + let User = "User" + +/// Extensions for the RethinkDB connection +[] +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 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 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 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 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" + } diff --git a/src/Dependencies.fs b/src/Dependencies.fs new file mode 100644 index 0000000..7d42fd6 --- /dev/null +++ b/src/Dependencies.fs @@ -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 + +[] +module DependencyExtraction = + + let getConn (deps : IDependencies) = deps.Conn diff --git a/src/Entities.fs b/src/Entities.fs new file mode 100644 index 0000000..4451b93 --- /dev/null +++ b/src/Entities.fs @@ -0,0 +1,74 @@ +namespace MyPrayerJournal + +open Newtonsoft.Json + +/// A user +type User = { + /// The Id of the user + [] + 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 + [] + 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 diff --git a/src/Extensions.fs b/src/Extensions.fs new file mode 100644 index 0000000..8b0b7d3 --- /dev/null +++ b/src/Extensions.fs @@ -0,0 +1,16 @@ +[] +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 diff --git a/src/Program.fs b/src/Program.fs deleted file mode 100644 index d832473..0000000 --- a/src/Program.fs +++ /dev/null @@ -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." - ] -[] -let main argv = - let config = - { defaultConfig with homeFolder = Some (Path.GetFullPath "./wwwroot/") } - - startWebServer config app - 0 // return an integer exit code diff --git a/src/project.json b/src/project.json index db60d1e..b6c0451 100644 --- a/src/project.json +++ b/src/project.json @@ -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-*" +} \ No newline at end of file