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

Log on works now

Browse Source 
...but wait, there's more!
- Admin area dashboard works, list pages work
- Minor admin area style tweaks
This commit is contained in:
Daniel J. Summers 2016-11-10 22:17:46 -06:00
parent 1873f9d6fc
commit ed9b8adc1c
17 changed files with 378 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/MyWebLog.App/AdminModule.fs
View File

@ -8,15 +8,15 @@ open Nancy
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
/// Handle /admin routes /// Handle /admin routes
type AdminModule(data : IMyWebLogData) as this = type AdminModule (data : IMyWebLogData) as this =
inherit NancyModule("/admin") inherit NancyModule ("/admin")
do do
this.Get("/", fun _ -> this.Dashboard ()) this.Get ("/", fun _ -> this.Dashboard ())
/// Admin dashboard /// Admin dashboard
member this.Dashboard () : obj = member this.Dashboard () : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = DashboardModel(this.Context, this.WebLog, findDashboardCounts data this.WebLog.Id) let model = DashboardModel (this.Context, this.WebLog, findDashboardCounts data this.WebLog.Id)
model.PageTitle <- Strings.get "Dashboard" model.PageTitle <- Strings.get "Dashboard"
upcast this.View.["admin/dashboard", model] upcast this.View.["admin/dashboard", model]

77
src/MyWebLog.App/App.fs
View File

@ -33,11 +33,11 @@ open System.Text.RegularExpressions
let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json") let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json")
with ex -> raise <| Exception (Strings.get "ErrBadAppConfig", ex) with ex -> raise <| Exception (Strings.get "ErrBadAppConfig", ex)
let data = lazy (RethinkMyWebLogData(cfg.DataConfig.Conn, cfg.DataConfig) :> IMyWebLogData) let data = lazy (RethinkMyWebLogData (cfg.DataConfig.Conn, cfg.DataConfig) :> IMyWebLogData)
/// 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) =
let translate (m : Match) = Strings.get m.Groups.["TranslationKey"].Value let translate (m : Match) = Strings.get m.Groups.["TranslationKey"].Value
@ -45,17 +45,24 @@ type TranslateTokenViewEngineMatcher() =
/// Handle forms authentication /// Handle forms authentication
type MyWebLogUser(name, claims) = type MyWebLogUser (claims : Claim seq) =
inherit ClaimsPrincipal() inherit ClaimsPrincipal (ClaimsIdentity (claims, "forms"))
member this.UserName with get() = name
member this.Claims with get() = claims new (user : User) =
// TODO: refactor the User.Claims property to produce this, and just pass it as the constructor
let claims =
seq {
yield Claim (ClaimTypes.Name, user.PreferredName)
for claim in user.Claims -> Claim (ClaimTypes.Role, claim)
}
MyWebLogUser claims
type MyWebLogUserMapper(container : TinyIoCContainer) = type MyWebLogUserMapper (container : TinyIoCContainer) =
interface IUserMapper with interface IUserMapper with
member this.GetUserFromIdentifier (identifier, context) = member this.GetUserFromIdentifier (identifier, context) =
match context.Request.PersistableSession.GetOrDefault(Keys.User, User.Empty) with match context.Request.PersistableSession.GetOrDefault (Keys.User, User.Empty) with
| user when user.Id = string identifier -> upcast MyWebLogUser(user.PreferredName, user.Claims) | user when user.Id = string identifier -> upcast MyWebLogUser user
| _ -> null | _ -> null
@ -71,49 +78,47 @@ 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 addContentDir |> Seq.map (fun themeDir -> themeDir, Path.Combine [| themeDir; "content" |])
|> Seq.filter (fun (_, contentDir) -> Directory.Exists contentDir)
|> Seq.iter (fun (themeDir, contentDir) ->
conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory ((Path.GetFileName themeDir), contentDir)))
override this.ConfigureApplicationContainer (container) = override this.ConfigureApplicationContainer (container) =
base.ConfigureApplicationContainer container base.ConfigureApplicationContainer container
container.Register<AppConfig>(cfg) container.Register<AppConfig> cfg
|> ignore |> ignore
data.Force().SetUp () data.Force().SetUp ()
container.Register<IMyWebLogData>(data.Force ()) container.Register<IMyWebLogData> (data.Force ())
|> ignore |> ignore
// NodaTime // NodaTime
container.Register<IClock>(SystemClock.Instance) container.Register<IClock> SystemClock.Instance
|> ignore |> ignore
// I18N in SSVE // I18N in SSVE
container.Register<seq<ISuperSimpleViewEngineMatcher>>(fun _ _ -> container.Register<ISuperSimpleViewEngineMatcher seq> (fun _ _ ->
Seq.singleton (TranslateTokenViewEngineMatcher() :> ISuperSimpleViewEngineMatcher)) Seq.singleton (TranslateTokenViewEngineMatcher () :> ISuperSimpleViewEngineMatcher))
|> ignore |> ignore
override this.ApplicationStartup (container, pipelines) = override this.ApplicationStartup (container, pipelines) =
base.ApplicationStartup (container, pipelines) base.ApplicationStartup (container, pipelines)
// Forms authentication configuration // Forms authentication configuration
let auth = let auth =
FormsAuthenticationConfiguration( FormsAuthenticationConfiguration (
CryptographyConfiguration = CryptographyConfiguration =
CryptographyConfiguration( CryptographyConfiguration (
AesEncryptionProvider(PassphraseKeyGenerator(cfg.AuthEncryptionPassphrase, cfg.AuthSalt)), AesEncryptionProvider (PassphraseKeyGenerator (cfg.AuthEncryptionPassphrase, cfg.AuthSalt)),
DefaultHmacProvider(PassphraseKeyGenerator(cfg.AuthHmacPassphrase, cfg.AuthSalt))), DefaultHmacProvider (PassphraseKeyGenerator (cfg.AuthHmacPassphrase, cfg.AuthSalt))),
RedirectUrl = "~/user/logon", RedirectUrl = "~/user/logon",
UserMapper = container.Resolve<IUserMapper>()) 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.DataConfig.Conn) let sessions = RethinkDBSessionConfiguration cfg.DataConfig.Conn
sessions.Database <- cfg.DataConfig.Database sessions.Database <- cfg.DataConfig.Database
//let sessions = RelationalSessionConfiguration(ConfigurationManager.ConnectionStrings.["SessionStore"].ConnectionString) //let sessions = RelationalSessionConfiguration(ConfigurationManager.ConnectionStrings.["SessionStore"].ConnectionString)
PersistableSessions.Enable (pipelines, sessions) PersistableSessions.Enable (pipelines, sessions)
@ -121,7 +126,7 @@ type MyWebLogBootstrapper() =
override this.Configure (environment) = override this.Configure (environment) =
base.Configure environment base.Configure environment
environment.Tracing(true, true) environment.Tracing (true, true)
let version = let version =
@ -149,16 +154,16 @@ type RequestEnvironment() =
type Startup() = type Startup() =
member this.Configure (app : IApplicationBuilder) = member this.Configure (app : IApplicationBuilder) =
let opt = NancyOptions() let opt = NancyOptions ()
opt.Bootstrapper <- new MyWebLogBootstrapper() opt.Bootstrapper <- new MyWebLogBootstrapper ()
app.UseOwin(fun x -> x.UseNancy(opt) |> ignore) |> ignore app.UseOwin (fun x -> x.UseNancy opt |> ignore) |> ignore
let Run () = let Run () =
use host = use host =
WebHostBuilder() WebHostBuilder()
.UseContentRoot(System.IO.Directory.GetCurrentDirectory()) .UseContentRoot(System.IO.Directory.GetCurrentDirectory ())
.UseKestrel() .UseKestrel()
.UseStartup<Startup>() .UseStartup<Startup>()
.Build() .Build ()
host.Run() host.Run ()

107
src/MyWebLog.App/CategoryModule.fs
View File

@ -10,68 +10,71 @@ open Nancy.Security
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
/// Handle /category and /categories URLs /// Handle /category and /categories URLs
type CategoryModule(data : IMyWebLogData) as this = type CategoryModule (data : IMyWebLogData) as this =
inherit NancyModule() inherit NancyModule ()
do do
this.Get ("/categories", fun _ -> this.CategoryList ()) this.Get ("/categories", fun _ -> this.CategoryList ())
this.Get ("/category/{id}/edit", fun parms -> this.EditCategory (downcast parms)) this.Get ("/category/{id}/edit", fun parms -> this.EditCategory (downcast parms))
this.Post ("/category/{id}/edit", fun parms -> this.SaveCategory (downcast parms)) this.Post ("/category/{id}/edit", fun parms -> this.SaveCategory (downcast parms))
this.Delete("/category/{id}/delete", fun parms -> this.DeleteCategory (downcast parms)) this.Delete ("/category/{id}/delete", fun parms -> this.DeleteCategory (downcast parms))
/// Display a list of categories /// Display a list of categories
member this.CategoryList () : obj = member this.CategoryList () : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = CategoryListModel(this.Context, this.WebLog, let model =
(findAllCategories data this.WebLog.Id CategoryListModel (
|> List.map (fun cat -> IndentedCategory.Create cat (fun _ -> false)))) this.Context, this.WebLog, findAllCategories data this.WebLog.Id
upcast this.View.["/admin/category/list", model] |> List.map (fun cat -> IndentedCategory.Create cat (fun _ -> false)))
upcast this.View.["admin/category/list", model]
/// Edit a category /// Edit a category
member this.EditCategory (parameters : DynamicDictionary) : obj = member this.EditCategory (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString () let catId = parameters.["id"].ToString ()
match (match catId with match catId with "new" -> Some Category.Empty | _ -> tryFindCategory data this.WebLog.Id catId
| "new" -> Some Category.Empty |> function
| _ -> tryFindCategory data this.WebLog.Id catId) with | Some cat ->
| Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat) let model = CategoryEditModel(this.Context, this.WebLog, cat)
model.Categories <- findAllCategories data this.WebLog.Id model.Categories <- findAllCategories data 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]
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Save a category /// Save a category
member this.SaveCategory (parameters : DynamicDictionary) : obj = member this.SaveCategory (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken () this.ValidateCsrfToken ()
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 match catId with
| "new" -> Some { Category.Empty with WebLogId = this.WebLog.Id } | "new" -> Some { Category.Empty with WebLogId = this.WebLog.Id }
| _ -> tryFindCategory data this.WebLog.Id catId | _ -> tryFindCategory data this.WebLog.Id catId
match oldCat with |> function
| Some old -> let cat = { old with Name = form.Name | Some old ->
Slug = form.Slug let cat = { old with Name = form.Name
Description = match form.Description with "" -> None | d -> Some d Slug = form.Slug
ParentId = match form.ParentId with "" -> None | p -> Some p } Description = match form.Description with "" -> None | d -> Some d
let newCatId = saveCategory data cat ParentId = match form.ParentId with "" -> None | p -> Some p }
match old.ParentId = cat.ParentId with let newCatId = saveCategory data cat
| true -> () match old.ParentId = cat.ParentId with
| _ -> match old.ParentId with | true -> ()
| Some parentId -> removeCategoryFromParent data this.WebLog.Id parentId newCatId | _ ->
| _ -> () match old.ParentId with
match cat.ParentId with | Some parentId -> removeCategoryFromParent data this.WebLog.Id parentId newCatId
| Some parentId -> addCategoryToParent data this.WebLog.Id parentId newCatId | _ -> ()
| _ -> () match cat.ParentId with
let model = MyWebLogModel(this.Context, this.WebLog) | Some parentId -> addCategoryToParent data this.WebLog.Id parentId newCatId
{ UserMessage.Empty with | _ -> ()
Level = Level.Info let model = MyWebLogModel (this.Context, this.WebLog)
Message = System.String.Format { UserMessage.Empty with
(Strings.get "MsgCategoryEditSuccess", Level = Level.Info
Strings.get (match catId with "new" -> "Added" | _ -> "Updated")) } Message = System.String.Format
|> model.AddMessage (Strings.get "MsgCategoryEditSuccess",
this.Redirect (sprintf "/category/%s/edit" newCatId) model Strings.get (match catId with "new" -> "Added" | _ -> "Updated")) }
|> model.AddMessage
this.Redirect (sprintf "/category/%s/edit" newCatId) model
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Delete a category /// Delete a category
@ -80,10 +83,12 @@ type CategoryModule(data : IMyWebLogData) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString () let catId = parameters.["id"].ToString ()
match tryFindCategory data this.WebLog.Id catId with match tryFindCategory data this.WebLog.Id catId with
| Some cat -> deleteCategory data cat | Some cat ->
let model = MyWebLogModel(this.Context, this.WebLog) deleteCategory data cat
{ UserMessage.Empty with Level = Level.Info let model = MyWebLogModel(this.Context, this.WebLog)
Message = System.String.Format(Strings.get "MsgCategoryDeleted", cat.Name) } { UserMessage.Empty with
|> model.AddMessage Level = Level.Info
this.Redirect "/categories" model Message = System.String.Format(Strings.get "MsgCategoryDeleted", cat.Name) }
|> model.AddMessage
this.Redirect "/categories" model
| _ -> this.NotFound () | _ -> this.NotFound ()

8
src/MyWebLog.App/ModuleExtensions.fs
View File

@ -25,10 +25,12 @@ type NancyModule with
match List.length model.Messages with match List.length model.Messages with
| 0 -> () | 0 -> ()
| _ -> this.Session.[Keys.Messages] <- model.Messages | _ -> this.Session.[Keys.Messages] <- model.Messages
upcast this.Response.AsRedirect(url).WithStatusCode HttpStatusCode.TemporaryRedirect // Temp (307) redirects don't reset the HTTP method; this allows POST-process-REDIRECT workflow
upcast this.Response.AsRedirect(url).WithStatusCode HttpStatusCode.MovedPermanently
/// Require a specific level of access for the current web log /// Require a specific level of access for the current web log
member this.RequiresAccessLevel level = member this.RequiresAccessLevel level =
let findClaim = new Predicate<Claim>(fun claim -> claim.Type = ClaimTypes.Role && claim.Value = sprintf "%s|%s" this.WebLog.Id level) let findClaim = Predicate<Claim> (fun claim ->
this.RequiresAuthentication() claim.Type = ClaimTypes.Role && claim.Value = sprintf "%s|%s" this.WebLog.Id level)
this.RequiresAuthentication ()
this.RequiresClaims [| findClaim |] this.RequiresClaims [| findClaim |]

98
src/MyWebLog.App/PageModule.fs
View File

@ -11,20 +11,21 @@ open NodaTime
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
/// Handle /pages and /page URLs /// Handle /pages and /page URLs
type PageModule(data : IMyWebLogData, clock : IClock) as this = type PageModule (data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule() inherit NancyModule ()
do do
this.Get ("/pages", fun _ -> this.PageList ()) this.Get ("/pages", fun _ -> this.PageList ())
this.Get ("/page/{id}/edit", fun parms -> this.EditPage (downcast parms)) this.Get ("/page/{id}/edit", fun parms -> this.EditPage (downcast parms))
this.Post ("/page/{id}/edit", fun parms -> this.SavePage (downcast parms)) this.Post ("/page/{id}/edit", fun parms -> this.SavePage (downcast parms))
this.Delete("/page/{id}/delete", fun parms -> this.DeletePage (downcast parms)) this.Delete ("/page/{id}/delete", fun parms -> this.DeletePage (downcast parms))
/// List all pages /// List all pages
member this.PageList () : obj = member this.PageList () : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PagesModel(this.Context, this.WebLog, (findAllPages data this.WebLog.Id let model =
|> List.map (fun p -> PageForDisplay(this.WebLog, p)))) PagesModel(this.Context, this.WebLog, findAllPages data this.WebLog.Id
|> List.map (fun p -> PageForDisplay (this.WebLog, p)))
model.PageTitle <- Strings.get "Pages" model.PageTitle <- Strings.get "Pages"
upcast this.View.["admin/page/list", model] upcast this.View.["admin/page/list", model]
@ -34,15 +35,16 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
let pageId = parameters.["id"].ToString () let pageId = parameters.["id"].ToString ()
match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId
|> function |> function
| Some page -> let rev = match page.Revisions | Some page ->
|> List.sortByDescending (fun r -> r.AsOf) let rev = match page.Revisions
|> List.tryHead with |> List.sortByDescending (fun r -> r.AsOf)
| Some r -> r |> List.tryHead with
| _ -> Revision.Empty | Some r -> r
let model = EditPageModel(this.Context, this.WebLog, page, rev) | _ -> Revision.Empty
model.PageTitle <- Strings.get <| match pageId with "new" -> "AddNewPage" | _ -> "EditPage" let model = EditPageModel (this.Context, this.WebLog, page, rev)
upcast this.View.["admin/page/edit", model] model.PageTitle <- Strings.get <| match pageId with "new" -> "AddNewPage" | _ -> "EditPage"
| _ -> this.NotFound () upcast this.View.["admin/page/edit", model]
| _ -> this.NotFound ()
/// Save a page /// Save a page
member this.SavePage (parameters : DynamicDictionary) : obj = member this.SavePage (parameters : DynamicDictionary) : obj =
@ -50,29 +52,31 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString () let pageId = parameters.["id"].ToString ()
let form = this.Bind<EditPageForm> () let form = this.Bind<EditPageForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks() let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
match (match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId) with match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId
| Some p -> let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p |> function
let pId = { p with | Some p ->
Title = form.Title let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p
Permalink = form.Permalink let pId = { p with
PublishedOn = match pageId with "new" -> now | _ -> page.PublishedOn Title = form.Title
UpdatedOn = now Permalink = form.Permalink
Text = match form.Source with PublishedOn = match pageId with "new" -> now | _ -> page.PublishedOn
| RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text UpdatedOn = now
| _ -> form.Text Text = match form.Source with
Revisions = { AsOf = now | RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text
SourceType = form.Source | _ -> form.Text
Text = form.Text } :: page.Revisions } Revisions = { AsOf = now
|> savePage data SourceType = form.Source
let model = MyWebLogModel(this.Context, this.WebLog) Text = form.Text } :: page.Revisions }
{ UserMessage.Empty with |> savePage data
Level = Level.Info let model = MyWebLogModel (this.Context, this.WebLog)
Message = System.String.Format { UserMessage.Empty with
(Strings.get "MsgPageEditSuccess", Level = Level.Info
Strings.get (match pageId with "new" -> "Added" | _ -> "Updated")) } Message = System.String.Format
|> model.AddMessage (Strings.get "MsgPageEditSuccess",
this.Redirect (sprintf "/page/%s/edit" pId) model Strings.get (match pageId with "new" -> "Added" | _ -> "Updated")) }
|> model.AddMessage
this.Redirect (sprintf "/page/%s/edit" pId) model
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Delete a page /// Delete a page
@ -81,10 +85,12 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString () let pageId = parameters.["id"].ToString ()
match tryFindPageWithoutRevisions data this.WebLog.Id pageId with match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page -> deletePage data page.WebLogId page.Id | Some page ->
let model = MyWebLogModel(this.Context, this.WebLog) deletePage data page.WebLogId page.Id
{ UserMessage.Empty with Level = Level.Info let model = MyWebLogModel (this.Context, this.WebLog)
Message = Strings.get "MsgPageDeleted" } { UserMessage.Empty with
|> model.AddMessage Level = Level.Info
this.Redirect "/pages" model Message = Strings.get "MsgPageDeleted" }
|> model.AddMessage
this.Redirect "/pages" model
| _ -> this.NotFound () | _ -> this.NotFound ()

238
src/MyWebLog.App/PostModule.fs
View File

@ -24,20 +24,20 @@ type NewsItem =
/// Routes dealing with posts (including the home page, /tag, /category, RSS, and catch-all routes) /// Routes dealing with posts (including the home page, /tag, /category, RSS, and catch-all routes)
type PostModule(data : IMyWebLogData, clock : IClock) as this = type PostModule(data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule() inherit NancyModule ()
/// Get the page number from the dictionary /// Get the page number from the dictionary
let getPage (parameters : DynamicDictionary) = let getPage (parameters : DynamicDictionary) =
match parameters.ContainsKey "page" with true -> System.Int32.Parse (parameters.["page"].ToString ()) | _ -> 1 match parameters.ContainsKey "page" with true -> System.Int32.Parse (parameters.["page"].ToString ()) | _ -> 1
/// Convert a list of posts to a list of posts for display /// Convert a list of posts to a list of posts for display
let forDisplay posts = posts |> List.map (fun post -> PostForDisplay(this.WebLog, post)) let forDisplay posts = posts |> List.map (fun post -> PostForDisplay (this.WebLog, post))
/// Generate an RSS/Atom feed of the latest posts /// Generate an RSS/Atom feed of the latest posts
let generateFeed format : obj = let generateFeed format : obj =
let myChannelFeed channelTitle channelLink channelDescription (items : NewsItem list) = let myChannelFeed channelTitle channelLink channelDescription (items : NewsItem list) =
let xn = XName.Get let xn = XName.Get
let elem name (valu:string) = XElement(xn name, valu) let elem name (valu:string) = XElement (xn name, valu)
let elems = let elems =
items items
|> List.sortBy (fun i -> i.ReleaseDate) |> List.sortBy (fun i -> i.ReleaseDate)
@ -54,12 +54,12 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
XDeclaration("1.0", "utf-8", "yes"), XDeclaration("1.0", "utf-8", "yes"),
XElement XElement
(xn "rss", (xn "rss",
XAttribute(xn "version", "2.0"), XAttribute (xn "version", "2.0"),
elem "title" channelTitle, elem "title" channelTitle,
elem "link" channelLink, elem "link" channelLink,
elem "description" (defaultArg channelDescription ""), elem "description" (defaultArg channelDescription ""),
elem "language" "en-us", elem "language" "en-us",
XElement(xn "channel", elems)) XElement (xn "channel", elems))
|> box) |> box)
|> box |> box
let schemeAndUrl = sprintf "%s://%s" this.Request.Url.Scheme this.WebLog.UrlBase let schemeAndUrl = sprintf "%s://%s" this.Request.Url.Scheme this.WebLog.UrlBase
@ -103,24 +103,24 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
upcast this.Response.FromStream(stream, sprintf "application/%s+xml" format) *) upcast this.Response.FromStream(stream, sprintf "application/%s+xml" format) *)
do do
this.Get ("/", fun _ -> this.HomePage ()) this.Get ("/", fun _ -> this.HomePage ())
this.Get ("/{permalink*}", fun parms -> this.CatchAll (downcast parms)) this.Get ("/{permalink*}", fun parms -> this.CatchAll (downcast parms))
this.Get ("/posts/page/{page:int}", fun parms -> this.PublishedPostsPage (getPage <| downcast parms)) this.Get ("/posts/page/{page:int}", fun parms -> this.PublishedPostsPage (getPage <| downcast parms))
this.Get ("/category/{slug}", fun parms -> this.CategorizedPosts (downcast parms)) this.Get ("/category/{slug}", fun parms -> this.CategorizedPosts (downcast parms))
this.Get ("/category/{slug}/page/{page:int}", fun parms -> this.CategorizedPosts (downcast parms)) this.Get ("/category/{slug}/page/{page:int}", fun parms -> this.CategorizedPosts (downcast parms))
this.Get ("/tag/{tag}", fun parms -> this.TaggedPosts (downcast parms)) this.Get ("/tag/{tag}", fun parms -> this.TaggedPosts (downcast parms))
this.Get ("/tag/{tag}/page/{page:int}", fun parms -> this.TaggedPosts (downcast parms)) this.Get ("/tag/{tag}/page/{page:int}", fun parms -> this.TaggedPosts (downcast parms))
this.Get ("/feed", fun _ -> this.Feed ()) this.Get ("/feed", fun _ -> this.Feed ())
this.Get ("/posts/list", fun _ -> this.PostList 1) this.Get ("/posts/list", fun _ -> this.PostList 1)
this.Get ("/posts/list/page/{page:int}", fun parms -> this.PostList (getPage <| downcast parms)) this.Get ("/posts/list/page/{page:int}", fun parms -> this.PostList (getPage <| downcast parms))
this.Get ("/post/{postId}/edit", fun parms -> this.EditPost (downcast parms)) this.Get ("/post/{postId}/edit", fun parms -> this.EditPost (downcast parms))
this.Post("/post/{postId}/edit", fun parms -> this.SavePost (downcast parms)) this.Post ("/post/{postId}/edit", fun parms -> this.SavePost (downcast parms))
// ---- Display posts to users ---- // ---- Display posts to users ----
/// Display a page of published posts /// Display a page of published posts
member this.PublishedPostsPage pageNbr : obj = member this.PublishedPostsPage pageNbr : obj =
let model = PostsModel(this.Context, this.WebLog) let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr model.PageNbr <- pageNbr
model.Posts <- findPageOfPublishedPosts data this.WebLog.Id pageNbr 10 |> forDisplay model.Posts <- findPageOfPublishedPosts data this.WebLog.Id pageNbr 10 |> forDisplay
model.HasNewer <- match pageNbr with model.HasNewer <- match pageNbr with
@ -139,65 +139,68 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.HomePage () : obj = member this.HomePage () : obj =
match this.WebLog.DefaultPage with match this.WebLog.DefaultPage with
| "posts" -> this.PublishedPostsPage 1 | "posts" -> this.PublishedPostsPage 1
| pageId -> match tryFindPageWithoutRevisions data this.WebLog.Id pageId with | pageId ->
| Some page -> let model = PageModel(this.Context, this.WebLog, page) match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
model.PageTitle <- page.Title | Some page ->
this.ThemedView "page" model let model = PageModel(this.Context, this.WebLog, page)
| _ -> this.NotFound () model.PageTitle <- page.Title
this.ThemedView "page" model
| _ -> 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) : obj = member this.CatchAll (parameters : DynamicDictionary) : obj =
let url = parameters.["permalink"].ToString () let url = parameters.["permalink"].ToString ()
match tryFindPostByPermalink data this.WebLog.Id url with match tryFindPostByPermalink data this.WebLog.Id url with
| Some post -> // Hopefully the most common result; the permalink is a permalink! | Some post -> // Hopefully the most common result; the permalink is a permalink!
let model = PostModel(this.Context, this.WebLog, post) let model = PostModel(this.Context, this.WebLog, post)
model.NewerPost <- tryFindNewerPost data post model.NewerPost <- tryFindNewerPost data post
model.OlderPost <- tryFindOlderPost data post model.OlderPost <- tryFindOlderPost data post
model.PageTitle <- post.Title model.PageTitle <- post.Title
this.ThemedView "single" model this.ThemedView "single" model
| _ -> // Maybe it's a page permalink instead... | _ -> // Maybe it's a page permalink instead...
match tryFindPageByPermalink data this.WebLog.Id url with match tryFindPageByPermalink data 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
| _ -> // Maybe it's an old permalink for a post | _ -> // Maybe it's an old permalink for a post
match tryFindPostByPriorPermalink data this.WebLog.Id url with match tryFindPostByPriorPermalink data 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
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Display categorized posts /// Display categorized posts
member this.CategorizedPosts (parameters : DynamicDictionary) : obj = member this.CategorizedPosts (parameters : DynamicDictionary) : obj =
let slug = parameters.["slug"].ToString () let slug = parameters.["slug"].ToString ()
match tryFindCategoryBySlug data this.WebLog.Id slug with match tryFindCategoryBySlug data this.WebLog.Id slug with
| Some cat -> let pageNbr = getPage parameters | Some cat ->
let model = PostsModel(this.Context, this.WebLog) let pageNbr = getPage parameters
model.PageNbr <- pageNbr let model = PostsModel (this.Context, this.WebLog)
model.Posts <- findPageOfCategorizedPosts data this.WebLog.Id cat.Id pageNbr 10 |> forDisplay model.PageNbr <- pageNbr
model.HasNewer <- match List.isEmpty model.Posts with model.Posts <- findPageOfCategorizedPosts data this.WebLog.Id cat.Id pageNbr 10 |> forDisplay
| true -> false model.HasNewer <- match List.isEmpty model.Posts with
| _ -> Option.isSome <| tryFindNewerCategorizedPost data cat.Id | true -> false
(List.head model.Posts).Post | _ -> Option.isSome <| tryFindNewerCategorizedPost data cat.Id
model.HasOlder <- match List.isEmpty model.Posts with (List.head model.Posts).Post
| true -> false model.HasOlder <- match List.isEmpty model.Posts with
| _ -> Option.isSome <| tryFindOlderCategorizedPost data cat.Id | true -> false
(List.last model.Posts).Post | _ -> Option.isSome <| tryFindOlderCategorizedPost data cat.Id
model.UrlPrefix <- sprintf "/category/%s" slug (List.last model.Posts).Post
model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name model.UrlPrefix <- sprintf "/category/%s" slug
(match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n) model.PageTitle <- sprintf "\"%s\" Category%s" cat.Name
model.Subtitle <- Some <| match cat.Description with (match pageNbr with | 1 -> "" | n -> sprintf " | Page %i" n)
| Some desc -> desc model.Subtitle <- Some <| match cat.Description with
| _ -> sprintf "Posts in the \"%s\" category" cat.Name | Some desc -> desc
this.ThemedView "index" model | _ -> sprintf "Posts in the \"%s\" category" cat.Name
this.ThemedView "index" model
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Display tagged posts /// Display tagged posts
member this.TaggedPosts (parameters : DynamicDictionary) : obj = member this.TaggedPosts (parameters : DynamicDictionary) : obj =
let tag = parameters.["tag"].ToString () let tag = parameters.["tag"].ToString ()
let pageNbr = getPage parameters let pageNbr = getPage parameters
let model = PostsModel(this.Context, this.WebLog) let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr model.PageNbr <- pageNbr
model.Posts <- findPageOfTaggedPosts data this.WebLog.Id tag pageNbr 10 |> forDisplay model.Posts <- findPageOfTaggedPosts data this.WebLog.Id tag pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with model.HasNewer <- match List.isEmpty model.Posts with
@ -215,10 +218,11 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.Feed () : obj = member this.Feed () : obj =
let query = this.Request.Query :?> DynamicDictionary let query = this.Request.Query :?> DynamicDictionary
match query.ContainsKey "format" with match query.ContainsKey "format" with
| true -> match query.["format"].ToString () with | true ->
| x when x = "atom" || x = "rss" -> generateFeed x match query.["format"].ToString () with
| x when x = "rss2" -> generateFeed "rss" | x when x = "atom" || x = "rss" -> generateFeed x
| _ -> this.Redirect "/feed" (MyWebLogModel(this.Context, this.WebLog)) | x when x = "rss2" -> generateFeed "rss"
| _ -> this.Redirect "/feed" (MyWebLogModel (this.Context, this.WebLog))
| _ -> generateFeed "rss" | _ -> generateFeed "rss"
// ---- Administer posts ---- // ---- Administer posts ----
@ -226,7 +230,7 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
/// Display a page of posts in the admin area /// Display a page of posts in the admin area
member this.PostList pageNbr : obj = member this.PostList pageNbr : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PostsModel(this.Context, this.WebLog) let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr model.PageNbr <- pageNbr
model.Posts <- findPageOfAllPosts data this.WebLog.Id pageNbr 25 |> forDisplay model.Posts <- findPageOfAllPosts data this.WebLog.Id pageNbr 25 |> forDisplay
model.HasNewer <- pageNbr > 1 model.HasNewer <- pageNbr > 1
@ -239,20 +243,21 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.EditPost (parameters : DynamicDictionary) : obj = member this.EditPost (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
let postId = parameters.["postId"].ToString () let postId = parameters.["postId"].ToString ()
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId
| Some post -> let rev = match post.Revisions |> function
|> List.sortByDescending (fun r -> r.AsOf) | Some post ->
|> List.tryHead with let rev = match post.Revisions
| Some r -> r |> List.sortByDescending (fun r -> r.AsOf)
| None -> Revision.Empty |> List.tryHead with
let model = EditPostModel(this.Context, this.WebLog, post, rev) | Some r -> r
model.Categories <- findAllCategories data this.WebLog.Id | None -> Revision.Empty
|> List.map (fun cat -> string (fst cat).Id, let model = EditPostModel (this.Context, this.WebLog, post, rev)
sprintf "%s%s" model.Categories <- findAllCategories data this.WebLog.Id
(String.replicate (snd cat) " &nbsp; &nbsp; ") |> List.map (fun cat -> string (fst cat).Id,
(fst cat).Name) sprintf "%s%s" (String.replicate (snd cat) " &nbsp; &nbsp; ")
model.PageTitle <- Strings.get <| match post.Id with "new" -> "AddNewPost" | _ -> "EditPost" (fst cat).Name)
upcast this.View.["admin/post/edit"] model.PageTitle <- Strings.get <| match post.Id with "new" -> "AddNewPost" | _ -> "EditPost"
upcast this.View.["admin/post/edit"]
| _ -> this.NotFound () | _ -> this.NotFound ()
/// Save a post /// Save a post
@ -260,42 +265,43 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator this.RequiresAccessLevel AuthorizationLevel.Administrator
this.ValidateCsrfToken () this.ValidateCsrfToken ()
let postId = parameters.["postId"].ToString () let postId = parameters.["postId"].ToString ()
let form = this.Bind<EditPostForm>() let form = this.Bind<EditPostForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks() let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId
| Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow |> function
let post = match postId with | Some p ->
| "new" -> { p with let justPublished = p.PublishedOn = int64 0 && form.PublishNow
WebLogId = this.WebLog.Id let post = match postId with
AuthorId = (this.Request.PersistableSession.GetOrDefault<User> | "new" -> { p with
(Keys.User, User.Empty)).Id } WebLogId = this.WebLog.Id
| _ -> p AuthorId = (this.Request.PersistableSession.GetOrDefault<User>
let pId = { post with (Keys.User, User.Empty)).Id }
Status = match form.PublishNow with | _ -> p
| true -> PostStatus.Published let pId =
| _ -> PostStatus.Draft { post with
Title = form.Title Status = match form.PublishNow with true -> PostStatus.Published | _ -> PostStatus.Draft
Permalink = form.Permalink Title = form.Title
PublishedOn = match justPublished with true -> now | _ -> int64 0 Permalink = form.Permalink
UpdatedOn = now PublishedOn = match justPublished with true -> now | _ -> int64 0
Text = match form.Source with UpdatedOn = now
| RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text Text = match form.Source with
| _ -> form.Text | RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text
CategoryIds = Array.toList form.Categories | _ -> form.Text
Tags = form.Tags.Split ',' CategoryIds = Array.toList form.Categories
|> Seq.map (fun t -> t.Trim().ToLowerInvariant()) Tags = form.Tags.Split ','
|> Seq.toList |> Seq.map (fun t -> t.Trim().ToLowerInvariant ())
Revisions = { AsOf = now |> Seq.toList
SourceType = form.Source Revisions = { AsOf = now
Text = form.Text } :: post.Revisions } SourceType = form.Source
|> savePost data Text = form.Text } :: post.Revisions }
let model = MyWebLogModel(this.Context, this.WebLog) |> savePost data
{ UserMessage.Empty with let model = MyWebLogModel(this.Context, this.WebLog)
Level = Level.Info { UserMessage.Empty with
Message = System.String.Format Level = Level.Info
(Strings.get "MsgPostEditSuccess", Message = System.String.Format
Strings.get (match postId with "new" -> "Added" | _ -> "Updated"), (Strings.get "MsgPostEditSuccess",
(match justPublished with true -> Strings.get "AndPublished" | _ -> "")) } Strings.get (match postId with "new" -> "Added" | _ -> "Updated"),
|> model.AddMessage (match justPublished with true -> Strings.get "AndPublished" | _ -> "")) }
this.Redirect (sprintf "/post/%s/edit" pId) model |> model.AddMessage
this.Redirect (sprintf "/post/%s/edit" pId) model
| _ -> this.NotFound () | _ -> this.NotFound ()

43
src/MyWebLog.App/UserModule.fs
View File

@ -14,8 +14,8 @@ open RethinkDb.Driver.Net
open System.Text open System.Text
/// Handle /user URLs /// Handle /user URLs
type UserModule(data : IMyWebLogData, cfg : AppConfig) as this = type UserModule (data : IMyWebLogData, 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) =
@ -23,13 +23,13 @@ type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
|> 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
this.Get ("/logon", fun _ -> this.ShowLogOn ()) this.Get ("/logon", fun _ -> this.ShowLogOn ())
this.Post("/logon", fun parms -> this.DoLogOn (downcast parms)) this.Post ("/logon", fun p -> this.DoLogOn (downcast p))
this.Get ("/logoff", fun _ -> this.LogOff ()) this.Get ("/logoff", fun _ -> this.LogOff ())
/// Show the log on page /// Show the log on page
member this.ShowLogOn () : obj = member this.ShowLogOn () : obj =
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 true -> query.["returnUrl"].ToString () | _ -> "" model.Form.ReturnUrl <- match query.ContainsKey "returnUrl" with true -> query.["returnUrl"].ToString () | _ -> ""
upcast this.View.["admin/user/logon", model] upcast this.View.["admin/user/logon", model]
@ -40,27 +40,26 @@ type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
let form = this.Bind<LogOnForm> () let form = this.Bind<LogOnForm> ()
let model = MyWebLogModel(this.Context, this.WebLog) let model = MyWebLogModel(this.Context, this.WebLog)
match tryUserLogOn data form.Email (pbkdf2 form.Password) with match tryUserLogOn data form.Email (pbkdf2 form.Password) with
| Some user -> this.Session.[Keys.User] <- user | Some user ->
{ UserMessage.Empty with Level = Level.Info this.Session.[Keys.User] <- user
Message = Strings.get "MsgLogOnSuccess" } model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgLogOnSuccess" }
|> model.AddMessage this.Redirect "" model |> ignore // Save the messages in the session before the Nancy redirect
this.Redirect "" model |> ignore // Save the messages in the session before the Nancy redirect // 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) "/") | _ ->
| _ -> { UserMessage.Empty with Level = Level.Error { UserMessage.Empty with
Message = Strings.get "ErrBadLogOnAttempt" } Level = Level.Error
|> model.AddMessage Message = Strings.get "ErrBadLogOnAttempt" }
this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model |> model.AddMessage
this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model
/// Log a user off /// Log a user off
member this.LogOff () : obj = member this.LogOff () : obj =
// FIXME: why are we getting the user here if we don't do anything with it? // FIXME: why are we getting the user here if we don't do anything with it?
let user = this.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty) let user = this.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty)
this.Session.DeleteAll () this.Session.DeleteAll ()
let model = MyWebLogModel(this.Context, this.WebLog) let model = MyWebLogModel (this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgLogOffSuccess" }
Message = Strings.get "MsgLogOffSuccess" }
|> model.AddMessage
this.Redirect "" model |> ignore this.Redirect "" model |> ignore
upcast this.LogoutAndRedirect "/" upcast this.LogoutAndRedirect "/"

71
src/MyWebLog.App/ViewModels.fs
View File

@ -86,15 +86,15 @@ module FormatDateTime =
/// Display the time /// Display the time
let time timeZone ticks = let time timeZone ticks =
(zonedTime timeZone ticks (zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("h':'mmtt", DateTimeZoneProviders.Tzdb).Format).ToLower() |> ZonedDateTimePattern.CreateWithCurrentCulture("h':'mmtt", DateTimeZoneProviders.Tzdb).Format).ToLower ()
/// Parent view model for all myWebLog views /// Parent view model for all myWebLog views
type MyWebLogModel(ctx : NancyContext, webLog : WebLog) = type MyWebLogModel (ctx : NancyContext, webLog : WebLog) =
/// Get the messages from the session /// Get the messages from the session
let getMessages () = let getMessages () =
let msg = ctx.Request.PersistableSession.GetOrDefault<UserMessage list>(Keys.Messages, []) let msg = ctx.Request.PersistableSession.GetOrDefault<UserMessage list> (Keys.Messages, [])
match List.length msg with match List.length msg with
| 0 -> () | 0 -> ()
| _ -> ctx.Request.Session.Delete Keys.Messages | _ -> ctx.Request.Session.Delete Keys.Messages
@ -107,7 +107,7 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
/// User messages /// User messages
member val Messages = getMessages () with get, set member val Messages = getMessages () with get, set
/// The currently logged in user /// The currently logged in user
member this.User = ctx.Request.PersistableSession.GetOrDefault<User>(Keys.User, User.Empty) member this.User = ctx.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty)
/// The title of the page /// The title of the page
member val PageTitle = "" with get, set member val PageTitle = "" with get, set
/// The name and version of the application /// The name and version of the application
@ -128,9 +128,10 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
/// The page title with the web log name appended /// The page title with the web log name appended
member this.DisplayPageTitle = member this.DisplayPageTitle =
match this.PageTitle with match this.PageTitle with
| "" -> match this.WebLog.Subtitle with | "" ->
| Some st -> sprintf "%s | %s" this.WebLog.Name st match this.WebLog.Subtitle with
| None -> this.WebLog.Name | Some st -> sprintf "%s | %s" this.WebLog.Name st
| 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
@ -151,8 +152,8 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
// ---- Admin models ---- // ---- Admin models ----
/// Admin Dashboard view model /// Admin Dashboard view model
type DashboardModel(ctx, webLog, counts : DashboardCounts) = type DashboardModel (ctx, webLog, counts : DashboardCounts) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The number of posts for the current web log /// The number of posts for the current web log
member val Posts = counts.Posts with get, set member val Posts = counts.Posts with get, set
/// The number of pages for the current web log /// The number of pages for the current web log
@ -190,15 +191,15 @@ with
/// Model for the list of categories /// Model for the list of categories
type CategoryListModel(ctx, webLog, categories) = type CategoryListModel (ctx, webLog, categories) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The categories /// The categories
member this.Categories : IndentedCategory list = categories member this.Categories : IndentedCategory list = categories
/// Form for editing a category /// Form for editing a category
type CategoryForm(category : Category) = type CategoryForm (category : Category) =
new() = CategoryForm(Category.Empty) new() = CategoryForm (Category.Empty)
/// The name of the category /// The name of the category
member val Name = category.Name with get, set member val Name = category.Name with get, set
/// The slug of the category (used in category URLs) /// The slug of the category (used in category URLs)
@ -209,10 +210,10 @@ type CategoryForm(category : Category) =
member val ParentId = defaultArg category.ParentId "" with get, set member val ParentId = defaultArg category.ParentId "" with get, set
/// Model for editing a category /// Model for editing a category
type CategoryEditModel(ctx, webLog, category) = type CategoryEditModel (ctx, webLog, category) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The form with the category information /// The form with the category information
member val Form = CategoryForm(category) with get, set member val Form = CategoryForm (category) with get, set
/// The categories /// The categories
member val Categories : IndentedCategory list = [] with get, set member val Categories : IndentedCategory list = [] with get, set
@ -220,14 +221,14 @@ type CategoryEditModel(ctx, webLog, category) =
// ---- Page models ---- // ---- Page models ----
/// Model for page display /// Model for page display
type PageModel(ctx, webLog, page) = type PageModel (ctx, webLog, page) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The page to be displayed /// The page to be displayed
member this.Page : Page = page member this.Page : Page = page
/// Wrapper for a page with additional properties /// Wrapper for a page with additional properties
type PageForDisplay(webLog, page) = type PageForDisplay (webLog, page) =
/// The page /// The page
member this.Page : Page = page member this.Page : Page = page
/// The time zone of the web log /// The time zone of the web log
@ -239,8 +240,8 @@ type PageForDisplay(webLog, page) =
/// Model for page list display /// Model for page list display
type PagesModel(ctx, webLog, pages) = type PagesModel (ctx, webLog, pages) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The pages /// The pages
member this.Pages : PageForDisplay list = pages member this.Pages : PageForDisplay list = pages
@ -273,8 +274,8 @@ type EditPageForm() =
/// Model for the edit page page /// Model for the edit page page
type EditPageModel(ctx, webLog, page, revision) = type EditPageModel (ctx, webLog, page, revision) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The page edit form /// The page edit form
member val Form = EditPageForm().ForPage(page).ForRevision(revision) member val Form = EditPageForm().ForPage(page).ForRevision(revision)
/// The page itself /// The page itself
@ -296,8 +297,8 @@ type EditPageModel(ctx, webLog, page, revision) =
// ---- Post models ---- // ---- Post models ----
/// Model for single post display /// Model for single post display
type PostModel(ctx, webLog, post) = type PostModel (ctx, webLog, post) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// 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
@ -321,7 +322,7 @@ type PostModel(ctx, webLog, post) =
/// Wrapper for a post with additional properties /// Wrapper for a post with additional properties
type PostForDisplay(webLog : WebLog, post : Post) = type PostForDisplay (webLog : WebLog, post : Post) =
/// Turn tags into a pipe-delimited string of tags /// Turn tags into a pipe-delimited string of tags
let pipedTags tags = tags |> List.reduce (fun acc x -> sprintf "%s | %s" acc x) let pipedTags tags = tags |> List.reduce (fun acc x -> sprintf "%s | %s" acc x)
/// The actual post /// The actual post
@ -342,8 +343,8 @@ type PostForDisplay(webLog : WebLog, post : Post) =
/// Model for all page-of-posts pages /// Model for all page-of-posts pages
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 : string option = None with get, set member val Subtitle : string option = None with get, set
/// The posts to display /// The posts to display
@ -368,7 +369,7 @@ type PostsModel(ctx, webLog) =
/// Form for editing a post /// Form for editing a post
type EditPostForm() = type EditPostForm () =
/// The title of the post /// The title of the post
member val Title = "" with get, set member val Title = "" with get, set
/// The permalink for the post /// The permalink for the post
@ -399,8 +400,8 @@ type EditPostForm() =
this this
/// View model for the edit post page /// View model for the edit post page
type EditPostModel(ctx, webLog, post, revision) = type EditPostModel (ctx, webLog, post, revision) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The form /// The form
member val Form = EditPostForm().ForPost(post).ForRevision(revision) with get, set member val Form = EditPostForm().ForPost(post).ForRevision(revision) with get, set
@ -419,7 +420,7 @@ type EditPostModel(ctx, webLog, post, revision) =
// ---- User models ---- // ---- User models ----
/// Form for the log on page /// Form for the log on page
type LogOnForm() = type LogOnForm () =
/// The URL to which the user will be directed upon successful log on /// The URL to which the user will be directed upon successful log on
member val ReturnUrl = "" with get, set member val ReturnUrl = "" with get, set
/// The e-mail address /// The e-mail address
@ -429,7 +430,7 @@ type LogOnForm() =
/// Model to support the user log on page /// Model to support the user log on page
type LogOnModel(ctx, webLog) = type LogOnModel (ctx, webLog) =
inherit MyWebLogModel(ctx, webLog) inherit MyWebLogModel (ctx, webLog)
/// The log on form /// The log on form
member val Form = LogOnForm() with get, set member val Form = LogOnForm () with get, set

43
src/MyWebLog.Data.RethinkDB/DataConfig.fs
View File

@ -27,32 +27,17 @@ type DataConfig =
with with
/// Use RethinkDB defaults for non-provided options, and connect to the server /// Use RethinkDB defaults for non-provided options, and connect to the server
static member Connect config = static member Connect config =
let ensureHostname cfg = match cfg.Hostname with let host cfg = match cfg.Hostname with null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname } | _ -> cfg
| null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname } let port cfg = match cfg.Port with 0 -> { cfg with Port = RethinkDBConstants.DefaultPort } | _ -> cfg
| _ -> cfg let auth cfg = match cfg.AuthKey with null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey } | _ -> cfg
let ensurePort cfg = match cfg.Port with let timeout cfg = match cfg.Timeout with 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout } | _ -> cfg
| 0 -> { cfg with Port = RethinkDBConstants.DefaultPort } let db cfg = match cfg.Database with null -> { cfg with Database = RethinkDBConstants.DefaultDbName } | _ -> cfg
| _ -> cfg let connect cfg =
let ensureAuthKey cfg = match cfg.AuthKey with { cfg with Conn = RethinkDB.R.Connection()
| null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey } .Hostname(cfg.Hostname)
| _ -> cfg .Port(cfg.Port)
let ensureTimeout cfg = match cfg.Timeout with .AuthKey(cfg.AuthKey)
| 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout } .Db(cfg.Database)
| _ -> cfg .Timeout(cfg.Timeout)
let ensureDatabase cfg = match cfg.Database with .Connect () }
| null -> { cfg with Database = RethinkDBConstants.DefaultDbName } (host >> port >> auth >> timeout >> db >> connect) config
| _ -> cfg
let connect cfg = { cfg with Conn = RethinkDB.R.Connection()
.Hostname(cfg.Hostname)
.Port(cfg.Port)
.AuthKey(cfg.AuthKey)
.Db(cfg.Database)
.Timeout(cfg.Timeout)
.Connect() }
config
|> ensureHostname
|> ensurePort
|> ensureAuthKey
|> ensureTimeout
|> ensureDatabase
|> connect

2
src/MyWebLog.Data.RethinkDB/Post.fs
View File

@ -101,7 +101,7 @@ let tryFindPost conn webLogId postId : Post option =
r.Table(Table.Post) r.Table(Table.Post)
.Get(postId) .Get(postId)
.Filter(ReqlFunction1 (fun p -> upcast p.["WebLogId"].Eq webLogId)) .Filter(ReqlFunction1 (fun p -> upcast p.["WebLogId"].Eq webLogId))
.RunResultAsync<Post> conn .RunAtomAsync<Post> conn
return match box p with null -> None | post -> Some <| unbox post return match box p with null -> None | post -> Some <| unbox post
} }
|> Async.RunSynchronously |> Async.RunSynchronously

3
src/MyWebLog.Data.RethinkDB/RethinkMyWebLogData.fs
View File

@ -40,7 +40,8 @@ type RethinkMyWebLogData(conn : IConnection, cfg : DataConfig) =
member __.AddPost = Post.addPost conn member __.AddPost = Post.addPost conn
member __.UpdatePost = Post.updatePost conn member __.UpdatePost = Post.updatePost conn
member __.LogOn = User.tryUserLogOn conn member __.LogOn = User.tryUserLogOn conn
member __.SetUserPassword = User.setUserPassword conn
member __.WebLogByUrlBase = WebLog.tryFindWebLogByUrlBase conn member __.WebLogByUrlBase = WebLog.tryFindWebLogByUrlBase conn
member __.DashboardCounts = WebLog.findDashboardCounts conn member __.DashboardCounts = WebLog.findDashboardCounts conn

12
src/MyWebLog.Data.RethinkDB/User.fs
View File

@ -14,8 +14,18 @@ let tryUserLogOn conn (email : string) (passwordHash : string) =
let! user = let! user =
r.Table(Table.User) r.Table(Table.User)
.GetAll(email).OptArg("index", "UserName") .GetAll(email).OptArg("index", "UserName")
.Filter(ReqlFunction1(fun u -> upcast u.["PasswordHash"].Eq(passwordHash))) .Filter(ReqlFunction1 (fun u -> upcast u.["PasswordHash"].Eq passwordHash))
.RunResultAsync<User list> conn .RunResultAsync<User list> conn
return user |> List.tryHead return user |> List.tryHead
} }
|> Async.RunSynchronously |> Async.RunSynchronously
/// Set a user's password
let setUserPassword conn (email : string) (passwordHash : string) =
async {
do! r.Table(Table.User)
.GetAll(email).OptArg("index", "UserName")
.Update(dict [ "PasswordHash", passwordHash ])
.RunResultAsync conn
}
|> Async.RunSynchronously

3
src/MyWebLog.Entities/IMyWebLogData.fs
View File

@ -105,6 +105,9 @@ type IMyWebLogData =
/// Attempt to log on a user /// Attempt to log on a user
abstract LogOn : (string -> string -> User option) abstract LogOn : (string -> string -> User option)
/// Set a user's password (e-mail, password hash)
abstract SetUserPassword : (string -> string -> unit)
// --- WebLog --- // --- WebLog ---
/// Get a web log by its URL base /// Get a web log by its URL base

2
src/MyWebLog.Logic/User.fs
View File

@ -5,3 +5,5 @@ open MyWebLog.Data
/// Try to log on a user /// Try to log on a user
let tryUserLogOn (data : IMyWebLogData) email passwordHash = data.LogOn email passwordHash let tryUserLogOn (data : IMyWebLogData) email passwordHash = data.LogOn email passwordHash
let setUserPassword (data : IMyWebLogData) = data.SetUserPassword

1
src/MyWebLog.Resources/en-US.json
View File

@ -7,6 +7,7 @@
"Admin": "Admin", "Admin": "Admin",
"AndPublished": " and Published", "AndPublished": " and Published",
"andXMore": "and {0} more...", "andXMore": "and {0} more...",
"at": "at",
"Categories": "Categories", "Categories": "Categories",
"Category": "Category", "Category": "Category",
"CategoryDeleteWarning": "Are you sure you wish to delete the category", "CategoryDeleteWarning": "Are you sure you wish to delete the category",

5
src/MyWebLog/views/admin/content/admin.css Normal file
View File

@ -0,0 +1,5 @@
footer {
background-color: #808080;
border-top: solid 1px black;
color: white;
}

4
src/myWebLog/views/admin/admin-layout.html
View File

@ -7,7 +7,7 @@
<link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.4/css/bootstrap.css" /> <link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.4/css/bootstrap.css" />
<link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/bootswatch/3.3.4/cosmo/bootstrap.min.css" /> <link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/bootswatch/3.3.4/cosmo/bootstrap.min.css" />
<link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css" /> <link rel="stylesheet" type="text/css" href="//maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css" />
<link rel="stylesheet" type="text/css" href="/content/styles/admin.css" /> <link rel="stylesheet" type="text/css" href="/admin/content/admin.css" />
</head> </head>
<body> <body>
<header> <header>
@ -46,7 +46,7 @@
</footer> </footer>
<script type="text/javascript" src="//ajax.aspnetcdn.com/ajax/jQuery/jquery-2.1.3.min.js"></script> <script type="text/javascript" src="//ajax.aspnetcdn.com/ajax/jQuery/jquery-2.1.3.min.js"></script>
<script type="text/javascript" src="//maxcdn.bootstrapcdn.com/bootstrap/3.3.4/js/bootstrap.min.js"></script> <script type="text/javascript" src="//maxcdn.bootstrapcdn.com/bootstrap/3.3.4/js/bootstrap.min.js"></script>
<script type="text/javascript" src="//tinymce.cachefly.net/4.1/tinymce.min.js"></script> <script type="text/javascript" src="//cdn.tinymce.com/4/tinymce.min.js"></script>
@Section['Scripts']; @Section['Scripts'];
</body> </body>
</html> </html>