bit-badger/myWebLog
1
0
Fork 0
Code Issues 2 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)
.RunAtomAsync<Category>(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

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

@ -25,8 +25,8 @@ type DataConfig =
[<JsonIgnore>]
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<DataConfig> json
config
|> ensureHostname
|> ensurePort
|> ensureAuthKey
|> ensureTimeout
|> ensureDatabase
|> connect

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

@ -5,34 +5,38 @@ open Newtonsoft.Json
// ---- Constants ----
/// Constants to use for revision source language
[<RequireQualifiedAccess>]
module RevisionSource =
[<Literal>]
let Markdown = "markdown"
[<Literal>]
let HTML = "html"
let HTML = "html"
/// Constants to use for authorization levels
[<RequireQualifiedAccess>]
module AuthorizationLevel =
[<Literal>]
let Administrator = "Administrator"
[<Literal>]
let User = "User"
let User = "User"
/// Constants to use for post statuses
[<RequireQualifiedAccess>]
module PostStatus =
[<Literal>]
let Draft = "Draft"
let Draft = "Draft"
[<Literal>]
let Published = "Published"
/// Constants to use for comment statuses
[<RequireQualifiedAccess>]
module CommentStatus =
[<Literal>]
let Approved = "Approved"
[<Literal>]
let Pending = "Pending"
let Pending = "Pending"
[<Literal>]
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
[<JsonIgnore>]
@ -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 = [] }

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

@ -21,9 +21,7 @@ let tryFindPage conn webLogId pageId =
.RunAtomAsync<Page>(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 =

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

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

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.")
/// Ensure the myWebLog database exists
let checkDatabase (cfg : DataConfig) =
let private checkDatabase (cfg : DataConfig) =
logStep "|> Checking database"
let dbs = r.DbList().RunListAsync<string>(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<string>(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<string>(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<string>(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"

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
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>
/// Looks up a localized string similar to Invalid e-mail address or password.
/// </summary>

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

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

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

@ -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\.(?<TranslationKey>[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<DataConfig>(cfg)
container.Register<AppConfig>(cfg)
|> ignore
container.Register<IConnection>(cfg.Conn)
container.Register<IConnection>(cfg.DataConfig.Conn)
|> ignore
// NodaTime
container.Register<IClock>(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<IUserMapper>())
CryptographyConfiguration =
CryptographyConfiguration(
RijndaelEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)),
DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))),
RedirectUrl = "~/user/logon",
UserMapper = container.Resolve<IUserMapper>())
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

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
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<CategoryForm> ()
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 ()

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

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 ()
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<EditPageForm> ()
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 ()

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

@ -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<EditPostForm>()
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 ()

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

@ -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 () =

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

@ -11,6 +11,7 @@ open System
/// Levels for a user message
[<RequireQualifiedAccess>]
module Level =
/// An informational message
let Info = "Info"
@ -59,7 +60,7 @@ with
match this.Details with
| Some d -> yield "<br />"
yield d
| None -> ()
| None -> ()
yield "</div>"
}
|> 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<Post>.None with get, set
member val NewerPost : Post option = None with get, set
/// 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
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<string>.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)

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

@ -52,6 +52,7 @@
<ItemGroup>
<Compile Include="AssemblyInfo.fs" />
<Compile Include="Keys.fs" />
<Compile Include="AppConfig.fs" />
<Compile Include="ViewModels.fs" />
<Compile Include="ModuleExtensions.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>
<None Include="App.config" />
<Content Include="data-config.json">
<Content Include="config.json">
<CopyToOutputDirectory>Always</CopyToOutputDirectory>
</Content>
<Content Include="views\themes\default\content\bootstrap-theme.css.map">