Log on works now

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

View File

@ -45,17 +45,24 @@ type TranslateTokenViewEngineMatcher() =
/// Handle forms authentication
type MyWebLogUser(name, claims) =
inherit ClaimsPrincipal()
member this.UserName with get() = name
member this.Claims with get() = claims
type MyWebLogUser (claims : Claim seq) =
inherit ClaimsPrincipal (ClaimsIdentity (claims, "forms"))
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) =
interface IUserMapper with
member this.GetUserFromIdentifier (identifier, context) =
match context.Request.PersistableSession.GetOrDefault (Keys.User, User.Empty) with
| user when user.Id = string identifier -> upcast MyWebLogUser(user.PreferredName, user.Claims)
| user when user.Id = string identifier -> upcast MyWebLogUser user
| _ -> null
@ -71,30 +78,28 @@ 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 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) =
base.ConfigureApplicationContainer container
container.Register<AppConfig>(cfg)
container.Register<AppConfig> cfg
|> ignore
data.Force().SetUp ()
container.Register<IMyWebLogData> (data.Force ())
|> ignore
// NodaTime
container.Register<IClock>(SystemClock.Instance)
container.Register<IClock> SystemClock.Instance
|> ignore
// I18N in SSVE
container.Register<seq<ISuperSimpleViewEngineMatcher>>(fun _ _ ->
container.Register<ISuperSimpleViewEngineMatcher seq> (fun _ _ ->
Seq.singleton (TranslateTokenViewEngineMatcher () :> ISuperSimpleViewEngineMatcher))
|> ignore
@ -113,7 +118,7 @@ type MyWebLogBootstrapper() =
// CSRF
Csrf.Enable pipelines
// Sessions
let sessions = RethinkDBSessionConfiguration(cfg.DataConfig.Conn)
let sessions = RethinkDBSessionConfiguration cfg.DataConfig.Conn
sessions.Database <- cfg.DataConfig.Database
//let sessions = RelationalSessionConfiguration(ConfigurationManager.ConnectionStrings.["SessionStore"].ConnectionString)
PersistableSessions.Enable (pipelines, sessions)
@ -151,7 +156,7 @@ type Startup() =
member this.Configure (app : IApplicationBuilder) =
let opt = NancyOptions ()
opt.Bootstrapper <- new MyWebLogBootstrapper ()
app.UseOwin(fun x -> x.UseNancy(opt) |> ignore) |> ignore
app.UseOwin (fun x -> x.UseNancy opt |> ignore) |> ignore
let Run () =

View File

@ -22,19 +22,20 @@ type CategoryModule(data : IMyWebLogData) as this =
/// Display a list of categories
member this.CategoryList () : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = CategoryListModel(this.Context, this.WebLog,
(findAllCategories data this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat (fun _ -> false))))
upcast this.View.["/admin/category/list", model]
let model =
CategoryListModel (
this.Context, this.WebLog, findAllCategories data this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat (fun _ -> false)))
upcast this.View.["admin/category/list", model]
/// Edit a category
member this.EditCategory (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
match (match catId with
| "new" -> Some Category.Empty
| _ -> tryFindCategory data this.WebLog.Id catId) with
| Some cat -> let model = CategoryEditModel(this.Context, this.WebLog, cat)
match catId with "new" -> Some Category.Empty | _ -> tryFindCategory data this.WebLog.Id catId
|> function
| Some cat ->
let model = CategoryEditModel(this.Context, this.WebLog, cat)
model.Categories <- findAllCategories data this.WebLog.Id
|> List.map (fun cat -> IndentedCategory.Create cat
(fun c -> c = defaultArg (fst cat).ParentId ""))
@ -47,18 +48,20 @@ type CategoryModule(data : IMyWebLogData) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
let form = this.Bind<CategoryForm> ()
let oldCat = match catId with
match catId with
| "new" -> Some { Category.Empty with WebLogId = this.WebLog.Id }
| _ -> tryFindCategory data this.WebLog.Id catId
match oldCat with
| Some old -> let cat = { old with Name = form.Name
|> function
| Some old ->
let cat = { old with Name = form.Name
Slug = form.Slug
Description = match form.Description with "" -> None | d -> Some d
ParentId = match form.ParentId with "" -> None | p -> Some p }
let newCatId = saveCategory data cat
match old.ParentId = cat.ParentId with
| true -> ()
| _ -> match old.ParentId with
| _ ->
match old.ParentId with
| Some parentId -> removeCategoryFromParent data this.WebLog.Id parentId newCatId
| _ -> ()
match cat.ParentId with
@ -80,9 +83,11 @@ type CategoryModule(data : IMyWebLogData) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
match tryFindCategory data this.WebLog.Id catId with
| Some cat -> deleteCategory data cat
| Some cat ->
deleteCategory data cat
let model = MyWebLogModel(this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
{ UserMessage.Empty with
Level = Level.Info
Message = System.String.Format(Strings.get "MsgCategoryDeleted", cat.Name) }
|> model.AddMessage
this.Redirect "/categories" model

View File

@ -25,10 +25,12 @@ type NancyModule with
match List.length model.Messages with
| 0 -> ()
| _ -> 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
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 ->
claim.Type = ClaimTypes.Role && claim.Value = sprintf "%s|%s" this.WebLog.Id level)
this.RequiresAuthentication ()
this.RequiresClaims [| findClaim |]

View File

@ -23,8 +23,9 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
/// List all pages
member this.PageList () : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PagesModel(this.Context, this.WebLog, (findAllPages data this.WebLog.Id
|> List.map (fun p -> PageForDisplay(this.WebLog, p))))
let model =
PagesModel(this.Context, this.WebLog, findAllPages data this.WebLog.Id
|> List.map (fun p -> PageForDisplay (this.WebLog, p)))
model.PageTitle <- Strings.get "Pages"
upcast this.View.["admin/page/list", model]
@ -34,7 +35,8 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
let pageId = parameters.["id"].ToString ()
match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId
|> function
| Some page -> let rev = match page.Revisions
| Some page ->
let rev = match page.Revisions
|> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with
| Some r -> r
@ -51,8 +53,10 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
let pageId = parameters.["id"].ToString ()
let form = this.Bind<EditPageForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
match (match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId) with
| Some p -> let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p
match pageId with "new" -> Some Page.Empty | _ -> tryFindPage data this.WebLog.Id pageId
|> function
| Some p ->
let page = match pageId with "new" -> { p with WebLogId = this.WebLog.Id } | _ -> p
let pId = { p with
Title = form.Title
Permalink = form.Permalink
@ -81,9 +85,11 @@ type PageModule(data : IMyWebLogData, clock : IClock) as this =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString ()
match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page -> deletePage data page.WebLogId page.Id
| Some page ->
deletePage data page.WebLogId page.Id
let model = MyWebLogModel (this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
{ UserMessage.Empty with
Level = Level.Info
Message = Strings.get "MsgPageDeleted" }
|> model.AddMessage
this.Redirect "/pages" model

View File

@ -139,8 +139,10 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.HomePage () : obj =
match this.WebLog.DefaultPage with
| "posts" -> this.PublishedPostsPage 1
| pageId -> match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page -> let model = PageModel(this.Context, this.WebLog, page)
| pageId ->
match tryFindPageWithoutRevisions data this.WebLog.Id pageId with
| Some page ->
let model = PageModel(this.Context, this.WebLog, page)
model.PageTitle <- page.Title
this.ThemedView "page" model
| _ -> this.NotFound ()
@ -172,7 +174,8 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.CategorizedPosts (parameters : DynamicDictionary) : obj =
let slug = parameters.["slug"].ToString ()
match tryFindCategoryBySlug data this.WebLog.Id slug with
| Some cat -> let pageNbr = getPage parameters
| Some cat ->
let pageNbr = getPage parameters
let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfCategorizedPosts data this.WebLog.Id cat.Id pageNbr 10 |> forDisplay
@ -215,7 +218,8 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.Feed () : obj =
let query = this.Request.Query :?> DynamicDictionary
match query.ContainsKey "format" with
| true -> match query.["format"].ToString () with
| true ->
match query.["format"].ToString () with
| x when x = "atom" || x = "rss" -> generateFeed x
| x when x = "rss2" -> generateFeed "rss"
| _ -> this.Redirect "/feed" (MyWebLogModel (this.Context, this.WebLog))
@ -239,8 +243,10 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
member this.EditPost (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let postId = parameters.["postId"].ToString ()
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with
| Some post -> let rev = match post.Revisions
match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId
|> function
| Some post ->
let rev = match post.Revisions
|> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with
| Some r -> r
@ -248,8 +254,7 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
let model = EditPostModel (this.Context, this.WebLog, post, rev)
model.Categories <- findAllCategories data this.WebLog.Id
|> List.map (fun cat -> string (fst cat).Id,
sprintf "%s%s"
(String.replicate (snd cat) " &nbsp; &nbsp; ")
sprintf "%s%s" (String.replicate (snd cat) " &nbsp; &nbsp; ")
(fst cat).Name)
model.PageTitle <- Strings.get <| match post.Id with "new" -> "AddNewPost" | _ -> "EditPost"
upcast this.View.["admin/post/edit"]
@ -262,18 +267,19 @@ type PostModule(data : IMyWebLogData, clock : IClock) as this =
let postId = parameters.["postId"].ToString ()
let form = this.Bind<EditPostForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
match (match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId) with
| Some p -> let justPublished = p.PublishedOn = int64 0 && form.PublishNow
match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId
|> function
| Some p ->
let justPublished = p.PublishedOn = int64 0 && form.PublishNow
let post = match postId with
| "new" -> { p with
WebLogId = this.WebLog.Id
AuthorId = (this.Request.PersistableSession.GetOrDefault<User>
(Keys.User, User.Empty)).Id }
| _ -> p
let pId = { post with
Status = match form.PublishNow with
| true -> PostStatus.Published
| _ -> PostStatus.Draft
let pId =
{ post with
Status = match form.PublishNow with true -> PostStatus.Published | _ -> PostStatus.Draft
Title = form.Title
Permalink = form.Permalink
PublishedOn = match justPublished with true -> now | _ -> int64 0

View File

@ -24,7 +24,7 @@ type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
do
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 ())
/// Show the log on page
@ -40,15 +40,16 @@ type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
let form = this.Bind<LogOnForm> ()
let model = MyWebLogModel(this.Context, this.WebLog)
match tryUserLogOn data form.Email (pbkdf2 form.Password) with
| Some user -> this.Session.[Keys.User] <- user
{ UserMessage.Empty with Level = Level.Info
Message = Strings.get "MsgLogOnSuccess" }
|> model.AddMessage
| Some user ->
this.Session.[Keys.User] <- user
model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgLogOnSuccess" }
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
upcast this.LoginAndRedirect (System.Guid.Parse user.Id,
fallbackRedirectUrl = defaultArg (Option.ofObj form.ReturnUrl) "/")
| _ -> { UserMessage.Empty with Level = Level.Error
| _ ->
{ UserMessage.Empty with
Level = Level.Error
Message = Strings.get "ErrBadLogOnAttempt" }
|> model.AddMessage
this.Redirect (sprintf "/user/logon?returnUrl=%s" form.ReturnUrl) model
@ -59,8 +60,6 @@ type UserModule(data : IMyWebLogData, cfg : AppConfig) as this =
let user = this.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty)
this.Session.DeleteAll ()
let model = MyWebLogModel (this.Context, this.WebLog)
{ UserMessage.Empty with Level = Level.Info
Message = Strings.get "MsgLogOffSuccess" }
|> model.AddMessage
model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgLogOffSuccess" }
this.Redirect "" model |> ignore
upcast this.LogoutAndRedirect "/"

View File

@ -128,7 +128,8 @@ type MyWebLogModel(ctx : NancyContext, webLog : WebLog) =
/// The page title with the web log name appended
member this.DisplayPageTitle =
match this.PageTitle with
| "" -> match this.WebLog.Subtitle with
| "" ->
match this.WebLog.Subtitle with
| Some st -> sprintf "%s | %s" this.WebLog.Name st
| None -> this.WebLog.Name
| pt -> sprintf "%s | %s" pt this.WebLog.Name

View File

@ -27,32 +27,17 @@ type DataConfig =
with
/// 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
let ensurePort cfg = match cfg.Port with
| 0 -> { cfg with Port = RethinkDBConstants.DefaultPort }
| _ -> cfg
let ensureAuthKey cfg = match cfg.AuthKey with
| null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey }
| _ -> 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
let connect cfg = { cfg with Conn = RethinkDB.R.Connection()
let host cfg = match cfg.Hostname with null -> { cfg with Hostname = RethinkDBConstants.DefaultHostname } | _ -> cfg
let port cfg = match cfg.Port with 0 -> { cfg with Port = RethinkDBConstants.DefaultPort } | _ -> cfg
let auth cfg = match cfg.AuthKey with null -> { cfg with AuthKey = RethinkDBConstants.DefaultAuthkey } | _ -> cfg
let timeout cfg = match cfg.Timeout with 0 -> { cfg with Timeout = RethinkDBConstants.DefaultTimeout } | _ -> cfg
let db cfg = match cfg.Database with null -> { cfg with Database = RethinkDBConstants.DefaultDbName } | _ -> 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
(host >> port >> auth >> timeout >> db >> connect) config

View File

@ -101,7 +101,7 @@ let tryFindPost conn webLogId postId : Post option =
r.Table(Table.Post)
.Get(postId)
.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
}
|> Async.RunSynchronously

View File

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

View File

@ -14,8 +14,18 @@ let tryUserLogOn conn (email : string) (passwordHash : string) =
let! user =
r.Table(Table.User)
.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
return user |> List.tryHead
}
|> 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

View File

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

View File

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

View File

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

View File

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

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/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="/content/styles/admin.css" />
<link rel="stylesheet" type="text/css" href="/admin/content/admin.css" />
</head>
<body>
<header>
@ -46,7 +46,7 @@
</footer>
<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="//tinymce.cachefly.net/4.1/tinymce.min.js"></script>
<script type="text/javascript" src="//cdn.tinymce.com/4/tinymce.min.js"></script>
@Section['Scripts'];
</body>
</html>