From 1251c28a89aba696e341db6636f473dd915959a9 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Fri, 23 Sep 2016 22:06:14 -0500 Subject: [PATCH] More plumbing App now starts with a very basic layout --- src/MyPrayerJournal/App.fs | 122 ++++++++++++++++-- src/MyPrayerJournal/Data.fs | 35 ++++-- src/MyPrayerJournal/Entities.fs | 12 ++ src/MyPrayerJournal/HomeModule.fs | 15 +++ src/MyPrayerJournal/Keys.fs | 14 +++ src/MyPrayerJournal/Strings.fs | 40 ++++++ src/MyPrayerJournal/UserModule.fs | 18 +++ src/MyPrayerJournal/ViewModels.fs | 140 +++++++++++++++++++++ src/MyPrayerJournal/project.json | 37 ++++-- src/MyPrayerJournal/resources/en-US.json | 8 ++ src/MyPrayerJournal/views/home/index.html | 5 + src/MyPrayerJournal/views/layout.html | 60 +++++++++ src/MyPrayerJournal/views/user/log-on.html | 40 ++++++ 13 files changed, 515 insertions(+), 31 deletions(-) create mode 100644 src/MyPrayerJournal/HomeModule.fs create mode 100644 src/MyPrayerJournal/Keys.fs create mode 100644 src/MyPrayerJournal/Strings.fs create mode 100644 src/MyPrayerJournal/UserModule.fs create mode 100644 src/MyPrayerJournal/ViewModels.fs create mode 100644 src/MyPrayerJournal/resources/en-US.json create mode 100644 src/MyPrayerJournal/views/home/index.html create mode 100644 src/MyPrayerJournal/views/layout.html create mode 100644 src/MyPrayerJournal/views/user/log-on.html diff --git a/src/MyPrayerJournal/App.fs b/src/MyPrayerJournal/App.fs index bef701f..f3bb363 100644 --- a/src/MyPrayerJournal/App.fs +++ b/src/MyPrayerJournal/App.fs @@ -1,11 +1,23 @@ -module App +module MyPrayerJournal.App -open MyPrayerJournal +open Microsoft.AspNetCore.Builder +open Microsoft.AspNetCore.Hosting open Nancy +open Nancy.Authentication.Forms +open Nancy.Bootstrapper +open Nancy.Cryptography open Nancy.Owin -open Suave.Web -open Suave.Owin +open Nancy.Security +open Nancy.Session.Persistable +open Nancy.Session.RethinkDB +open Nancy.TinyIoc +open Nancy.ViewEngines.SuperSimpleViewEngine +open NodaTime +open RethinkDb.Driver.Net open System +open System.Reflection +open System.Security.Claims +open System.Text.RegularExpressions /// Establish the configuration let cfg = AppConfig.FromJson (System.IO.File.ReadAllText "config.json") @@ -13,8 +25,104 @@ let cfg = AppConfig.FromJson (System.IO.File.ReadAllText "config.json") do cfg.DataConfig.Conn.EstablishEnvironment () |> Async.RunSynchronously +/// Support i18n/l10n via the @Translate SSVE alias +type TranslateTokenViewEngineMatcher() = + static let regex = Regex("@Translate\.(?[a-zA-Z0-9-_]+);?", RegexOptions.Compiled) + interface ISuperSimpleViewEngineMatcher with + member this.Invoke (content, model, host) = + let translate (m : Match) = Strings.get m.Groups.["TranslationKey"].Value + regex.Replace(content, translate) + +/// Handle forms authentication +type AppUser(name, claims) = + inherit ClaimsPrincipal() + member this.UserName with get() = name + member this.Claims with get() = claims + +type AppUserMapper(container : TinyIoCContainer) = + + interface IUserMapper with + member this.GetUserFromIdentifier (identifier, context) = + match context.Request.PersistableSession.GetOrDefault(Keys.User, User.Empty) with + | user when user.Id = string identifier -> upcast AppUser(user.Name, [ "LoggedIn" ]) + | _ -> null + + +/// Set up the application environment +type AppBootstrapper() = + inherit DefaultNancyBootstrapper() + + override this.ConfigureRequestContainer (container, context) = + base.ConfigureRequestContainer (container, context) + /// User mapper for forms authentication + ignore <| container.Register() + + override this.ConfigureApplicationContainer (container) = + base.ConfigureApplicationContainer container + ignore <| container.Register(cfg) + ignore <| container.Register(cfg.DataConfig.Conn) + // NodaTime + ignore <| container.Register(SystemClock.Instance) + // I18N in SSVE + ignore <| container.Register> + (fun _ _ -> + Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher)) + + override this.ApplicationStartup (container, pipelines) = + base.ApplicationStartup (container, pipelines) + // Forms authentication configuration + let auth = + FormsAuthenticationConfiguration( + CryptographyConfiguration = + CryptographyConfiguration( + AesEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)), + DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))), + RedirectUrl = "~/user/log-on", + UserMapper = container.Resolve()) + FormsAuthentication.Enable (pipelines, auth) + // CSRF + Csrf.Enable pipelines + // Sessions + let sessions = RethinkDBSessionConfiguration(cfg.DataConfig.Conn) + sessions.Database <- cfg.DataConfig.Database + PersistableSessions.Enable (pipelines, sessions) + () + + override this.Configure (environment) = + base.Configure environment + environment.Tracing(true, true) + + +let version = + let v = typeof.GetType().GetTypeInfo().Assembly.GetName().Version + match v.Build with + | 0 -> match v.Minor with 0 -> string v.Major | _ -> sprintf "%d.%d" v.Major v.Minor + | _ -> sprintf "%d.%d.%d" v.Major v.Minor v.Build + |> sprintf "v%s" + +/// Set up the request environment +type RequestEnvironment() = + interface IRequestStartup with + member this.Initialize (pipelines, context) = + pipelines.BeforeRequest.AddItemToStartOfPipeline + (fun ctx -> + ctx.Items.[Keys.RequestStart] <- DateTime.Now.Ticks + ctx.Items.[Keys.Version] <- version + null) + +type Startup() = + member this.Configure (app : IApplicationBuilder) = + ignore <| app.UseOwin(fun x -> x.UseNancy(fun opt -> opt.Bootstrapper <- new AppBootstrapper()) |> ignore) + [] let main argv = - let app = OwinApp.ofMidFunc "/" (NancyMiddleware.UseNancy(NancyOptions())) - startWebServer defaultConfig app - 0 // return an integer exit code +// let app = OwinApp.ofMidFunc "/" (NancyMiddleware.UseNancy(fun opt -> opt.Bootstrapper <- new AppBootstrapper())) +// startWebServer defaultConfig app +// 0 // return an integer exit code + WebHostBuilder() + .UseContentRoot(System.IO.Directory.GetCurrentDirectory()) + .UseKestrel() + .UseStartup() + .Build() + .Run() + 0 \ No newline at end of file diff --git a/src/MyPrayerJournal/Data.fs b/src/MyPrayerJournal/Data.fs index bbaf113..56ad052 100644 --- a/src/MyPrayerJournal/Data.fs +++ b/src/MyPrayerJournal/Data.fs @@ -1,8 +1,10 @@ [] module Data +open MyPrayerJournal open Newtonsoft.Json open RethinkDb.Driver +open RethinkDb.Driver.Ast open RethinkDb.Driver.Net open System @@ -20,6 +22,17 @@ module DataTable = /// Extensions for the RethinkDB connection type IConnection with + /// Log on a user + member this.LogOnUser (email : string) (passwordHash : string) = + async { + let! user = r.Table(DataTable.User) + .GetAll(email).OptArg("index", "Email") + .Filter(ReqlFunction1(fun usr -> upcast usr.["PasswordHash"].Eq(passwordHash))) + .RunResultAsync(this) + |> Async.AwaitTask + return match box user with null -> None | _ -> Some user + } + /// Set up the environment for MyPrayerJournal member this.EstablishEnvironment () = /// Shorthand for the database @@ -29,45 +42,45 @@ type IConnection with /// Ensure the database exists let checkDatabase () = async { - logStep "|> Checking database..." + logStep "|> Checking database" let! dbList = r.DbList().RunResultAsync(this) |> Async.AwaitTask match dbList |> List.contains "MyPrayerJournal" with | true -> () - | _ -> logStep " Database not found - creating..." + | _ -> logStep " Database not found - creating..." do! r.DbCreate("MyPrayerJournal").RunResultAsync(this) |> Async.AwaitTask |> Async.Ignore - logStep " ...done" + logStep " ...done" } /// Ensure all tables exit let checkTables () = async { - logStep "|> Checking tables..." + logStep "|> Checking tables" let! tables = db().TableList().RunResultAsync(this) |> Async.AwaitTask [ DataTable.Request; DataTable.User ] |> List.filter (fun tbl -> not (tables |> List.contains tbl)) |> List.map (fun tbl -> async { - logStep <| sprintf " %s table not found - creating..." tbl + logStep <| sprintf " %s table not found - creating..." tbl do! db().TableCreate(tbl).RunResultAsync(this) |> Async.AwaitTask |> Async.Ignore - logStep " ...done" + logStep " ...done" }) |> List.iter Async.RunSynchronously } /// Ensure the proper indexes exist let checkIndexes () = async { - logStep "|> Checking indexes..." + logStep "|> Checking indexes" let! reqIdx = db().Table(DataTable.Request).IndexList().RunResultAsync(this) |> Async.AwaitTask match reqIdx |> List.contains "UserId" with | true -> () - | _ -> logStep <| sprintf " %s.UserId index not found - creating..." DataTable.Request + | _ -> logStep <| sprintf " %s.UserId index not found - creating..." DataTable.Request do! db().Table(DataTable.Request).IndexCreate("UserId").RunResultAsync(this) |> Async.AwaitTask |> Async.Ignore - logStep " ...done" + logStep " ...done" let! usrIdx = db().Table(DataTable.User).IndexList().RunResultAsync(this) |> Async.AwaitTask match usrIdx |> List.contains "Email" with | true -> () - | _ -> logStep <| sprintf " %s.Email index not found - creating..." DataTable.User + | _ -> logStep <| sprintf " %s.Email index not found - creating..." DataTable.User do! db().Table(DataTable.User).IndexCreate("Email").RunResultAsync(this) |> Async.AwaitTask |> Async.Ignore - logStep " ...done" + logStep " ...done" } async { logStep "Database checks starting" diff --git a/src/MyPrayerJournal/Entities.fs b/src/MyPrayerJournal/Entities.fs index 8381e24..75d08f0 100644 --- a/src/MyPrayerJournal/Entities.fs +++ b/src/MyPrayerJournal/Entities.fs @@ -13,10 +13,22 @@ type User = { PasswordHash : 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 = "" + PasswordHash = "" + Name = "" + TimeZone = "" + LastSeenOn = int64 0 } + /// Request history entry type History = { /// The instant at which the update was made diff --git a/src/MyPrayerJournal/HomeModule.fs b/src/MyPrayerJournal/HomeModule.fs new file mode 100644 index 0000000..4d83fc6 --- /dev/null +++ b/src/MyPrayerJournal/HomeModule.fs @@ -0,0 +1,15 @@ +namespace MyPrayerJournal + +open Nancy + +type HomeModule() as this = + inherit NancyModule() + + do + this.Get ("/", fun _ -> this.Home ()) + + member this.Home () : obj = + let model = MyPrayerJournalModel(this.Context) + model.PageTitle <- Strings.get "Welcome" + upcast this.View.["home/index", model] + \ No newline at end of file diff --git a/src/MyPrayerJournal/Keys.fs b/src/MyPrayerJournal/Keys.fs new file mode 100644 index 0000000..27568ab --- /dev/null +++ b/src/MyPrayerJournal/Keys.fs @@ -0,0 +1,14 @@ +[] +module MyPrayerJournal.Keys + +/// Messages stored in the session +let Messages = "messages" + +/// The request start time (stored in the context for each request) +let RequestStart = "request-start" + +/// The current user +let User = "user" + +/// The version of myPrayerJournal +let Version = "version" diff --git a/src/MyPrayerJournal/Strings.fs b/src/MyPrayerJournal/Strings.fs new file mode 100644 index 0000000..f7ccec5 --- /dev/null +++ b/src/MyPrayerJournal/Strings.fs @@ -0,0 +1,40 @@ +module MyPrayerJournal.Strings + +open Newtonsoft.Json +open System.Collections.Generic +open System.IO + +/// The locales we'll try to load +let private supportedLocales = [ "en-US" ] + +/// The fallback locale, if a key is not found in a non-default locale +let private fallbackLocale = "en-US" + +/// Get an embedded JSON file as a string +let private getEmbedded locale = + use stream = new FileStream((sprintf "resources/%s.json" locale), FileMode.Open) + use rdr = new StreamReader(stream) + rdr.ReadToEnd() + +/// The dictionary of localized strings +let private strings = + supportedLocales + |> List.map (fun loc -> loc, JsonConvert.DeserializeObject>(getEmbedded loc)) + |> dict + +/// Get a key from the resources file for the given locale +let getForLocale locale key = + let getString thisLocale = + match strings.ContainsKey thisLocale with + | true -> match strings.[thisLocale].ContainsKey key with + | true -> Some strings.[thisLocale].[key] + | _ -> None + | _ -> None + match getString locale with + | Some xlat -> Some xlat + | _ when locale <> fallbackLocale -> getString fallbackLocale + | _ -> None + |> function Some xlat -> xlat | _ -> sprintf "%s.%s" locale key + +/// Translate the key for the current locale +let get key = getForLocale System.Globalization.CultureInfo.CurrentCulture.Name key diff --git a/src/MyPrayerJournal/UserModule.fs b/src/MyPrayerJournal/UserModule.fs new file mode 100644 index 0000000..3c5bd71 --- /dev/null +++ b/src/MyPrayerJournal/UserModule.fs @@ -0,0 +1,18 @@ +namespace MyPrayerJournal + +open Nancy + +type UserModule() as this = + inherit NancyModule("user") + + do + this.Get ("/log-on", fun _ -> this.ShowLogOn ()) + this.Post("/log-on", fun parms -> this.DoLogOn (downcast parms)) + + member this.ShowLogOn () : obj = + let model = MyPrayerJournalModel(this.Context) + model.PageTitle <- Strings.get "LogOn" + upcast this.View.["user/log-on", model] + + member this.DoLogOn (parms : DynamicDictionary) : obj = + upcast "X" \ No newline at end of file diff --git a/src/MyPrayerJournal/ViewModels.fs b/src/MyPrayerJournal/ViewModels.fs new file mode 100644 index 0000000..4a3faa3 --- /dev/null +++ b/src/MyPrayerJournal/ViewModels.fs @@ -0,0 +1,140 @@ +namespace MyPrayerJournal + +open Nancy +open Nancy.Session.Persistable +open Newtonsoft.Json +open NodaTime +open NodaTime.Text +open System + +/// Levels for a user message +[] +module Level = + /// An informational message + let Info = "Info" + /// A message regarding a non-fatal but non-optimal condition + let Warning = "WARNING" + /// A message regarding a failure of the expected result + let Error = "ERROR" + + +/// A message for the user +type UserMessage = + { /// The level of the message (use Level module constants) + Level : string + /// The text of the message + Message : string + /// Further details regarding the message + Details : string option } +with + /// An empty message + static member Empty = + { Level = Level.Info + Message = "" + Details = None } + + /// Display version + [] + member this.ToDisplay = + let classAndLabel = + dict [ + Level.Error, ("danger", Strings.get "Error") + Level.Warning, ("warning", Strings.get "Warning") + Level.Info, ("info", "") + ] + seq { + yield "
" + match snd classAndLabel.[this.Level] with + | "" -> () + | lbl -> yield lbl.ToUpper () + yield " » " + yield this.Message + yield "" + match this.Details with + | Some d -> yield "
" + yield d + | None -> () + yield "
" + } + |> Seq.reduce (+) + + +/// Helpers to format local date/time using NodaTime +module FormatDateTime = + + /// Convert ticks to a zoned date/time + let zonedTime timeZone ticks = Instant.FromUnixTimeTicks(ticks).InZone(DateTimeZoneProviders.Tzdb.[timeZone]) + + /// Display a long date + let longDate timeZone ticks = + zonedTime timeZone ticks + |> ZonedDateTimePattern.CreateWithCurrentCulture("MMMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format + + /// Display a short date + let shortDate timeZone ticks = + zonedTime timeZone ticks + |> ZonedDateTimePattern.CreateWithCurrentCulture("MMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format + + /// Display the time + let time timeZone ticks = + (zonedTime timeZone ticks + |> ZonedDateTimePattern.CreateWithCurrentCulture("h':'mmtt", DateTimeZoneProviders.Tzdb).Format).ToLower() + + +/// Parent view model for all myPrayerJournal view models +type MyPrayerJournalModel(ctx : NancyContext) = + + /// Get the messages from the session + let getMessages () = + let msg = ctx.Request.PersistableSession.GetOrDefault(Keys.Messages, []) + match List.length msg with + | 0 -> () + | _ -> ctx.Request.Session.Delete Keys.Messages + msg + + /// User messages + member val Messages = getMessages () with get, set + /// The currently logged in user + member this.User = ctx.Request.PersistableSession.GetOrDefault(Keys.User, User.Empty) + /// The title of the page + member val PageTitle = "" with get, set + /// The name and version of the application + member this.Generator = sprintf "myPrayerJournal %s" (ctx.Items.[Keys.Version].ToString ()) + /// The request start time + member this.RequestStart = ctx.Items.[Keys.RequestStart] :?> int64 + /// Is a user authenticated for this request? + member this.IsAuthenticated = "" <> this.User.Id + /// Add a message to the output + member this.AddMessage message = this.Messages <- message :: this.Messages + + /// Display a long date + member this.DisplayLongDate ticks = FormatDateTime.longDate this.User.TimeZone ticks + /// Display a short date + member this.DisplayShortDate ticks = FormatDateTime.shortDate this.User.TimeZone ticks + /// Display the time + member this.DisplayTime ticks = FormatDateTime.time this.User.TimeZone ticks + /// The page title with the web log name appended + member this.DisplayPageTitle = this.PageTitle (* + match this.PageTitle with + | "" -> match this.WebLog.Subtitle with + | Some st -> sprintf "%s | %s" this.WebLog.Name st + | None -> this.WebLog.Name + | pt -> sprintf "%s | %s" pt this.WebLog.Name *) + + /// An image with the version and load time in the tool tip + member this.FooterLogo = + seq { + yield "\"myWebLog\"" + } + |> Seq.reduce (+) diff --git a/src/MyPrayerJournal/project.json b/src/MyPrayerJournal/project.json index cce3476..e3eb47f 100644 --- a/src/MyPrayerJournal/project.json +++ b/src/MyPrayerJournal/project.json @@ -1,39 +1,50 @@ { - "version": "1.0.0-*", "buildOptions": { - "debugType": "portable", - "emitEntryPoint": true, - "compilerName": "fsc", "compile": { "includeFiles": [ "Entities.fs", + "Strings.fs", "Config.fs", "Data.fs", + "Keys.fs", + "ViewModels.fs", + "HomeModule.fs", + "UserModule.fs", "App.fs" ] - } + }, + "compilerName": "fsc", + "copyToOutput": { + "include": [ "views", "resources" ] + }, + "debugType": "portable", + "emitEntryPoint": true }, "dependencies": { + "Microsoft.AspNetCore.Hosting": "1.0.0", + "Microsoft.AspNetCore.Owin": "1.0.0", + "Microsoft.AspNetCore.Server.Kestrel": "1.0.1", "Nancy": "2.0.0-barneyrubble", "Nancy.Authentication.Forms": "2.0.0-barneyrubble", "Nancy.Session.Persistable": "0.9.1-pre", "Nancy.Session.RethinkDB": "0.9.1-pre", "Newtonsoft.Json": "9.0.1", - "RethinkDb.Driver": "2.3.15", - "Suave": "2.0.0-alpha5" - }, - "tools": { - "dotnet-compile-fsc":"1.0.0-preview2-*" + "NodaTime": "2.0.0-alpha20160729", + "RethinkDb.Driver": "2.3.15" }, "frameworks": { "netcoreapp1.0": { "dependencies": { + "Microsoft.FSharp.Core.netcore": "1.0.0-alpha-160831", "Microsoft.NETCore.App": { "type": "platform", "version": "1.0.1" - }, - "Microsoft.FSharp.Core.netcore": "1.0.0-alpha-160831" + } } } - } + }, + "tools": { + "dotnet-compile-fsc":"1.0.0-preview2-*" + }, + "version": "1.0.0-*" } diff --git a/src/MyPrayerJournal/resources/en-US.json b/src/MyPrayerJournal/resources/en-US.json new file mode 100644 index 0000000..2c13253 --- /dev/null +++ b/src/MyPrayerJournal/resources/en-US.json @@ -0,0 +1,8 @@ +{ + "ChangeYourPassword": "Change Your Password", + "EmailAddress": "E-mail Address", + "LogOff": "Log Off", + "LogOn": "Log On", + "MyPrayerJournal": "MyPrayerJournal", + "Password": "Password" +} \ No newline at end of file diff --git a/src/MyPrayerJournal/views/home/index.html b/src/MyPrayerJournal/views/home/index.html new file mode 100644 index 0000000..e51872e --- /dev/null +++ b/src/MyPrayerJournal/views/home/index.html @@ -0,0 +1,5 @@ +@Master['layout'] + +@Section['Content'] +

Hi

+@EndSection \ No newline at end of file diff --git a/src/MyPrayerJournal/views/layout.html b/src/MyPrayerJournal/views/layout.html new file mode 100644 index 0000000..b927bbc --- /dev/null +++ b/src/MyPrayerJournal/views/layout.html @@ -0,0 +1,60 @@ + + + + + + + @Model.DisplayPageTitle + + + + + @Section['Head']; + + +
+ +
+
+ @Section['Content']; +
+ @Section['Footer']; + + + @Section['Scripts']; + + \ No newline at end of file diff --git a/src/MyPrayerJournal/views/user/log-on.html b/src/MyPrayerJournal/views/user/log-on.html new file mode 100644 index 0000000..4e4af65 --- /dev/null +++ b/src/MyPrayerJournal/views/user/log-on.html @@ -0,0 +1,40 @@ +@Master['layout'] + +@Section['Content'] +
+ @AntiForgeryToken +
+
+
+ email + +
+
+
+
+
+
+
+ security + +
+
+
+
+
+

+
+ +

+
+
+
+@EndSection + +@Section['Scripts'] + +@EndSection