bit-badger/myWebLog
1
0
Fork 0
Code Issues 4 Pull Requests Packages Projects Releases 11 Activity

App-level Config / code style

Browse Source 
config.json now controls encryption and salt for both passwords and
forms authentication; data-config.json options are now under the "data"
key in config.json.

Unaligned ->'s throughout code per F# design guidelines, pulled out some
longer lambdas into their own let bindings within the method/function
scope, added qualified access attributes to smaller constant-type
modules
This commit is contained in:
Daniel J. Summers 2016-07-27 22:36:28 -05:00
parent ac8fa084d1
commit b9464f9600
21 changed files with 253 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/myWebLog.Data/Category.fs
View File

@ -43,7 +43,7 @@ let tryFindCategory conn webLogId catId : Category option =
match (category webLogId catId) match (category webLogId catId)
.RunAtomAsync<Category>(conn) |> await |> box with .RunAtomAsync<Category>(conn) |> await |> box with
| null -> None | null -> None
| cat -> Some <| unbox cat | cat -> Some <| unbox cat
/// Save a category /// Save a category
let saveCategory conn webLogId (cat : Category) = let saveCategory conn webLogId (cat : Category) =
@ -54,15 +54,15 @@ let saveCategory conn webLogId (cat : Category) =
.Insert(newCat) .Insert(newCat)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
newCat.Id newCat.Id
| _ -> let upd8 = ExpandoObject() | _ -> let upd8 = ExpandoObject()
upd8?Name <- cat.Name upd8?Name <- cat.Name
upd8?Slug <- cat.Slug upd8?Slug <- cat.Slug
upd8?Description <- cat.Description upd8?Description <- cat.Description
upd8?ParentId <- cat.ParentId upd8?ParentId <- cat.ParentId
(category webLogId cat.Id) (category webLogId cat.Id)
.Update(upd8) .Update(upd8)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
cat.Id cat.Id
/// Remove a category from a given parent /// Remove a category from a given parent
let removeCategoryFromParent conn webLogId parentId catId = let removeCategoryFromParent conn webLogId parentId catId =
@ -73,7 +73,7 @@ let removeCategoryFromParent conn webLogId parentId catId =
(category webLogId parentId) (category webLogId parentId)
.Update(upd8) .Update(upd8)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
| None -> () | None -> ()
/// Add a category to a given parent /// Add a category to a given parent
let addCategoryToParent conn webLogId parentId catId = let addCategoryToParent conn webLogId parentId catId =
@ -83,14 +83,14 @@ let addCategoryToParent conn webLogId parentId catId =
(category webLogId parentId) (category webLogId parentId)
.Update(upd8) .Update(upd8)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
| None -> () | None -> ()
/// Delete a category /// Delete a category
let deleteCategory conn cat = let deleteCategory conn cat =
// Remove the category from its parent // Remove the category from its parent
match cat.ParentId with match cat.ParentId with
| Some parentId -> removeCategoryFromParent conn cat.WebLogId parentId cat.Id | Some parentId -> removeCategoryFromParent conn cat.WebLogId parentId cat.Id
| None -> () | None -> ()
// Move this category's children to its parent // Move this category's children to its parent
let newParent = ExpandoObject() let newParent = ExpandoObject()
newParent?ParentId <- cat.ParentId newParent?ParentId <- cat.ParentId

11
src/myWebLog.Data/DataConfig.fs
View File

@ -25,8 +25,8 @@ type DataConfig =
[<JsonIgnore>] [<JsonIgnore>]
Conn : IConnection } Conn : IConnection }
with with
/// Create a data configuration from JSON /// Use RethinkDB defaults for non-provided options, and connect to the server
static member FromJson json = static member Connect config =
let ensureHostname cfg = match cfg.Hostname with let ensureHostname cfg = match cfg.Hostname with
| null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname } | null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname }
| _ -> cfg | _ -> cfg
@ -35,13 +35,13 @@ with
| _ -> cfg | _ -> cfg
let ensureAuthKey cfg = match cfg.AuthKey with let ensureAuthKey cfg = match cfg.AuthKey with
| null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey } | null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey }
| _ -> cfg | _ -> cfg
let ensureTimeout cfg = match cfg.Timeout with let ensureTimeout cfg = match cfg.Timeout with
| 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout } | 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout }
| _ -> cfg | _ -> cfg
let ensureDatabase cfg = match cfg.Database with let ensureDatabase cfg = match cfg.Database with
| null -> { cfg with Database = RethinkDBConstants.DefaultDbName } | null -> { cfg with Database = RethinkDBConstants.DefaultDbName }
| _ -> cfg | _ -> cfg
let connect cfg = { cfg with Conn = RethinkDB.R.Connection() let connect cfg = { cfg with Conn = RethinkDB.R.Connection()
.Hostname(cfg.Hostname) .Hostname(cfg.Hostname)
.Port(cfg.Port) .Port(cfg.Port)
@ -49,11 +49,10 @@ with
.Db(cfg.Database) .Db(cfg.Database)
.Timeout(cfg.Timeout) .Timeout(cfg.Timeout)
.Connect() } .Connect() }
JsonConvert.DeserializeObject<DataConfig> json config
|> ensureHostname |> ensureHostname
|> ensurePort |> ensurePort
|> ensureAuthKey |> ensureAuthKey
|> ensureTimeout |> ensureTimeout
|> ensureDatabase |> ensureDatabase
|> connect |> connect

36
src/myWebLog.Data/Entities.fs
View File

@ -5,34 +5,38 @@ open Newtonsoft.Json
// ---- Constants ---- // ---- Constants ----
/// Constants to use for revision source language /// Constants to use for revision source language
[<RequireQualifiedAccess>]
module RevisionSource = module RevisionSource =
[<Literal>] [<Literal>]
let Markdown = "markdown" let Markdown = "markdown"
[<Literal>] [<Literal>]
let HTML = "html" let HTML = "html"
/// Constants to use for authorization levels /// Constants to use for authorization levels
[<RequireQualifiedAccess>]
module AuthorizationLevel = module AuthorizationLevel =
[<Literal>] [<Literal>]
let Administrator = "Administrator" let Administrator = "Administrator"
[<Literal>] [<Literal>]
let User = "User" let User = "User"
/// Constants to use for post statuses /// Constants to use for post statuses
[<RequireQualifiedAccess>]
module PostStatus = module PostStatus =
[<Literal>] [<Literal>]
let Draft = "Draft" let Draft = "Draft"
[<Literal>] [<Literal>]
let Published = "Published" let Published = "Published"
/// Constants to use for comment statuses /// Constants to use for comment statuses
[<RequireQualifiedAccess>]
module CommentStatus = module CommentStatus =
[<Literal>] [<Literal>]
let Approved = "Approved" let Approved = "Approved"
[<Literal>] [<Literal>]
let Pending = "Pending" let Pending = "Pending"
[<Literal>] [<Literal>]
let Spam = "Spam" let Spam = "Spam"
// ---- Entities ---- // ---- Entities ----
@ -84,7 +88,7 @@ with
UpdatedOn = int64 0 UpdatedOn = int64 0
ShowInPageList = false ShowInPageList = false
Text = "" Text = ""
Revisions = List.empty Revisions = []
} }
@ -121,7 +125,7 @@ with
ThemePath = "default" ThemePath = "default"
UrlBase = "" UrlBase = ""
TimeZone = "America/New_York" TimeZone = "America/New_York"
PageList = List.empty } PageList = [] }
/// An authorization between a user and a web log /// An authorization between a user and a web log
@ -160,7 +164,7 @@ with
PreferredName = "" PreferredName = ""
PasswordHash = "" PasswordHash = ""
Url = None Url = None
Authorizations = List.empty } Authorizations = [] }
/// Claims for this user /// Claims for this user
[<JsonIgnore>] [<JsonIgnore>]
@ -186,14 +190,14 @@ type Category =
Children : string list } Children : string list }
with with
/// An empty category /// An empty category
static member empty = static member Empty =
{ Id = "new" { Id = "new"
WebLogId = "" WebLogId = ""
Name = "" Name = ""
Slug = "" Slug = ""
Description = None Description = None
ParentId = None ParentId = None
Children = List.empty } Children = [] }
/// A comment (applies to a post) /// A comment (applies to a post)
@ -272,9 +276,9 @@ with
PublishedOn = int64 0 PublishedOn = int64 0
UpdatedOn = int64 0 UpdatedOn = int64 0
Text = "" Text = ""
CategoryIds = List.empty CategoryIds = []
Tags = List.empty Tags = []
PriorPermalinks = List.empty PriorPermalinks = []
Revisions = List.empty Revisions = []
Categories = List.empty Categories = []
Comments = List.empty } Comments = [] }

26
src/myWebLog.Data/Page.fs
View File

@ -21,9 +21,7 @@ let tryFindPage conn webLogId pageId =
.RunAtomAsync<Page>(conn) |> await |> box with .RunAtomAsync<Page>(conn) |> await |> box with
| null -> None | null -> None
| page -> let pg : Page = unbox page | page -> let pg : Page = unbox page
match pg.WebLogId = webLogId with match pg.WebLogId = webLogId with true -> Some pg | _ -> None
| true -> Some pg
| _ -> None
/// Get a page by its Id (excluding revisions) /// Get a page by its Id (excluding revisions)
let tryFindPageWithoutRevisions conn webLogId pageId : Page option = let tryFindPageWithoutRevisions conn webLogId pageId : Page option =
@ -60,17 +58,17 @@ let savePage conn (pg : Page) =
.Insert(page) .Insert(page)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
newPage.Id newPage.Id
| _ -> let upd8 = ExpandoObject() | _ -> let upd8 = ExpandoObject()
upd8?Title <- pg.Title upd8?Title <- pg.Title
upd8?Permalink <- pg.Permalink upd8?Permalink <- pg.Permalink
upd8?PublishedOn <- pg.PublishedOn upd8?PublishedOn <- pg.PublishedOn
upd8?UpdatedOn <- pg.UpdatedOn upd8?UpdatedOn <- pg.UpdatedOn
upd8?Text <- pg.Text upd8?Text <- pg.Text
upd8?Revisions <- pg.Revisions upd8?Revisions <- pg.Revisions
(page pg.WebLogId pg.Id) (page pg.WebLogId pg.Id)
.Update(upd8) .Update(upd8)
.RunResultAsync(conn) |> await |> ignore .RunResultAsync(conn) |> await |> ignore
pg.Id pg.Id
/// Delete a page /// Delete a page
let deletePage conn webLogId pageId = let deletePage conn webLogId pageId =

16
src/myWebLog.Data/Post.fs
View File

@ -101,8 +101,6 @@ let tryFindPost conn webLogId postId : Post option =
| post -> Some <| unbox post | post -> Some <| unbox post
/// Try to find a post by its permalink /// Try to find a post by its permalink
// TODO: see if we can make .Merge work for page list even though the attribute is ignored
// (needs to be ignored for serialization, but included for deserialization)
let tryFindPostByPermalink conn webLogId permalink = let tryFindPostByPermalink conn webLogId permalink =
r.Table(Table.Post) r.Table(Table.Post)
.GetAll(r.Array(webLogId, permalink)).OptArg("index", "Permalink") .GetAll(r.Array(webLogId, permalink)).OptArg("index", "Permalink")
@ -157,10 +155,10 @@ let savePost conn post =
.RunResultAsync(conn) .RunResultAsync(conn)
|> ignore |> ignore
newPost.Id newPost.Id
| _ -> r.Table(Table.Post) | _ -> r.Table(Table.Post)
.Get(post.Id) .Get(post.Id)
.Replace( { post with Categories = List.empty .Replace( { post with Categories = []
Comments = List.empty } ) Comments = [] } )
.RunResultAsync(conn) .RunResultAsync(conn)
|> ignore |> ignore
post.Id post.Id

47
src/myWebLog.Data/SetUp.fs
View File

@ -10,63 +10,60 @@ let private logStepStart text = Console.Out.Write (sprintf "[myWebLog] %s...
let private logStepDone () = Console.Out.WriteLine (" done.") let private logStepDone () = Console.Out.WriteLine (" done.")
/// Ensure the myWebLog database exists /// Ensure the myWebLog database exists
let checkDatabase (cfg : DataConfig) = let private checkDatabase (cfg : DataConfig) =
logStep "|> Checking database" logStep "|> Checking database"
let dbs = r.DbList().RunListAsync<string>(cfg.Conn) |> await let dbs = r.DbList().RunListAsync<string>(cfg.Conn) |> await
match dbs.Contains cfg.Database with match dbs.Contains cfg.Database with
| true -> () | true -> ()
| _ -> logStepStart (sprintf " %s database not found - creating" cfg.Database) | _ -> logStepStart (sprintf " %s database not found - creating" cfg.Database)
r.DbCreate(cfg.Database).RunResultAsync(cfg.Conn) |> await |> ignore r.DbCreate(cfg.Database).RunResultAsync(cfg.Conn) |> await |> ignore
logStepDone () logStepDone ()
/// Ensure all required tables exist /// Ensure all required tables exist
let checkTables cfg = let private checkTables cfg =
logStep "|> Checking tables" logStep "|> Checking tables"
let tables = r.Db(cfg.Database).TableList().RunListAsync<string>(cfg.Conn) |> await let tables = r.Db(cfg.Database).TableList().RunListAsync<string>(cfg.Conn) |> await
[ Table.Category; Table.Comment; Table.Page; Table.Post; Table.User; Table.WebLog ] [ Table.Category; Table.Comment; Table.Page; Table.Post; Table.User; Table.WebLog ]
|> List.map (fun tbl -> match tables.Contains tbl with |> List.map (fun tbl -> match tables.Contains tbl with true -> None | _ -> Some (tbl, r.TableCreate tbl))
| true -> None |> List.filter Option.isSome
| _ -> Some (tbl, r.TableCreate tbl)) |> List.map Option.get
|> List.filter (fun create -> create.IsSome)
|> List.map (fun create -> create.Value)
|> List.iter (fun (tbl, create) -> logStepStart (sprintf " Creating table %s" tbl) |> List.iter (fun (tbl, create) -> logStepStart (sprintf " Creating table %s" tbl)
create.RunResultAsync(cfg.Conn) |> await |> ignore create.RunResultAsync(cfg.Conn) |> await |> ignore
logStepDone ()) logStepDone ())
/// Shorthand to get the table /// Shorthand to get the table
let tbl cfg table = r.Db(cfg.Database).Table(table) let private tbl cfg table = r.Db(cfg.Database).Table(table)
/// Create the given index /// Create the given index
let createIndex cfg table (index : string * (ReqlExpr -> obj) option) = let private createIndex cfg table (index : string * (ReqlExpr -> obj) option) =
let idxName, idxFunc = index let idxName, idxFunc = index
logStepStart (sprintf """ Creating index "%s" on table %s""" idxName table) logStepStart (sprintf """ Creating index "%s" on table %s""" idxName table)
match idxFunc with (match idxFunc with
| Some f -> (tbl cfg table).IndexCreate(idxName, f).RunResultAsync(cfg.Conn) | Some f -> (tbl cfg table).IndexCreate(idxName, f)
| None -> (tbl cfg table).IndexCreate(idxName ).RunResultAsync(cfg.Conn) | None -> (tbl cfg table).IndexCreate(idxName))
.RunResultAsync(cfg.Conn)
|> await |> ignore |> await |> ignore
(tbl cfg table).IndexWait(idxName).RunAtomAsync(cfg.Conn) |> await |> ignore (tbl cfg table).IndexWait(idxName).RunAtomAsync(cfg.Conn) |> await |> ignore
logStepDone () logStepDone ()
/// Ensure that the given indexes exist, and create them if required /// Ensure that the given indexes exist, and create them if required
let ensureIndexes cfg (indexes : (string * (string * (ReqlExpr -> obj) option) list) list) = let private ensureIndexes cfg (indexes : (string * (string * (ReqlExpr -> obj) option) list) list) =
let ensureForTable tabl = let ensureForTable (tblName, idxs) =
let idx = (tbl cfg (fst tabl)).IndexList().RunListAsync<string>(cfg.Conn) |> await let idx = (tbl cfg tblName).IndexList().RunListAsync<string>(cfg.Conn) |> await
snd tabl idxs
|> List.iter (fun index -> match idx.Contains (fst index) with |> List.iter (fun index -> match idx.Contains (fst index) with true -> () | _ -> createIndex cfg tblName index)
| true -> ()
| _ -> createIndex cfg (fst tabl) index)
indexes indexes
|> List.iter ensureForTable |> List.iter ensureForTable
/// Create an index on a single field /// Create an index on a single field
let singleField (name : string) : obj = upcast (fun row -> (row :> ReqlExpr).[name]) let private singleField (name : string) : obj = upcast (fun row -> (row :> ReqlExpr).[name])
/// Create an index on web log Id and the given field /// Create an index on web log Id and the given field
let webLogField (name : string) : (ReqlExpr -> obj) option = let private webLogField (name : string) : (ReqlExpr -> obj) option =
Some <| fun row -> upcast r.Array(row.["webLogId"], row.[name]) Some <| fun row -> upcast r.Array(row.["webLogId"], row.[name])
/// Ensure all the required indexes exist /// Ensure all the required indexes exist
let checkIndexes cfg = let private checkIndexes cfg =
logStep "|> Checking indexes" logStep "|> Checking indexes"
[ Table.Category, [ "WebLogId", None [ Table.Category, [ "WebLogId", None
"Slug", webLogField "Slug" "Slug", webLogField "Slug"

4
src/myWebLog.Data/Table.fs
View File

@ -1,4 +1,6 @@
module MyWebLog.Data.Table /// Constants for tables used in myWebLog
[<RequireQualifiedAccess>]
module MyWebLog.Data.Table
/// The Category table /// The Category table
let Category = "Category" let Category = "Category"

9
src/myWebLog.Resources/Resources.Designer.cs generated
View File

@ -240,6 +240,15 @@ namespace MyWebLog {
} }
} }
/// <summary>
/// Looks up a localized string similar to Could not convert config.json to myWebLog configuration.
/// </summary>
public static string ErrBadAppConfig {
get {
return ResourceManager.GetString("ErrBadAppConfig", resourceCulture);
}
}
/// <summary> /// <summary>
/// Looks up a localized string similar to Invalid e-mail address or password. /// Looks up a localized string similar to Invalid e-mail address or password.
/// </summary> /// </summary>

3
src/myWebLog.Resources/Resources.resx
View File

@ -327,4 +327,7 @@
<data name="Seconds" xml:space="preserve"> <data name="Seconds" xml:space="preserve">
<value>Seconds</value> <value>Seconds</value>
</data> </data>
<data name="ErrBadAppConfig" xml:space="preserve">
<value>Could not convert config.json to myWebLog configuration</value>
</data>
</root> </root>

61
src/myWebLog.Web/App.fs
View File

@ -24,22 +24,22 @@ open System
open System.IO open System.IO
open System.Text.RegularExpressions open System.Text.RegularExpressions
/// Set up a database connection /// Establish the configuration for this instance
let cfg = try DataConfig.FromJson (System.IO.File.ReadAllText "data-config.json") let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json")
with ex -> raise <| ApplicationException(Resources.ErrDataConfig, ex) with ex -> raise <| ApplicationException(Resources.ErrBadAppConfig, ex)
do do
startUpCheck cfg startUpCheck cfg.DataConfig
/// Support RESX lookup via the @Translate SSVE alias /// Support RESX lookup via the @Translate SSVE alias
type TranslateTokenViewEngineMatcher() = type TranslateTokenViewEngineMatcher() =
static let regex = Regex("@Translate\.(?<TranslationKey>[a-zA-Z0-9-_]+);?", RegexOptions.Compiled) static let regex = Regex("@Translate\.(?<TranslationKey>[a-zA-Z0-9-_]+);?", RegexOptions.Compiled)
interface ISuperSimpleViewEngineMatcher with interface ISuperSimpleViewEngineMatcher with
member this.Invoke (content, model, host) = member this.Invoke (content, model, host) =
regex.Replace(content, fun m -> let key = m.Groups.["TranslationKey"].Value let translate (m : Match) =
match MyWebLog.Resources.ResourceManager.GetString key with let key = m.Groups.["TranslationKey"].Value
| null -> key match MyWebLog.Resources.ResourceManager.GetString key with null -> key | xlat -> xlat
| xlat -> xlat) regex.Replace(content, translate)
/// Handle forms authentication /// Handle forms authentication
@ -47,8 +47,6 @@ type MyWebLogUser(name, claims) =
interface IUserIdentity with interface IUserIdentity with
member this.UserName with get() = name member this.UserName with get() = name
member this.Claims with get() = claims member this.Claims with get() = claims
(*member this.UserName with get() = (this :> IUserIdentity).UserName
member this.Claims with get() = (this :> IUserIdentity).Claims -- do we need these? *)
type MyWebLogUserMapper(container : TinyIoCContainer) = type MyWebLogUserMapper(container : TinyIoCContainer) =
@ -71,23 +69,24 @@ type MyWebLogBootstrapper() =
override this.ConfigureConventions (conventions) = override this.ConfigureConventions (conventions) =
base.ConfigureConventions conventions base.ConfigureConventions conventions
// Make theme content available at [theme-name]/
let addContentDir dir =
let contentDir = Path.Combine [| dir; "content" |]
match Directory.Exists contentDir with
| true -> conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory ((Path.GetFileName dir), contentDir))
| _ -> ()
conventions.StaticContentsConventions.Add conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory("admin/content", "views/admin/content")) (StaticContentConventionBuilder.AddDirectory("admin/content", "views/admin/content"))
// Make theme content available at [theme-name]/
Directory.EnumerateDirectories (Path.Combine [| "views"; "themes" |]) Directory.EnumerateDirectories (Path.Combine [| "views"; "themes" |])
|> Seq.iter (fun dir -> let contentDir = Path.Combine [| dir; "content" |] |> Seq.iter addContentDir
match Directory.Exists contentDir with
| true -> conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory
((Path.GetFileName dir), contentDir))
| _ -> ())
override this.ApplicationStartup (container, pipelines) = override this.ApplicationStartup (container, pipelines) =
base.ApplicationStartup (container, pipelines) base.ApplicationStartup (container, pipelines)
// Data configuration (both config and the connection; Nancy modules just need the connection) // Data configuration (both config and the connection; Nancy modules just need the connection)
container.Register<DataConfig>(cfg) container.Register<AppConfig>(cfg)
|> ignore |> ignore
container.Register<IConnection>(cfg.Conn) container.Register<IConnection>(cfg.DataConfig.Conn)
|> ignore |> ignore
// NodaTime // NodaTime
container.Register<IClock>(SystemClock.Instance) container.Register<IClock>(SystemClock.Instance)
@ -97,20 +96,20 @@ type MyWebLogBootstrapper() =
Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher)) Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher))
|> ignore |> ignore
// Forms authentication configuration // Forms authentication configuration
let salt = (System.Text.ASCIIEncoding()).GetBytes "NoneOfYourBeesWax"
let auth = let auth =
FormsAuthenticationConfiguration( FormsAuthenticationConfiguration(
CryptographyConfiguration = CryptographyConfiguration CryptographyConfiguration =
(RijndaelEncryptionProvider(PassphraseKeyGenerator("Secrets", salt)), CryptographyConfiguration(
DefaultHmacProvider(PassphraseKeyGenerator("Clandestine", salt))), RijndaelEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)),
RedirectUrl = "~/user/logon", DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))),
UserMapper = container.Resolve<IUserMapper>()) RedirectUrl = "~/user/logon",
UserMapper = container.Resolve<IUserMapper>())
FormsAuthentication.Enable (pipelines, auth) FormsAuthentication.Enable (pipelines, auth)
// CSRF // CSRF
Csrf.Enable pipelines Csrf.Enable pipelines
// Sessions // Sessions
let sessions = RethinkDbSessionConfiguration(cfg.Conn) let sessions = RethinkDbSessionConfiguration(cfg.DataConfig.Conn)
sessions.Database <- cfg.Database sessions.Database <- cfg.DataConfig.Database
PersistableSessions.Enable (pipelines, sessions) PersistableSessions.Enable (pipelines, sessions)
() ()
@ -130,11 +129,11 @@ type RequestEnvironment() =
member this.Initialize (pipelines, context) = member this.Initialize (pipelines, context) =
let establishEnv (ctx : NancyContext) = let establishEnv (ctx : NancyContext) =
ctx.Items.[Keys.RequestStart] <- DateTime.Now.Ticks ctx.Items.[Keys.RequestStart] <- DateTime.Now.Ticks
match tryFindWebLogByUrlBase cfg.Conn ctx.Request.Url.HostName with match tryFindWebLogByUrlBase cfg.DataConfig.Conn ctx.Request.Url.HostName with
| Some webLog -> ctx.Items.[Keys.WebLog] <- webLog | Some webLog -> ctx.Items.[Keys.WebLog] <- webLog
| None -> // TODO: redirect to domain set up page | None -> // TODO: redirect to domain set up page
ApplicationException (sprintf "%s %s" ctx.Request.Url.HostName Resources.ErrNotConfigured) ApplicationException (sprintf "%s %s" ctx.Request.Url.HostName Resources.ErrNotConfigured)
|> raise |> raise
ctx.Items.[Keys.Version] <- version ctx.Items.[Keys.Version] <- version
null null
pipelines.BeforeRequest.AddItemToStartOfPipeline establishEnv pipelines.BeforeRequest.AddItemToStartOfPipeline establishEnv

33
src/myWebLog.Web/AppConfig.fs Normal file
View File

@ -0,0 +1,33 @@
namespace MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open System.Text
/// Configuration for this myWebLog instance
type AppConfig =
{ /// The text from which to derive salt to use for passwords
[<JsonProperty("password-salt")>]
PasswordSaltString : string
/// The text from which to derive salt to use for forms authentication
[<JsonProperty("auth-salt")>]
AuthSaltString : string
/// The encryption passphrase to use for forms authentication
[<JsonProperty("encryption-passphrase")>]
AuthEncryptionPassphrase : string
/// The HMAC passphrase to use for forms authentication
[<JsonProperty("hmac-passphrase")>]
AuthHmacPassphrase : string
/// The data configuration
[<JsonProperty("data")>]
DataConfig : DataConfig }
with
/// The salt to use for passwords
member this.PasswordSalt = Encoding.UTF8.GetBytes this.PasswordSaltString
/// The salt to use for forms authentication
member this.AuthSalt = Encoding.UTF8.GetBytes this.AuthSaltString
/// Deserialize the configuration from the JSON file
static member FromJson json =
let cfg = JsonConvert.DeserializeObject<AppConfig> json
{ cfg with DataConfig = DataConfig.Connect cfg.DataConfig }

26
src/myWebLog.Web/CategoryModule.fs
View File

@ -30,14 +30,14 @@ type CategoryModule(conn : IConnection) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString () let catId = parameters.["id"].ToString ()
match (match catId with match (match catId with
| "new" -> Some Category.empty | "new" -> Some Category.Empty
| _ -> tryFindCategory conn this.WebLog.Id catId) with | _ -> tryFindCategory conn this.WebLog.Id catId) with
| Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat) | Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat)
model.Categories <- getAllCategories conn this.WebLog.Id model.Categories <- getAllCategories conn this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat |> List.map (fun cat -> IndentedCategory.Create cat
(fun c -> c = defaultArg (fst cat).ParentId "")) (fun c -> c = defaultArg (fst cat).ParentId ""))
upcast this.View.["admin/category/edit", model] upcast this.View.["admin/category/edit", model]
| None -> this.NotFound () | None -> this.NotFound ()
/// Save a category /// Save a category
member this.SaveCategory (parameters : DynamicDictionary) = member this.SaveCategory (parameters : DynamicDictionary) =
@ -45,9 +45,7 @@ type CategoryModule(conn : IConnection) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString () let catId = parameters.["id"].ToString ()
let form = this.Bind<CategoryForm> () let form = this.Bind<CategoryForm> ()
let oldCat = match catId with let oldCat = match catId with "new" -> Some Category.Empty | _ -> tryFindCategory conn this.WebLog.Id catId
| "new" -> Some Category.empty
| _ -> tryFindCategory conn this.WebLog.Id catId
match oldCat with match oldCat with
| Some old -> let cat = { old with Name = form.Name | Some old -> let cat = { old with Name = form.Name
Slug = form.Slug Slug = form.Slug
@ -56,12 +54,12 @@ type CategoryModule(conn : IConnection) as this =
let newCatId = saveCategory conn this.WebLog.Id cat let newCatId = saveCategory conn this.WebLog.Id cat
match old.ParentId = cat.ParentId with match old.ParentId = cat.ParentId with
| true -> () | true -> ()
| _ -> match old.ParentId with | _ -> match old.ParentId with
| Some parentId -> removeCategoryFromParent conn this.WebLog.Id parentId newCatId | Some parentId -> removeCategoryFromParent conn this.WebLog.Id parentId newCatId
| None -> () | None -> ()
match cat.ParentId with match cat.ParentId with
| Some parentId -> addCategoryToParent conn this.WebLog.Id parentId newCatId | Some parentId -> addCategoryToParent conn this.WebLog.Id parentId newCatId
| None -> () | None -> ()
let model = MyWebLogModel(this.Context, this.WebLog) let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with { UserMessage.Empty with
Level = Level.Info Level = Level.Info
@ -70,7 +68,7 @@ type CategoryModule(conn : IConnection) as this =
(match catId with | "new" -> Resources.Added | _ -> Resources.Updated)) } (match catId with | "new" -> Resources.Added | _ -> Resources.Updated)) }
|> model.AddMessage |> model.AddMessage
this.Redirect (sprintf "/category/%s/edit" newCatId) model this.Redirect (sprintf "/category/%s/edit" newCatId) model
| None -> this.NotFound () | None -> this.NotFound ()
/// Delete a category /// Delete a category
member this.DeleteCategory (parameters : DynamicDictionary) = member this.DeleteCategory (parameters : DynamicDictionary) =
@ -84,4 +82,4 @@ type CategoryModule(conn : IConnection) as this =
Message = System.String.Format(Resources.MsgCategoryDeleted, cat.Name) } Message = System.String.Format(Resources.MsgCategoryDeleted, cat.Name) }
|> model.AddMessage |> model.AddMessage
this.Redirect "/categories" model this.Redirect "/categories" model
| None -> this.NotFound () | None -> this.NotFound ()

8
src/myWebLog.Web/Keys.fs
View File

@ -1,11 +1,17 @@
module MyWebLog.Keys [<RequireQualifiedAccess>]
module MyWebLog.Keys
/// Messages stored in the session
let Messages = "messages" let Messages = "messages"
/// The request start time (stored in the context for each request)
let RequestStart = "request-start" let RequestStart = "request-start"
/// The current user
let User = "user" let User = "user"
/// The version of myWebLog
let Version = "version" let Version = "version"
/// The web log
let WebLog = "web-log" let WebLog = "web-log"

18
src/myWebLog.Web/PageModule.fs
View File

@ -33,16 +33,16 @@ type PageModule(conn : IConnection, clock : IClock) as this =
let pageId = parameters.["id"].ToString () let pageId = parameters.["id"].ToString ()
match (match pageId with match (match pageId with
| "new" -> Some Page.Empty | "new" -> Some Page.Empty
| _ -> tryFindPage conn this.WebLog.Id pageId) with | _ -> tryFindPage conn this.WebLog.Id pageId) with
| Some page -> let rev = match page.Revisions | Some page -> let rev = match page.Revisions
|> List.sortByDescending (fun r -> r.AsOf) |> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with |> List.tryHead with
| Some r -> r | Some r -> r
| None -> Revision.Empty | None -> Revision.Empty
let model = EditPageModel(this.Context, this.WebLog, page, rev) let model = EditPageModel(this.Context, this.WebLog, page, rev)
model.PageTitle <- match pageId with "new" -> Resources.AddNewPage | _ -> Resources.EditPage model.PageTitle <- match pageId with "new" -> Resources.AddNewPage | _ -> Resources.EditPage
upcast this.View.["admin/page/edit", model] upcast this.View.["admin/page/edit", model]
| None -> this.NotFound () | None -> this.NotFound ()
/// Save a page /// Save a page
member this.SavePage (parameters : DynamicDictionary) = member this.SavePage (parameters : DynamicDictionary) =
@ -51,9 +51,7 @@ type PageModule(conn : IConnection, clock : IClock) as this =
let pageId = parameters.["id"].ToString () let pageId = parameters.["id"].ToString ()
let form = this.Bind<EditPageForm> () let form = this.Bind<EditPageForm> ()
let now = clock.Now.Ticks let now = clock.Now.Ticks
match (match pageId with match (match pageId with "new" -> Some Page.Empty | _ -> tryFindPage conn this.WebLog.Id pageId) with
| "new" -> Some Page.Empty
| _ -> tryFindPage conn this.WebLog.Id pageId) with
| Some p -> let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p | Some p -> let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p
let pId = { p with let pId = { p with
Title = form.Title Title = form.Title
@ -62,7 +60,7 @@ type PageModule(conn : IConnection, clock : IClock) as this =
UpdatedOn = now UpdatedOn = now
Text = match form.Source with Text = match form.Source with
| RevisionSource.Markdown -> Markdown.TransformHtml form.Text | RevisionSource.Markdown -> Markdown.TransformHtml form.Text
| _ -> form.Text | _ -> form.Text
Revisions = { AsOf = now Revisions = { AsOf = now
SourceType = form.Source SourceType = form.Source
Text = form.Text } :: page.Revisions } Text = form.Text } :: page.Revisions }
@ -72,10 +70,10 @@ type PageModule(conn : IConnection, clock : IClock) as this =
Level = Level.Info Level = Level.Info
Message = System.String.Format Message = System.String.Format
(Resources.MsgPageEditSuccess, (Resources.MsgPageEditSuccess,
(match pageId with | "new" -> Resources.Added | _ -> Resources.Updated)) } (match pageId with "new" -> Resources.Added | _ -> Resources.Updated)) }
|> model.AddMessage |> model.AddMessage
this.Redirect (sprintf "/page/%s/edit" pId) model this.Redirect (sprintf "/page/%s/edit" pId) model
| None -> this.NotFound () | None -> this.NotFound ()
/// Delete a page /// Delete a page
member this.DeletePage (parameters : DynamicDictionary) = member this.DeletePage (parameters : DynamicDictionary) =
@ -89,4 +87,4 @@ type PageModule(conn : IConnection, clock : IClock) as this =
Message = Resources.MsgPageDeleted } Message = Resources.MsgPageDeleted }
|> model.AddMessage |> model.AddMessage
this.Redirect "/pages" model this.Redirect "/pages" model
| None -> this.NotFound () | None -> this.NotFound ()

78
src/myWebLog.Web/PostModule.fs
View File

@ -81,25 +81,23 @@ type PostModule(conn : IConnection, clock : IClock) as this =
| 1 -> false | 1 -> false
| _ -> match List.isEmpty model.Posts with | _ -> match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindNewerPost conn (List.last model.Posts).Post | _ -> Option.isSome <| tryFindNewerPost conn (List.last model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with model.HasOlder <- match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindOlderPost conn (List.head model.Posts).Post | _ -> Option.isSome <| tryFindOlderPost conn (List.head model.Posts).Post
model.UrlPrefix <- "/posts" model.UrlPrefix <- "/posts"
model.PageTitle <- match pageNbr with model.PageTitle <- match pageNbr with 1 -> "" | _ -> sprintf "%s%i" Resources.PageHash pageNbr
| 1 -> ""
| _ -> sprintf "%s%i" Resources.PageHash pageNbr
this.ThemedView "index" model this.ThemedView "index" model
/// Display either the newest posts or the configured home page /// Display either the newest posts or the configured home page
member this.HomePage () = member this.HomePage () =
match this.WebLog.DefaultPage with match this.WebLog.DefaultPage with
| "posts" -> this.PublishedPostsPage 1 | "posts" -> this.PublishedPostsPage 1
| pageId -> match tryFindPageWithoutRevisions conn this.WebLog.Id pageId with | pageId -> match tryFindPageWithoutRevisions conn this.WebLog.Id pageId with
| Some page -> let model = PageModel(this.Context, this.WebLog, page) | Some page -> let model = PageModel(this.Context, this.WebLog, page)
model.PageTitle <- page.Title model.PageTitle <- page.Title
this.ThemedView "page" model this.ThemedView "page" model
| None -> this.NotFound () | None -> this.NotFound ()
/// Derive a post or page from the URL, or redirect from a prior URL to the current one /// Derive a post or page from the URL, or redirect from a prior URL to the current one
member this.CatchAll (parameters : DynamicDictionary) = member this.CatchAll (parameters : DynamicDictionary) =
@ -111,18 +109,18 @@ type PostModule(conn : IConnection, clock : IClock) as this =
model.OlderPost <- tryFindOlderPost conn post model.OlderPost <- tryFindOlderPost conn post
model.PageTitle <- post.Title model.PageTitle <- post.Title
this.ThemedView "single" model this.ThemedView "single" model
| None -> // Maybe it's a page permalink instead... | None -> // Maybe it's a page permalink instead...
match tryFindPageByPermalink conn this.WebLog.Id url with match tryFindPageByPermalink conn this.WebLog.Id url with
| Some page -> // ...and it is! | Some page -> // ...and it is!
let model = PageModel(this.Context, this.WebLog, page) let model = PageModel(this.Context, this.WebLog, page)
model.PageTitle <- page.Title model.PageTitle <- page.Title
this.ThemedView "page" model this.ThemedView "page" model
| None -> // Maybe it's an old permalink for a post | None -> // Maybe it's an old permalink for a post
match tryFindPostByPriorPermalink conn this.WebLog.Id url with match tryFindPostByPriorPermalink conn this.WebLog.Id url with
| Some post -> // Redirect them to the proper permalink | Some post -> // Redirect them to the proper permalink
upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink) upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink)
.WithStatusCode HttpStatusCode.MovedPermanently .WithStatusCode HttpStatusCode.MovedPermanently
| None -> this.NotFound () | None -> this.NotFound ()
/// Display categorized posts /// Display categorized posts
member this.CategorizedPosts (parameters : DynamicDictionary) = member this.CategorizedPosts (parameters : DynamicDictionary) =
@ -134,20 +132,20 @@ type PostModule(conn : IConnection, clock : IClock) as this =
model.Posts <- findPageOfCategorizedPosts conn this.WebLog.Id cat.Id pageNbr 10 |> forDisplay model.Posts <- findPageOfCategorizedPosts conn this.WebLog.Id cat.Id pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with model.HasNewer <- match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindNewerCategorizedPost conn cat.Id | _ -> Option.isSome <| tryFindNewerCategorizedPost conn cat.Id
(List.head model.Posts).Post (List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with model.HasOlder <- match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindOlderCategorizedPost conn cat.Id | _ -> Option.isSome <| tryFindOlderCategorizedPost conn cat.Id
(List.last model.Posts).Post (List.last model.Posts).Post
model.UrlPrefix <- sprintf "/category/%s" slug model.UrlPrefix <- sprintf "/category/%s" slug
model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name
(match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n) (match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n)
model.Subtitle <- Some <| match cat.Description with model.Subtitle <- Some <| match cat.Description with
| Some desc -> desc | Some desc -> desc
| None -> sprintf "Posts in the \"%s\" category" cat.Name | None -> sprintf "Posts in the \"%s\" category" cat.Name
this.ThemedView "index" model this.ThemedView "index" model
| None -> this.NotFound () | None -> this.NotFound ()
/// Display tagged posts /// Display tagged posts
member this.TaggedPosts (parameters : DynamicDictionary) = member this.TaggedPosts (parameters : DynamicDictionary) =
@ -158,12 +156,12 @@ type PostModule(conn : IConnection, clock : IClock) as this =
model.Posts <- findPageOfTaggedPosts conn this.WebLog.Id tag pageNbr 10 |> forDisplay model.Posts <- findPageOfTaggedPosts conn this.WebLog.Id tag pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with model.HasNewer <- match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindNewerTaggedPost conn tag (List.head model.Posts).Post | _ -> Option.isSome <| tryFindNewerTaggedPost conn tag (List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with model.HasOlder <- match List.isEmpty model.Posts with
| true -> false | true -> false
| _ -> Option.isSome <| tryFindOlderTaggedPost conn tag (List.last model.Posts).Post | _ -> Option.isSome <| tryFindOlderTaggedPost conn tag (List.last model.Posts).Post
model.UrlPrefix <- sprintf "/tag/%s" tag model.UrlPrefix <- sprintf "/tag/%s" tag
model.PageTitle <- sprintf "\"%s\" Tag%s" tag (match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n) model.PageTitle <- sprintf "\"%s\" Tag%s" tag (match pageNbr with 1 -> "" | n -> sprintf " | Page %i" n)
model.Subtitle <- Some <| sprintf "Posts tagged \"%s\"" tag model.Subtitle <- Some <| sprintf "Posts tagged \"%s\"" tag
this.ThemedView "index" model this.ThemedView "index" model
@ -173,9 +171,9 @@ type PostModule(conn : IConnection, clock : IClock) as this =
match query.ContainsKey "format" with match query.ContainsKey "format" with
| true -> match query.["format"].ToString () with | true -> match query.["format"].ToString () with
| x when x = "atom" || x = "rss" -> generateFeed x | x when x = "atom" || x = "rss" -> generateFeed x
| x when x = "rss2" -> generateFeed "rss" | x when x = "rss2" -> generateFeed "rss"
| _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog)) | _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog))
| _ -> generateFeed "rss" | _ -> generateFeed "rss"
// ---- Administer posts ---- // ---- Administer posts ----
@ -195,9 +193,7 @@ type PostModule(conn : IConnection, clock : IClock) as this =
member this.EditPost (parameters : DynamicDictionary) = member this.EditPost (parameters : DynamicDictionary) =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let postId = parameters.["postId"].ToString () let postId = parameters.["postId"].ToString ()
match (match postId with match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost conn this.WebLog.Id postId) with
| "new" -> Some Post.Empty
| _ -> tryFindPost conn this.WebLog.Id postId) with
| Some post -> let rev = match post.Revisions | Some post -> let rev = match post.Revisions
|> List.sortByDescending (fun r -> r.AsOf) |> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with |> List.tryHead with
@ -211,7 +207,7 @@ type PostModule(conn : IConnection, clock : IClock) as this =
(fst cat).Name) (fst cat).Name)
model.PageTitle <- match post.Id with "new" -> Resources.AddNewPost | _ -> Resources.EditPost model.PageTitle <- match post.Id with "new" -> Resources.AddNewPost | _ -> Resources.EditPost
upcast this.View.["admin/post/edit"] upcast this.View.["admin/post/edit"]
| None -> this.NotFound () | None -> this.NotFound ()
/// Save a post /// Save a post
member this.SavePost (parameters : DynamicDictionary) = member this.SavePost (parameters : DynamicDictionary) =
@ -220,9 +216,7 @@ type PostModule(conn : IConnection, clock : IClock) as this =
let postId = parameters.["postId"].ToString () let postId = parameters.["postId"].ToString ()
let form = this.Bind<EditPostForm>() let form = this.Bind<EditPostForm>()
let now = clock.Now.Ticks let now = clock.Now.Ticks
match (match postId with match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost conn this.WebLog.Id postId) with
| "new" -> Some Post.Empty
| _ -> tryFindPost conn this.WebLog.Id postId) with
| Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow | Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow
let post = match postId with let post = match postId with
| "new" -> { p with | "new" -> { p with
@ -258,4 +252,4 @@ type PostModule(conn : IConnection, clock : IClock) as this =
(match justPublished with | true -> Resources.AndPublished | _ -> "")) } (match justPublished with | true -> Resources.AndPublished | _ -> "")) }
|> model.AddMessage |> model.AddMessage
this.Redirect (sprintf "/post/%s/edit" pId) model this.Redirect (sprintf "/post/%s/edit" pId) model
| None -> this.NotFound () | None -> this.NotFound ()

16
src/myWebLog.Web/UserModule.fs
View File

@ -12,12 +12,12 @@ open RethinkDb.Driver.Net
open System.Text open System.Text
/// Handle /user URLs /// Handle /user URLs
type UserModule(conn : IConnection) as this = type UserModule(conn : IConnection, cfg : AppConfig) as this =
inherit NancyModule("/user") inherit NancyModule("/user")
/// Hash the user's password /// Hash the user's password
let pbkdf2 (pw : string) = let pbkdf2 (pw : string) =
PassphraseKeyGenerator(pw, UTF8Encoding().GetBytes("// TODO: make this salt part of the config"), 4096).GetBytes 512 PassphraseKeyGenerator(pw, cfg.PasswordSalt, 4096).GetBytes 512
|> Seq.fold (fun acc byt -> sprintf "%s%s" acc (byt.ToString "x2")) "" |> Seq.fold (fun acc byt -> sprintf "%s%s" acc (byt.ToString "x2")) ""
do do
@ -29,9 +29,7 @@ type UserModule(conn : IConnection) as this =
member this.ShowLogOn () = member this.ShowLogOn () =
let model = LogOnModel(this.Context, this.WebLog) let model = LogOnModel(this.Context, this.WebLog)
let query = this.Request.Query :?> DynamicDictionary let query = this.Request.Query :?> DynamicDictionary
model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with true -> query.["returnUrl"].ToString () | _ -> ""
| true -> query.["returnUrl"].ToString ()
| _ -> ""
upcast this.View.["admin/user/logon", model] upcast this.View.["admin/user/logon", model]
/// Process a user log on /// Process a user log on
@ -48,10 +46,10 @@ type UserModule(conn : IConnection) as this =
// TODO: investigate if addMessage should update the session when it's called // TODO: investigate if addMessage should update the session when it's called
upcast this.LoginAndRedirect (System.Guid.Parse user.Id, upcast this.LoginAndRedirect (System.Guid.Parse user.Id,
fallbackRedirectUrl = defaultArg (Option.ofObj form.ReturnUrl) "/") fallbackRedirectUrl = defaultArg (Option.ofObj form.ReturnUrl) "/")
| None -> { UserMessage.Empty with Level = Level.Error | None -> { UserMessage.Empty with Level = Level.Error
Message = Resources.ErrBadLogOnAttempt } Message = Resources.ErrBadLogOnAttempt }
|> model.AddMessage |> model.AddMessage
this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model
/// Log a user off /// Log a user off
member this.LogOff () = member this.LogOff () =

13
src/myWebLog.Web/ViewModels.fs
View File

@ -11,6 +11,7 @@ open System
/// Levels for a user message /// Levels for a user message
[<RequireQualifiedAccess>]
module Level = module Level =
/// An informational message /// An informational message
let Info = "Info" let Info = "Info"
@ -59,7 +60,7 @@ with
match this.Details with match this.Details with
| Some d -> yield "<br />" | Some d -> yield "<br />"
yield d yield d
| None -> () | None -> ()
yield "</div>" yield "</div>"
} }
|> Seq.reduce (+) |> Seq.reduce (+)
@ -128,7 +129,7 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
match this.PageTitle with match this.PageTitle with
| "" -> match this.WebLog.Subtitle with | "" -> match this.WebLog.Subtitle with
| Some st -> sprintf "%s | %s" this.WebLog.Name st | Some st -> sprintf "%s | %s" this.WebLog.Name st
| None -> this.WebLog.Name | None -> this.WebLog.Name
| pt -> sprintf "%s | %s" pt this.WebLog.Name | pt -> sprintf "%s | %s" pt this.WebLog.Name
/// An image with the version and load time in the tool tip /// An image with the version and load time in the tool tip
@ -299,9 +300,9 @@ type PostModel(ctx, webLog, post) =
/// The post being displayed /// The post being displayed
member this.Post : Post = post member this.Post : Post = post
/// The next newer post /// The next newer post
member val NewerPost = Option<Post>.None with get, set member val NewerPost : Post option = None with get, set
/// The next older post /// The next older post
member val OlderPost = Option<Post>.None with get, set member val OlderPost : Post option = None with get, set
/// The date the post was published /// The date the post was published
member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn
/// The time the post was published /// The time the post was published
@ -343,7 +344,7 @@ type PostForDisplay(webLog : WebLog, post : Post) =
type PostsModel(ctx, webLog) = type PostsModel(ctx, webLog) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel(ctx, webLog)
/// The subtitle for the page /// The subtitle for the page
member val Subtitle = Option<string>.None with get, set member val Subtitle : string option = None with get, set
/// The posts to display /// The posts to display
member val Posts : PostForDisplay list = [] with get, set member val Posts : PostForDisplay list = [] with get, set
/// The page number of the post list /// The page number of the post list
@ -359,7 +360,7 @@ type PostsModel(ctx, webLog) =
member this.NewerLink = member this.NewerLink =
match this.UrlPrefix = "/posts" && this.PageNbr = 2 && this.WebLog.DefaultPage = "posts" with match this.UrlPrefix = "/posts" && this.PageNbr = 2 && this.WebLog.DefaultPage = "posts" with
| true -> "/" | true -> "/"
| _ -> sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr - 1) | _ -> sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr - 1)
/// The link for the prior (older) page of posts /// The link for the prior (older) page of posts
member this.OlderLink = sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr + 1) member this.OlderLink = sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr + 1)

1
src/myWebLog.Web/myWebLog.Web.fsproj
View File

@ -52,6 +52,7 @@
<ItemGroup> <ItemGroup>
<Compile Include="AssemblyInfo.fs" /> <Compile Include="AssemblyInfo.fs" />
<Compile Include="Keys.fs" /> <Compile Include="Keys.fs" />
<Compile Include="AppConfig.fs" />
<Compile Include="ViewModels.fs" /> <Compile Include="ViewModels.fs" />
<Compile Include="ModuleExtensions.fs" /> <Compile Include="ModuleExtensions.fs" />
<Compile Include="AdminModule.fs" /> <Compile Include="AdminModule.fs" />

17
src/myWebLog/config.json Normal file
View File

@ -0,0 +1,17 @@
{
// https://www.grc.com/passwords.htm is a great source of high-entropy passwords for these first 4 settings.
// Although what is there looks strong, keep in mind that it's what's in source control, so all instances of myWebLog
// could be using these values; that severly decreases their usefulness. :)
//
// WARNING: Changing this first one will render every single user's login inaccessible, including yours. Only do
// this if you are editing this file before setting up an instance, or if that is what you intend to do.
"password-salt": "3RVkw1jESpLFHr8F3WTThSbFnO3tFrMIckQsKzc9dymzEEXUoUS7nurF4rGpJ8Z",
// Changing any of these next 3 will render all current logins invalid, and the user will be force to reauthenticate.
"auth-salt": "2TweL5wcyGWg5CmMqZSZMonbe9xqQ2Q4vDNeysFRaUgVs4BpFZL85Iew79tn2IJ",
"encryption-passphrase": "jZjY6XyqUZypBcT0NaDXjEKc8xUjB4eb4V9EDHDedadRLuRUeRvIQx67yhx6bQP",
"hmac-passphrase": "42dzKb93X8YUkK8ms8JldjtkEvCKnPQGWCkO2yFaZ7lkNwECGCX00xzrx5ZSElO",
"data": {
"database": "myWebLog",
"hostname": "severus-server"
}
}

4
src/myWebLog/data-config.json
View File

@ -1,4 +0,0 @@
{
"database": "myWebLog",
"hostname": "severus-server"
}

2
src/myWebLog/myWebLog.csproj
View File

@ -48,7 +48,7 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<None Include="App.config" /> <None Include="App.config" />
<Content Include="data-config.json"> <Content Include="config.json">
<CopyToOutputDirectory>Always</CopyToOutputDirectory> <CopyToOutputDirectory>Always</CopyToOutputDirectory>
</Content> </Content>
<Content Include="views\themes\default\content\bootstrap-theme.css.map"> <Content Include="views\themes\default\content\bootstrap-theme.css.map">