More plumbing

App now starts with a very basic layout
This commit is contained in:
Daniel J. Summers 2016-09-23 22:06:14 -05:00
parent 6bd90c854d
commit 1251c28a89
13 changed files with 515 additions and 31 deletions

View File

@ -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\.(?<TranslationKey>[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<IUserMapper, AppUserMapper>()
override this.ConfigureApplicationContainer (container) =
base.ConfigureApplicationContainer container
ignore <| container.Register<AppConfig>(cfg)
ignore <| container.Register<IConnection>(cfg.DataConfig.Conn)
// NodaTime
ignore <| container.Register<IClock>(SystemClock.Instance)
// I18N in SSVE
ignore <| container.Register<seq<ISuperSimpleViewEngineMatcher>>
(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<IUserMapper>())
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<AppConfig>.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)
[<EntryPoint>]
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<Startup>()
.Build()
.Run()
0

View File

@ -1,8 +1,10 @@
[<AutoOpen>]
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<User>(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<string list>(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<string list>(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<string list>(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<string list>(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"

View File

@ -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

View File

@ -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]

View File

@ -0,0 +1,14 @@
[<RequireQualifiedAccess>]
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"

View File

@ -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<Dictionary<string, string>>(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

View File

@ -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"

View File

@ -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
[<RequireQualifiedAccess>]
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
[<JsonIgnore>]
member this.ToDisplay =
let classAndLabel =
dict [
Level.Error, ("danger", Strings.get "Error")
Level.Warning, ("warning", Strings.get "Warning")
Level.Info, ("info", "")
]
seq {
yield "<div class=\"alert alert-dismissable alert-"
yield fst classAndLabel.[this.Level]
yield "\" role=\"alert\"><button type=\"button\" class=\"close\" data-dismiss=\"alert\" aria-label=\""
yield Strings.get "Close"
yield "\">&times;</button><strong>"
match snd classAndLabel.[this.Level] with
| "" -> ()
| lbl -> yield lbl.ToUpper ()
yield " &#xbb; "
yield this.Message
yield "</strong>"
match this.Details with
| Some d -> yield "<br />"
yield d
| None -> ()
yield "</div>"
}
|> 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<UserMessage list>(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<User>(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 "<img src=\"/default/footer-logo.png\" alt=\"myWebLog\" title=\""
yield sprintf "%s %s &bull; " (Strings.get "PoweredBy") this.Generator
yield Strings.get "LoadedIn"
yield " "
yield TimeSpan(System.DateTime.Now.Ticks - this.RequestStart).TotalSeconds.ToString "f3"
yield " "
yield (Strings.get "Seconds").ToLower ()
yield "\" />"
}
|> Seq.reduce (+)

View File

@ -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-*"
}

View File

@ -0,0 +1,8 @@
{
"ChangeYourPassword": "Change Your Password",
"EmailAddress": "E-mail Address",
"LogOff": "Log Off",
"LogOn": "Log On",
"MyPrayerJournal": "MyPrayerJournal",
"Password": "Password"
}

View File

@ -0,0 +1,5 @@
@Master['layout']
@Section['Content']
<p>Hi</p>
@EndSection

View File

@ -0,0 +1,60 @@
<!DOCTYPE html>
<html>
<head>
<meta charset="utf-8"/>
<meta name="viewport" content="width=device-width" />
<meta name="generator" content="@Model.Generator" />
<title>@Model.DisplayPageTitle</title>
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css" integrity="sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u" crossorigin="anonymous" />
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap-theme.min.css" integrity="sha384-rHyoN1iRsVXV4nD0JutlnGaslCJuC7uwjduW9SVrLvRYooPp2bWYgmgJQIXwl/Sp" crossorigin="anonymous" />
<link rel="stylesheet" href="https://fonts.googleapis.com/icon?family=Material+Icons" />
<style>
body {
font-family: -apple-system,BlinkMacSystemFont,"Segoe UI",Roboto,Oxygen-Sans,Ubuntu,Cantarell,"Helvetica Neue",sans-serif;
}
.material-icons.md-18 {
font-size: 18px;
}
.material-icons.md-24 {
font-size: 24px;
}
.material-icons.md-36 {
font-size: 36px;
}
.material-icons.md-48 {
font-size: 48px;
}
.material-icons {
vertical-align: middle;
}
</style>
@Section['Head'];
</head>
<body>
<header>
<nav class="navbar navbar-default">
<div class="container-fluid">
<div class="navbar-header">
<a class="navbar-brand" href="/"><span style="font-weight:100;">My</span><span style="font-weight:600;">Prayer</span><span style="font-weight:700;">Journal</span></a>
</div>
<ul class="nav navbar-nav navbar-right">
@If.IsAuthenticated
<li><a href="/user/change-password">@Translate.ChangeYourPassword</a></li>
<li><a href="/user/log-off">@Translate.LogOff</a></li>
@EndIf
@IfNot.IsAuthenticated
<li><a href="/user/log-on">@Translate.LogOn</a></li>
@EndIf
</ul>
</div>
</nav>
</header>
<div class="container">
@Section['Content'];
</div>
@Section['Footer'];
<script type="text/javascript" src="//ajax.aspnetcdn.com/ajax/jQuery/jquery-2.1.3.min.js"></script>
<script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous"></script>
@Section['Scripts'];
</body>
</html>

View File

@ -0,0 +1,40 @@
@Master['layout']
@Section['Content']
<form action="/user/log-on" method="post">
@AntiForgeryToken
<div class="row">
<div class="col-sm-offset-1 col-sm-8 col-md-offset-3 col-md-6">
<div class="input-group">
<span class="input-group-addon" title="@Translate.EmailAddress"><i class="material-icons md-18">email</i></span>
<input type="text" name="Email" id="Email" class="form-control" placeholder="@Translate.EmailAddress" />
</div>
</div>
</div>
<div class="row">
<div class="col-sm-offset-1 col-sm-8 col-md-offset-3 col-md-6">
<br />
<div class="input-group">
<span class="input-group-addon" title="@Translate.Password"><i class="material-icons md-18">security</i></span>
<input type="password" name="Password" class="form-control" placeholder="@Translate.Password" />
</div>
</div>
</div>
<div class="row">
<div class="col-xs-12 text-center">
<p>
<br />
<button class="btn btn-primary"><i class="material-icons md-18">verified_user</i> @Translate.LogOn</button>
</p>
</div>
</div>
</form>
@EndSection
@Section['Scripts']
<script type="text/javascript">
/* <![CDATA[ */
$(document).ready(function () { $("#Email").focus() })
/* ]]> */
</script>
@EndSection