From b9464f9600840feb9429d541a087fb02814870eb Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 27 Jul 2016 22:36:28 -0500 Subject: [PATCH] App-level Config / code style 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 --- src/myWebLog.Data/Category.fs | 26 +++---- src/myWebLog.Data/DataConfig.fs | 11 ++- src/myWebLog.Data/Entities.fs | 36 +++++---- src/myWebLog.Data/Page.fs | 26 +++---- src/myWebLog.Data/Post.fs | 16 ++-- src/myWebLog.Data/SetUp.fs | 47 ++++++------ src/myWebLog.Data/Table.fs | 4 +- src/myWebLog.Resources/Resources.Designer.cs | 9 +++ src/myWebLog.Resources/Resources.resx | 3 + src/myWebLog.Web/App.fs | 61 ++++++++------- src/myWebLog.Web/AppConfig.fs | 33 +++++++++ src/myWebLog.Web/CategoryModule.fs | 26 +++---- src/myWebLog.Web/Keys.fs | 8 +- src/myWebLog.Web/PageModule.fs | 18 ++--- src/myWebLog.Web/PostModule.fs | 78 +++++++++----------- src/myWebLog.Web/UserModule.fs | 16 ++-- src/myWebLog.Web/ViewModels.fs | 13 ++-- src/myWebLog.Web/myWebLog.Web.fsproj | 1 + src/myWebLog/config.json | 17 +++++ src/myWebLog/data-config.json | 4 - src/myWebLog/myWebLog.csproj | 2 +- 21 files changed, 253 insertions(+), 202 deletions(-) create mode 100644 src/myWebLog.Web/AppConfig.fs create mode 100644 src/myWebLog/config.json delete mode 100644 src/myWebLog/data-config.json diff --git a/src/myWebLog.Data/Category.fs b/src/myWebLog.Data/Category.fs index f498fe8..043b287 100644 --- a/src/myWebLog.Data/Category.fs +++ b/src/myWebLog.Data/Category.fs @@ -43,7 +43,7 @@ let tryFindCategory conn webLogId catId : Category option = match (category webLogId catId) .RunAtomAsync(conn) |> await |> box with | null -> None - | cat -> Some <| unbox cat + | cat -> Some <| unbox cat /// Save a category let saveCategory conn webLogId (cat : Category) = @@ -54,15 +54,15 @@ let saveCategory conn webLogId (cat : Category) = .Insert(newCat) .RunResultAsync(conn) |> await |> ignore newCat.Id - | _ -> let upd8 = ExpandoObject() - upd8?Name <- cat.Name - upd8?Slug <- cat.Slug - upd8?Description <- cat.Description - upd8?ParentId <- cat.ParentId - (category webLogId cat.Id) - .Update(upd8) - .RunResultAsync(conn) |> await |> ignore - cat.Id + | _ -> let upd8 = ExpandoObject() + upd8?Name <- cat.Name + upd8?Slug <- cat.Slug + upd8?Description <- cat.Description + upd8?ParentId <- cat.ParentId + (category webLogId cat.Id) + .Update(upd8) + .RunResultAsync(conn) |> await |> ignore + cat.Id /// Remove a category from a given parent let removeCategoryFromParent conn webLogId parentId catId = @@ -73,7 +73,7 @@ let removeCategoryFromParent conn webLogId parentId catId = (category webLogId parentId) .Update(upd8) .RunResultAsync(conn) |> await |> ignore - | None -> () + | None -> () /// Add a category to a given parent let addCategoryToParent conn webLogId parentId catId = @@ -83,14 +83,14 @@ let addCategoryToParent conn webLogId parentId catId = (category webLogId parentId) .Update(upd8) .RunResultAsync(conn) |> await |> ignore - | None -> () + | None -> () /// Delete a category let deleteCategory conn cat = // Remove the category from its parent match cat.ParentId with | Some parentId -> removeCategoryFromParent conn cat.WebLogId parentId cat.Id - | None -> () + | None -> () // Move this category's children to its parent let newParent = ExpandoObject() newParent?ParentId <- cat.ParentId diff --git a/src/myWebLog.Data/DataConfig.fs b/src/myWebLog.Data/DataConfig.fs index 49325de..95e63f5 100644 --- a/src/myWebLog.Data/DataConfig.fs +++ b/src/myWebLog.Data/DataConfig.fs @@ -25,8 +25,8 @@ type DataConfig = [] Conn : IConnection } with - /// Create a data configuration from JSON - static member FromJson json = + /// Use RethinkDB defaults for non-provided options, and connect to the server + static member Connect config = let ensureHostname cfg = match cfg.Hostname with | null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname } | _ -> cfg @@ -35,13 +35,13 @@ with | _ -> cfg let ensureAuthKey cfg = match cfg.AuthKey with | null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey } - | _ -> cfg + | _ -> cfg let ensureTimeout cfg = match cfg.Timeout with | 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout } | _ -> cfg let ensureDatabase cfg = match cfg.Database with | null -> { cfg with Database = RethinkDBConstants.DefaultDbName } - | _ -> cfg + | _ -> cfg let connect cfg = { cfg with Conn = RethinkDB.R.Connection() .Hostname(cfg.Hostname) .Port(cfg.Port) @@ -49,11 +49,10 @@ with .Db(cfg.Database) .Timeout(cfg.Timeout) .Connect() } - JsonConvert.DeserializeObject json + config |> ensureHostname |> ensurePort |> ensureAuthKey |> ensureTimeout |> ensureDatabase |> connect - diff --git a/src/myWebLog.Data/Entities.fs b/src/myWebLog.Data/Entities.fs index df767ad..60cfde2 100644 --- a/src/myWebLog.Data/Entities.fs +++ b/src/myWebLog.Data/Entities.fs @@ -5,34 +5,38 @@ open Newtonsoft.Json // ---- Constants ---- /// Constants to use for revision source language +[] module RevisionSource = [] let Markdown = "markdown" [] - let HTML = "html" + let HTML = "html" /// Constants to use for authorization levels +[] module AuthorizationLevel = [] let Administrator = "Administrator" [] - let User = "User" + let User = "User" /// Constants to use for post statuses +[] module PostStatus = [] - let Draft = "Draft" + let Draft = "Draft" [] let Published = "Published" /// Constants to use for comment statuses +[] module CommentStatus = [] let Approved = "Approved" [] - let Pending = "Pending" + let Pending = "Pending" [] - let Spam = "Spam" + let Spam = "Spam" // ---- Entities ---- @@ -84,7 +88,7 @@ with UpdatedOn = int64 0 ShowInPageList = false Text = "" - Revisions = List.empty + Revisions = [] } @@ -121,7 +125,7 @@ with ThemePath = "default" UrlBase = "" TimeZone = "America/New_York" - PageList = List.empty } + PageList = [] } /// An authorization between a user and a web log @@ -160,7 +164,7 @@ with PreferredName = "" PasswordHash = "" Url = None - Authorizations = List.empty } + Authorizations = [] } /// Claims for this user [] @@ -186,14 +190,14 @@ type Category = Children : string list } with /// An empty category - static member empty = + static member Empty = { Id = "new" WebLogId = "" Name = "" Slug = "" Description = None ParentId = None - Children = List.empty } + Children = [] } /// A comment (applies to a post) @@ -272,9 +276,9 @@ with PublishedOn = int64 0 UpdatedOn = int64 0 Text = "" - CategoryIds = List.empty - Tags = List.empty - PriorPermalinks = List.empty - Revisions = List.empty - Categories = List.empty - Comments = List.empty } + CategoryIds = [] + Tags = [] + PriorPermalinks = [] + Revisions = [] + Categories = [] + Comments = [] } diff --git a/src/myWebLog.Data/Page.fs b/src/myWebLog.Data/Page.fs index 9f2d299..c1cec81 100644 --- a/src/myWebLog.Data/Page.fs +++ b/src/myWebLog.Data/Page.fs @@ -21,9 +21,7 @@ let tryFindPage conn webLogId pageId = .RunAtomAsync(conn) |> await |> box with | null -> None | page -> let pg : Page = unbox page - match pg.WebLogId = webLogId with - | true -> Some pg - | _ -> None + match pg.WebLogId = webLogId with true -> Some pg | _ -> None /// Get a page by its Id (excluding revisions) let tryFindPageWithoutRevisions conn webLogId pageId : Page option = @@ -60,17 +58,17 @@ let savePage conn (pg : Page) = .Insert(page) .RunResultAsync(conn) |> await |> ignore newPage.Id - | _ -> let upd8 = ExpandoObject() - upd8?Title <- pg.Title - upd8?Permalink <- pg.Permalink - upd8?PublishedOn <- pg.PublishedOn - upd8?UpdatedOn <- pg.UpdatedOn - upd8?Text <- pg.Text - upd8?Revisions <- pg.Revisions - (page pg.WebLogId pg.Id) - .Update(upd8) - .RunResultAsync(conn) |> await |> ignore - pg.Id + | _ -> let upd8 = ExpandoObject() + upd8?Title <- pg.Title + upd8?Permalink <- pg.Permalink + upd8?PublishedOn <- pg.PublishedOn + upd8?UpdatedOn <- pg.UpdatedOn + upd8?Text <- pg.Text + upd8?Revisions <- pg.Revisions + (page pg.WebLogId pg.Id) + .Update(upd8) + .RunResultAsync(conn) |> await |> ignore + pg.Id /// Delete a page let deletePage conn webLogId pageId = diff --git a/src/myWebLog.Data/Post.fs b/src/myWebLog.Data/Post.fs index 5e916ce..c0a442d 100644 --- a/src/myWebLog.Data/Post.fs +++ b/src/myWebLog.Data/Post.fs @@ -101,8 +101,6 @@ let tryFindPost conn webLogId postId : Post option = | post -> Some <| unbox post /// 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 = r.Table(Table.Post) .GetAll(r.Array(webLogId, permalink)).OptArg("index", "Permalink") @@ -157,10 +155,10 @@ let savePost conn post = .RunResultAsync(conn) |> ignore newPost.Id - | _ -> r.Table(Table.Post) - .Get(post.Id) - .Replace( { post with Categories = List.empty - Comments = List.empty } ) - .RunResultAsync(conn) - |> ignore - post.Id + | _ -> r.Table(Table.Post) + .Get(post.Id) + .Replace( { post with Categories = [] + Comments = [] } ) + .RunResultAsync(conn) + |> ignore + post.Id diff --git a/src/myWebLog.Data/SetUp.fs b/src/myWebLog.Data/SetUp.fs index 041f9cd..0f4fd3c 100644 --- a/src/myWebLog.Data/SetUp.fs +++ b/src/myWebLog.Data/SetUp.fs @@ -10,63 +10,60 @@ let private logStepStart text = Console.Out.Write (sprintf "[myWebLog] %s... let private logStepDone () = Console.Out.WriteLine (" done.") /// Ensure the myWebLog database exists -let checkDatabase (cfg : DataConfig) = +let private checkDatabase (cfg : DataConfig) = logStep "|> Checking database" let dbs = r.DbList().RunListAsync(cfg.Conn) |> await match dbs.Contains cfg.Database with | true -> () - | _ -> logStepStart (sprintf " %s database not found - creating" cfg.Database) - r.DbCreate(cfg.Database).RunResultAsync(cfg.Conn) |> await |> ignore - logStepDone () + | _ -> logStepStart (sprintf " %s database not found - creating" cfg.Database) + r.DbCreate(cfg.Database).RunResultAsync(cfg.Conn) |> await |> ignore + logStepDone () /// Ensure all required tables exist -let checkTables cfg = +let private checkTables cfg = logStep "|> Checking tables" let tables = r.Db(cfg.Database).TableList().RunListAsync(cfg.Conn) |> await [ Table.Category; Table.Comment; Table.Page; Table.Post; Table.User; Table.WebLog ] - |> List.map (fun tbl -> match tables.Contains tbl with - | true -> None - | _ -> Some (tbl, r.TableCreate tbl)) - |> List.filter (fun create -> create.IsSome) - |> List.map (fun create -> create.Value) + |> List.map (fun tbl -> match tables.Contains tbl with true -> None | _ -> Some (tbl, r.TableCreate tbl)) + |> List.filter Option.isSome + |> List.map Option.get |> List.iter (fun (tbl, create) -> logStepStart (sprintf " Creating table %s" tbl) create.RunResultAsync(cfg.Conn) |> await |> ignore logStepDone ()) /// 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 -let createIndex cfg table (index : string * (ReqlExpr -> obj) option) = +let private createIndex cfg table (index : string * (ReqlExpr -> obj) option) = let idxName, idxFunc = index logStepStart (sprintf """ Creating index "%s" on table %s""" idxName table) - match idxFunc with - | Some f -> (tbl cfg table).IndexCreate(idxName, f).RunResultAsync(cfg.Conn) - | None -> (tbl cfg table).IndexCreate(idxName ).RunResultAsync(cfg.Conn) + (match idxFunc with + | Some f -> (tbl cfg table).IndexCreate(idxName, f) + | None -> (tbl cfg table).IndexCreate(idxName)) + .RunResultAsync(cfg.Conn) |> await |> ignore (tbl cfg table).IndexWait(idxName).RunAtomAsync(cfg.Conn) |> await |> ignore logStepDone () /// Ensure that the given indexes exist, and create them if required -let ensureIndexes cfg (indexes : (string * (string * (ReqlExpr -> obj) option) list) list) = - let ensureForTable tabl = - let idx = (tbl cfg (fst tabl)).IndexList().RunListAsync(cfg.Conn) |> await - snd tabl - |> List.iter (fun index -> match idx.Contains (fst index) with - | true -> () - | _ -> createIndex cfg (fst tabl) index) +let private ensureIndexes cfg (indexes : (string * (string * (ReqlExpr -> obj) option) list) list) = + let ensureForTable (tblName, idxs) = + let idx = (tbl cfg tblName).IndexList().RunListAsync(cfg.Conn) |> await + idxs + |> List.iter (fun index -> match idx.Contains (fst index) with true -> () | _ -> createIndex cfg tblName index) indexes |> List.iter ensureForTable /// 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 -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]) /// Ensure all the required indexes exist -let checkIndexes cfg = +let private checkIndexes cfg = logStep "|> Checking indexes" [ Table.Category, [ "WebLogId", None "Slug", webLogField "Slug" diff --git a/src/myWebLog.Data/Table.fs b/src/myWebLog.Data/Table.fs index 7191881..082f3cb 100644 --- a/src/myWebLog.Data/Table.fs +++ b/src/myWebLog.Data/Table.fs @@ -1,4 +1,6 @@ -module MyWebLog.Data.Table +/// Constants for tables used in myWebLog +[] +module MyWebLog.Data.Table /// The Category table let Category = "Category" diff --git a/src/myWebLog.Resources/Resources.Designer.cs b/src/myWebLog.Resources/Resources.Designer.cs index 1d165e9..9510e5a 100644 --- a/src/myWebLog.Resources/Resources.Designer.cs +++ b/src/myWebLog.Resources/Resources.Designer.cs @@ -240,6 +240,15 @@ namespace MyWebLog { } } + /// + /// Looks up a localized string similar to Could not convert config.json to myWebLog configuration. + /// + public static string ErrBadAppConfig { + get { + return ResourceManager.GetString("ErrBadAppConfig", resourceCulture); + } + } + /// /// Looks up a localized string similar to Invalid e-mail address or password. /// diff --git a/src/myWebLog.Resources/Resources.resx b/src/myWebLog.Resources/Resources.resx index 054947a..1cb3fe9 100644 --- a/src/myWebLog.Resources/Resources.resx +++ b/src/myWebLog.Resources/Resources.resx @@ -327,4 +327,7 @@ Seconds + + Could not convert config.json to myWebLog configuration + \ No newline at end of file diff --git a/src/myWebLog.Web/App.fs b/src/myWebLog.Web/App.fs index ddd5248..0e1fc37 100644 --- a/src/myWebLog.Web/App.fs +++ b/src/myWebLog.Web/App.fs @@ -24,22 +24,22 @@ open System open System.IO open System.Text.RegularExpressions -/// Set up a database connection -let cfg = try DataConfig.FromJson (System.IO.File.ReadAllText "data-config.json") - with ex -> raise <| ApplicationException(Resources.ErrDataConfig, ex) +/// Establish the configuration for this instance +let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json") + with ex -> raise <| ApplicationException(Resources.ErrBadAppConfig, ex) do - startUpCheck cfg + startUpCheck cfg.DataConfig /// Support RESX lookup 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) = - regex.Replace(content, fun m -> let key = m.Groups.["TranslationKey"].Value - match MyWebLog.Resources.ResourceManager.GetString key with - | null -> key - | xlat -> xlat) + let translate (m : Match) = + let key = m.Groups.["TranslationKey"].Value + match MyWebLog.Resources.ResourceManager.GetString key with null -> key | xlat -> xlat + regex.Replace(content, translate) /// Handle forms authentication @@ -47,8 +47,6 @@ type MyWebLogUser(name, claims) = interface IUserIdentity with member this.UserName with get() = name 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) = @@ -71,23 +69,24 @@ type MyWebLogBootstrapper() = override this.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 (StaticContentConventionBuilder.AddDirectory("admin/content", "views/admin/content")) - // Make theme content available at [theme-name]/ Directory.EnumerateDirectories (Path.Combine [| "views"; "themes" |]) - |> Seq.iter (fun dir -> let contentDir = Path.Combine [| dir; "content" |] - match Directory.Exists contentDir with - | true -> conventions.StaticContentsConventions.Add - (StaticContentConventionBuilder.AddDirectory - ((Path.GetFileName dir), contentDir)) - | _ -> ()) + |> Seq.iter addContentDir override this.ApplicationStartup (container, pipelines) = base.ApplicationStartup (container, pipelines) // Data configuration (both config and the connection; Nancy modules just need the connection) - container.Register(cfg) + container.Register(cfg) |> ignore - container.Register(cfg.Conn) + container.Register(cfg.DataConfig.Conn) |> ignore // NodaTime container.Register(SystemClock.Instance) @@ -97,20 +96,20 @@ type MyWebLogBootstrapper() = Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher)) |> ignore // Forms authentication configuration - let salt = (System.Text.ASCIIEncoding()).GetBytes "NoneOfYourBeesWax" let auth = FormsAuthenticationConfiguration( - CryptographyConfiguration = CryptographyConfiguration - (RijndaelEncryptionProvider(PassphraseKeyGenerator("Secrets", salt)), - DefaultHmacProvider(PassphraseKeyGenerator("Clandestine", salt))), - RedirectUrl = "~/user/logon", - UserMapper = container.Resolve()) + CryptographyConfiguration = + CryptographyConfiguration( + RijndaelEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)), + DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))), + RedirectUrl = "~/user/logon", + UserMapper = container.Resolve()) FormsAuthentication.Enable (pipelines, auth) // CSRF Csrf.Enable pipelines // Sessions - let sessions = RethinkDbSessionConfiguration(cfg.Conn) - sessions.Database <- cfg.Database + let sessions = RethinkDbSessionConfiguration(cfg.DataConfig.Conn) + sessions.Database <- cfg.DataConfig.Database PersistableSessions.Enable (pipelines, sessions) () @@ -130,11 +129,11 @@ type RequestEnvironment() = member this.Initialize (pipelines, context) = let establishEnv (ctx : NancyContext) = 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 - | None -> // TODO: redirect to domain set up page - ApplicationException (sprintf "%s %s" ctx.Request.Url.HostName Resources.ErrNotConfigured) - |> raise + | None -> // TODO: redirect to domain set up page + ApplicationException (sprintf "%s %s" ctx.Request.Url.HostName Resources.ErrNotConfigured) + |> raise ctx.Items.[Keys.Version] <- version null pipelines.BeforeRequest.AddItemToStartOfPipeline establishEnv diff --git a/src/myWebLog.Web/AppConfig.fs b/src/myWebLog.Web/AppConfig.fs new file mode 100644 index 0000000..dbc2762 --- /dev/null +++ b/src/myWebLog.Web/AppConfig.fs @@ -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 + [] + PasswordSaltString : string + /// The text from which to derive salt to use for forms authentication + [] + AuthSaltString : string + /// The encryption passphrase to use for forms authentication + [] + AuthEncryptionPassphrase : string + /// The HMAC passphrase to use for forms authentication + [] + AuthHmacPassphrase : string + /// The data configuration + [] + 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 json + { cfg with DataConfig = DataConfig.Connect cfg.DataConfig } \ No newline at end of file diff --git a/src/myWebLog.Web/CategoryModule.fs b/src/myWebLog.Web/CategoryModule.fs index a3352d6..f0a67d9 100644 --- a/src/myWebLog.Web/CategoryModule.fs +++ b/src/myWebLog.Web/CategoryModule.fs @@ -30,14 +30,14 @@ type CategoryModule(conn : IConnection) as this = this.RequiresAccessLevel AuthorizationLevel.Administrator let catId = parameters.["id"].ToString () match (match catId with - | "new" -> Some Category.empty - | _ -> tryFindCategory conn this.WebLog.Id catId) with + | "new" -> Some Category.Empty + | _ -> tryFindCategory conn this.WebLog.Id catId) with | Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat) model.Categories <- getAllCategories conn this.WebLog.Id |> List.map (fun cat -> IndentedCategory.Create cat (fun c -> c = defaultArg (fst cat).ParentId "")) upcast this.View.["admin/category/edit", model] - | None -> this.NotFound () + | None -> this.NotFound () /// Save a category member this.SaveCategory (parameters : DynamicDictionary) = @@ -45,9 +45,7 @@ type CategoryModule(conn : IConnection) as this = this.RequiresAccessLevel AuthorizationLevel.Administrator let catId = parameters.["id"].ToString () let form = this.Bind () - let oldCat = match catId with - | "new" -> Some Category.empty - | _ -> tryFindCategory conn this.WebLog.Id catId + let oldCat = match catId with "new" -> Some Category.Empty | _ -> tryFindCategory conn this.WebLog.Id catId match oldCat with | Some old -> let cat = { old with Name = form.Name Slug = form.Slug @@ -56,12 +54,12 @@ type CategoryModule(conn : IConnection) as this = let newCatId = saveCategory conn this.WebLog.Id cat match old.ParentId = cat.ParentId with | true -> () - | _ -> match old.ParentId with - | Some parentId -> removeCategoryFromParent conn this.WebLog.Id parentId newCatId - | None -> () - match cat.ParentId with - | Some parentId -> addCategoryToParent conn this.WebLog.Id parentId newCatId - | None -> () + | _ -> match old.ParentId with + | Some parentId -> removeCategoryFromParent conn this.WebLog.Id parentId newCatId + | None -> () + match cat.ParentId with + | Some parentId -> addCategoryToParent conn this.WebLog.Id parentId newCatId + | None -> () let model = MyWebLogModel(this.Context, this.WebLog) { UserMessage.Empty with Level = Level.Info @@ -70,7 +68,7 @@ type CategoryModule(conn : IConnection) as this = (match catId with | "new" -> Resources.Added | _ -> Resources.Updated)) } |> model.AddMessage this.Redirect (sprintf "/category/%s/edit" newCatId) model - | None -> this.NotFound () + | None -> this.NotFound () /// Delete a category member this.DeleteCategory (parameters : DynamicDictionary) = @@ -84,4 +82,4 @@ type CategoryModule(conn : IConnection) as this = Message = System.String.Format(Resources.MsgCategoryDeleted, cat.Name) } |> model.AddMessage this.Redirect "/categories" model - | None -> this.NotFound () + | None -> this.NotFound () diff --git a/src/myWebLog.Web/Keys.fs b/src/myWebLog.Web/Keys.fs index 18bc4e6..741b6b4 100644 --- a/src/myWebLog.Web/Keys.fs +++ b/src/myWebLog.Web/Keys.fs @@ -1,11 +1,17 @@ -module MyWebLog.Keys +[] +module MyWebLog.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 myWebLog let Version = "version" +/// The web log let WebLog = "web-log" \ No newline at end of file diff --git a/src/myWebLog.Web/PageModule.fs b/src/myWebLog.Web/PageModule.fs index 40fba18..17f8d3a 100644 --- a/src/myWebLog.Web/PageModule.fs +++ b/src/myWebLog.Web/PageModule.fs @@ -33,16 +33,16 @@ type PageModule(conn : IConnection, clock : IClock) as this = let pageId = parameters.["id"].ToString () match (match pageId with | "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 |> List.sortByDescending (fun r -> r.AsOf) |> List.tryHead with | Some r -> r - | None -> Revision.Empty + | None -> Revision.Empty let model = EditPageModel(this.Context, this.WebLog, page, rev) model.PageTitle <- match pageId with "new" -> Resources.AddNewPage | _ -> Resources.EditPage upcast this.View.["admin/page/edit", model] - | None -> this.NotFound () + | None -> this.NotFound () /// Save a page member this.SavePage (parameters : DynamicDictionary) = @@ -51,9 +51,7 @@ type PageModule(conn : IConnection, clock : IClock) as this = let pageId = parameters.["id"].ToString () let form = this.Bind () let now = clock.Now.Ticks - match (match pageId with - | "new" -> Some Page.Empty - | _ -> tryFindPage conn this.WebLog.Id pageId) with + match (match 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 let pId = { p with Title = form.Title @@ -62,7 +60,7 @@ type PageModule(conn : IConnection, clock : IClock) as this = UpdatedOn = now Text = match form.Source with | RevisionSource.Markdown -> Markdown.TransformHtml form.Text - | _ -> form.Text + | _ -> form.Text Revisions = { AsOf = now SourceType = form.Source Text = form.Text } :: page.Revisions } @@ -72,10 +70,10 @@ type PageModule(conn : IConnection, clock : IClock) as this = Level = Level.Info Message = System.String.Format (Resources.MsgPageEditSuccess, - (match pageId with | "new" -> Resources.Added | _ -> Resources.Updated)) } + (match pageId with "new" -> Resources.Added | _ -> Resources.Updated)) } |> model.AddMessage this.Redirect (sprintf "/page/%s/edit" pId) model - | None -> this.NotFound () + | None -> this.NotFound () /// Delete a page member this.DeletePage (parameters : DynamicDictionary) = @@ -89,4 +87,4 @@ type PageModule(conn : IConnection, clock : IClock) as this = Message = Resources.MsgPageDeleted } |> model.AddMessage this.Redirect "/pages" model - | None -> this.NotFound () + | None -> this.NotFound () diff --git a/src/myWebLog.Web/PostModule.fs b/src/myWebLog.Web/PostModule.fs index a994fc2..466152b 100644 --- a/src/myWebLog.Web/PostModule.fs +++ b/src/myWebLog.Web/PostModule.fs @@ -81,25 +81,23 @@ type PostModule(conn : IConnection, clock : IClock) as this = | 1 -> false | _ -> match List.isEmpty model.Posts with | 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 | true -> false - | _ -> Option.isSome <| tryFindOlderPost conn (List.head model.Posts).Post + | _ -> Option.isSome <| tryFindOlderPost conn (List.head model.Posts).Post model.UrlPrefix <- "/posts" - model.PageTitle <- match pageNbr with - | 1 -> "" - | _ -> sprintf "%s%i" Resources.PageHash pageNbr + model.PageTitle <- match pageNbr with 1 -> "" | _ -> sprintf "%s%i" Resources.PageHash pageNbr this.ThemedView "index" model /// Display either the newest posts or the configured home page member this.HomePage () = match this.WebLog.DefaultPage with | "posts" -> this.PublishedPostsPage 1 - | pageId -> match tryFindPageWithoutRevisions conn this.WebLog.Id pageId with - | Some page -> let model = PageModel(this.Context, this.WebLog, page) - model.PageTitle <- page.Title - this.ThemedView "page" model - | None -> this.NotFound () + | pageId -> match tryFindPageWithoutRevisions conn this.WebLog.Id pageId with + | Some page -> let model = PageModel(this.Context, this.WebLog, page) + model.PageTitle <- page.Title + this.ThemedView "page" model + | None -> this.NotFound () /// Derive a post or page from the URL, or redirect from a prior URL to the current one member this.CatchAll (parameters : DynamicDictionary) = @@ -111,18 +109,18 @@ type PostModule(conn : IConnection, clock : IClock) as this = model.OlderPost <- tryFindOlderPost conn post model.PageTitle <- post.Title this.ThemedView "single" model - | None -> // Maybe it's a page permalink instead... - match tryFindPageByPermalink conn this.WebLog.Id url with - | Some page -> // ...and it is! - let model = PageModel(this.Context, this.WebLog, page) - model.PageTitle <- page.Title - this.ThemedView "page" model - | None -> // Maybe it's an old permalink for a post - match tryFindPostByPriorPermalink conn this.WebLog.Id url with - | Some post -> // Redirect them to the proper permalink - upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink) - .WithStatusCode HttpStatusCode.MovedPermanently - | None -> this.NotFound () + | None -> // Maybe it's a page permalink instead... + match tryFindPageByPermalink conn this.WebLog.Id url with + | Some page -> // ...and it is! + let model = PageModel(this.Context, this.WebLog, page) + model.PageTitle <- page.Title + this.ThemedView "page" model + | None -> // Maybe it's an old permalink for a post + match tryFindPostByPriorPermalink conn this.WebLog.Id url with + | Some post -> // Redirect them to the proper permalink + upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink) + .WithStatusCode HttpStatusCode.MovedPermanently + | None -> this.NotFound () /// Display categorized posts 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.HasNewer <- match List.isEmpty model.Posts with | true -> false - | _ -> Option.isSome <| tryFindNewerCategorizedPost conn cat.Id - (List.head model.Posts).Post + | _ -> Option.isSome <| tryFindNewerCategorizedPost conn cat.Id + (List.head model.Posts).Post model.HasOlder <- match List.isEmpty model.Posts with | true -> false - | _ -> Option.isSome <| tryFindOlderCategorizedPost conn cat.Id - (List.last model.Posts).Post + | _ -> Option.isSome <| tryFindOlderCategorizedPost conn cat.Id + (List.last model.Posts).Post model.UrlPrefix <- sprintf "/category/%s" slug model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name (match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n) model.Subtitle <- Some <| match cat.Description with | 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 - | None -> this.NotFound () + | None -> this.NotFound () /// Display tagged posts 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.HasNewer <- match List.isEmpty model.Posts with | 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 | 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.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 this.ThemedView "index" model @@ -173,9 +171,9 @@ type PostModule(conn : IConnection, clock : IClock) as this = match query.ContainsKey "format" with | true -> match query.["format"].ToString () with | x when x = "atom" || x = "rss" -> generateFeed x - | x when x = "rss2" -> generateFeed "rss" - | _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog)) - | _ -> generateFeed "rss" + | x when x = "rss2" -> generateFeed "rss" + | _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog)) + | _ -> generateFeed "rss" // ---- Administer posts ---- @@ -195,9 +193,7 @@ type PostModule(conn : IConnection, clock : IClock) as this = member this.EditPost (parameters : DynamicDictionary) = this.RequiresAccessLevel AuthorizationLevel.Administrator let postId = parameters.["postId"].ToString () - match (match postId with - | "new" -> Some Post.Empty - | _ -> tryFindPost conn this.WebLog.Id postId) with + match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost conn this.WebLog.Id postId) with | Some post -> let rev = match post.Revisions |> List.sortByDescending (fun r -> r.AsOf) |> List.tryHead with @@ -211,7 +207,7 @@ type PostModule(conn : IConnection, clock : IClock) as this = (fst cat).Name) model.PageTitle <- match post.Id with "new" -> Resources.AddNewPost | _ -> Resources.EditPost upcast this.View.["admin/post/edit"] - | None -> this.NotFound () + | None -> this.NotFound () /// Save a post member this.SavePost (parameters : DynamicDictionary) = @@ -220,9 +216,7 @@ type PostModule(conn : IConnection, clock : IClock) as this = let postId = parameters.["postId"].ToString () let form = this.Bind() let now = clock.Now.Ticks - match (match postId with - | "new" -> Some Post.Empty - | _ -> tryFindPost conn this.WebLog.Id postId) with + match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost conn this.WebLog.Id postId) with | Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow let post = match postId with | "new" -> { p with @@ -258,4 +252,4 @@ type PostModule(conn : IConnection, clock : IClock) as this = (match justPublished with | true -> Resources.AndPublished | _ -> "")) } |> model.AddMessage this.Redirect (sprintf "/post/%s/edit" pId) model - | None -> this.NotFound () + | None -> this.NotFound () diff --git a/src/myWebLog.Web/UserModule.fs b/src/myWebLog.Web/UserModule.fs index 7e6fb76..fe51ccc 100644 --- a/src/myWebLog.Web/UserModule.fs +++ b/src/myWebLog.Web/UserModule.fs @@ -12,12 +12,12 @@ open RethinkDb.Driver.Net open System.Text /// Handle /user URLs -type UserModule(conn : IConnection) as this = +type UserModule(conn : IConnection, cfg : AppConfig) as this = inherit NancyModule("/user") /// Hash the user's password 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")) "" do @@ -29,9 +29,7 @@ type UserModule(conn : IConnection) as this = member this.ShowLogOn () = let model = LogOnModel(this.Context, this.WebLog) let query = this.Request.Query :?> DynamicDictionary - model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with - | true -> query.["returnUrl"].ToString () - | _ -> "" + model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with true -> query.["returnUrl"].ToString () | _ -> "" upcast this.View.["admin/user/logon", model] /// 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 upcast this.LoginAndRedirect (System.Guid.Parse user.Id, fallbackRedirectUrl = defaultArg (Option.ofObj form.ReturnUrl) "/") - | None -> { UserMessage.Empty with Level = Level.Error - Message = Resources.ErrBadLogOnAttempt } - |> model.AddMessage - this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model + | None -> { UserMessage.Empty with Level = Level.Error + Message = Resources.ErrBadLogOnAttempt } + |> model.AddMessage + this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model /// Log a user off member this.LogOff () = diff --git a/src/myWebLog.Web/ViewModels.fs b/src/myWebLog.Web/ViewModels.fs index 093bb7b..75f8f3e 100644 --- a/src/myWebLog.Web/ViewModels.fs +++ b/src/myWebLog.Web/ViewModels.fs @@ -11,6 +11,7 @@ open System /// Levels for a user message +[] module Level = /// An informational message let Info = "Info" @@ -59,7 +60,7 @@ with match this.Details with | Some d -> yield "
" yield d - | None -> () + | None -> () yield "" } |> Seq.reduce (+) @@ -128,7 +129,7 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) = match this.PageTitle with | "" -> match this.WebLog.Subtitle with | 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 /// 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 member this.Post : Post = post /// The next newer post - member val NewerPost = Option.None with get, set + member val NewerPost : Post option = None with get, set /// The next older post - member val OlderPost = Option.None with get, set + member val OlderPost : Post option = None with get, set /// The date the post was published member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn /// The time the post was published @@ -343,7 +344,7 @@ type PostForDisplay(webLog : WebLog, post : Post) = type PostsModel(ctx, webLog) = inherit MyWebLogModel(ctx, webLog) /// The subtitle for the page - member val Subtitle = Option.None with get, set + member val Subtitle : string option = None with get, set /// The posts to display member val Posts : PostForDisplay list = [] with get, set /// The page number of the post list @@ -359,7 +360,7 @@ type PostsModel(ctx, webLog) = member this.NewerLink = match this.UrlPrefix = "/posts" && this.PageNbr = 2 && this.WebLog.DefaultPage = "posts" with | 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 member this.OlderLink = sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr + 1) diff --git a/src/myWebLog.Web/myWebLog.Web.fsproj b/src/myWebLog.Web/myWebLog.Web.fsproj index fc9cc04..59c8dfa 100644 --- a/src/myWebLog.Web/myWebLog.Web.fsproj +++ b/src/myWebLog.Web/myWebLog.Web.fsproj @@ -52,6 +52,7 @@ + diff --git a/src/myWebLog/config.json b/src/myWebLog/config.json new file mode 100644 index 0000000..12ae5f7 --- /dev/null +++ b/src/myWebLog/config.json @@ -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" + } +} \ No newline at end of file diff --git a/src/myWebLog/data-config.json b/src/myWebLog/data-config.json deleted file mode 100644 index 1efaace..0000000 --- a/src/myWebLog/data-config.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "database": "myWebLog", - "hostname": "severus-server" -} diff --git a/src/myWebLog/myWebLog.csproj b/src/myWebLog/myWebLog.csproj index 97773dc..613f01f 100644 --- a/src/myWebLog/myWebLog.csproj +++ b/src/myWebLog/myWebLog.csproj @@ -48,7 +48,7 @@ - + Always