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

Version 2, ready for beta

Browse Source
This commit was merged in pull request #1.
This commit is contained in:
Daniel J. Summers
2022-06-22 20:35:12 -04:00
committed by GitHub
parent 33dccf5822
commit 0f66ca969d
125 changed files with 10015 additions and 4521 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
.gitignore vendored
View File

@@ -253,7 +253,11 @@ paket-files/
.idea/
*.sln.iml
# Personal themes used to test initial release
src/MyWebLog/views/themes/daniel-j-summers
src/MyWebLog/views/themes/daniels-weekly-devotions
src/MyWebLog/views/themes/djs-consulting
# Zipped myWebLog themes
**/*.zip
# Files used for testing
src/MyWebLog/wwwroot/img/daniel-j-summers
src/MyWebLog/wwwroot/img/bit-badger
.ionide

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

@@ -1,155 +0,0 @@
module MyWebLog.App
open MyWebLog
open MyWebLog.Data
open MyWebLog.Data.RethinkDB
open MyWebLog.Entities
open MyWebLog.Logic.WebLog
open MyWebLog.Resources
open Nancy
open Nancy.Authentication.Forms
open Nancy.Bootstrapper
open Nancy.Conventions
open Nancy.Cryptography
open Nancy.Owin
open Nancy.Security
open Nancy.Session.Persistable
//open Nancy.Session.Relational
open Nancy.Session.RethinkDB
open Nancy.TinyIoc
open Nancy.ViewEngines.SuperSimpleViewEngine
open NodaTime
open RethinkDb.Driver.Net
open Suave
open Suave.Owin
open System
open System.IO
open System.Reflection
open System.Security.Claims
open System.Text.RegularExpressions
/// Establish the configuration for this instance
let cfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json")
with ex -> raise <| Exception (Strings.get "ErrBadAppConfig", ex)
let data = lazy (RethinkMyWebLogData (cfg.DataConfig.Conn, cfg.DataConfig) :> IMyWebLogData)
/// 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) =
let translate (m : Match) = Strings.get m.Groups.["TranslationKey"].Value
regex.Replace(content, translate)
/// Handle forms authentication
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
| _ -> null
/// Set up the application environment
type MyWebLogBootstrapper() =
inherit DefaultNancyBootstrapper()
override this.ConfigureRequestContainer (container, context) =
base.ConfigureRequestContainer (container, context)
/// User mapper for forms authentication
container.Register<IUserMapper, MyWebLogUserMapper>()
|> ignore
override this.ConfigureConventions (conventions) =
base.ConfigureConventions conventions
conventions.StaticContentsConventions.Add
(StaticContentConventionBuilder.AddDirectory ("admin/content", "views/admin/content"))
// Make theme content available at [theme-name]/
Directory.EnumerateDirectories (Path.Combine [| "views"; "themes" |])
|> 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
|> ignore
data.Force().SetUp ()
container.Register<IMyWebLogData> (data.Force ())
|> ignore
// NodaTime
container.Register<IClock> SystemClock.Instance
|> ignore
// I18N in SSVE
container.Register<ISuperSimpleViewEngineMatcher seq> (fun _ _ ->
Seq.singleton (TranslateTokenViewEngineMatcher () :> ISuperSimpleViewEngineMatcher))
|> ignore
override this.ApplicationStartup (container, pipelines) =
base.ApplicationStartup (container, pipelines)
// Forms authentication configuration
let auth =
FormsAuthenticationConfiguration (
CryptographyConfiguration =
CryptographyConfiguration (
AesEncryptionProvider (PassphraseKeyGenerator (cfg.AuthEncryptionPassphrase, cfg.AuthSalt)),
DefaultHmacProvider (PassphraseKeyGenerator (cfg.AuthHmacPassphrase, cfg.AuthSalt))),
RedirectUrl = "~/user/log-on",
UserMapper = container.Resolve<IUserMapper> ())
FormsAuthentication.Enable (pipelines, auth)
// CSRF
Csrf.Enable pipelines
// Sessions
let sessions = RethinkDBSessionConfiguration cfg.DataConfig.Conn
sessions.Database <- cfg.DataConfig.Database
//let sessions = RelationalSessionConfiguration(ConfigurationManager.ConnectionStrings.["SessionStore"].ConnectionString)
PersistableSessions.Enable (pipelines, sessions)
()
override this.Configure (environment) =
base.Configure environment
environment.Tracing (true, true)
let version =
let v = typeof<AppConfig>.GetTypeInfo().Assembly.GetName().Version
match v.Build with
| 0 -> match v.Minor with 0 -> string v.Major | _ -> sprintf "%d.%d" v.Major v.Minor
| _ -> sprintf "%d.%d.%d" v.Major v.Minor v.Build
|> sprintf "v%s"
/// Set up the request environment
type RequestEnvironment() =
interface IRequestStartup with
member this.Initialize (pipelines, context) =
let establishEnv (ctx : NancyContext) =
ctx.Items.[Keys.RequestStart] <- DateTime.Now.Ticks
match tryFindWebLogByUrlBase (data.Force ()) ctx.Request.Url.HostName with
| Some webLog -> ctx.Items.[Keys.WebLog] <- webLog
| None -> // TODO: redirect to domain set up page
Exception (sprintf "%s %s" ctx.Request.Url.HostName (Strings.get "ErrNotConfigured"))
|> raise
ctx.Items.[Keys.Version] <- version
null
pipelines.BeforeRequest.AddItemToStartOfPipeline establishEnv
let Run () =
OwinApp.ofMidFunc "/" (NancyMiddleware.UseNancy (NancyOptions (Bootstrapper = new MyWebLogBootstrapper ())))
|> startWebServer defaultConfig

33
src/MyWebLog.App/AppConfig.fs
View File

@@ -1,33 +0,0 @@
namespace MyWebLog
open MyWebLog.Data.RethinkDB
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 }

21
src/MyWebLog.App/AssemblyInfo.fs
View File

@@ -1,21 +0,0 @@
namespace MyWebLog.AssemblyInfo
open System.Reflection
open System.Runtime.CompilerServices
open System.Runtime.InteropServices
[<assembly: AssemblyTitle("MyWebLog.Web")>]
[<assembly: AssemblyDescription("Main Nancy assembly for myWebLog")>]
[<assembly: AssemblyConfiguration("")>]
[<assembly: AssemblyCompany("DJS Consulting")>]
[<assembly: AssemblyProduct("MyWebLog.Web")>]
[<assembly: AssemblyCopyright("Copyright © 2016")>]
[<assembly: AssemblyTrademark("")>]
[<assembly: AssemblyCulture("")>]
[<assembly: ComVisible(false)>]
[<assembly: Guid("e6ee110a-27a6-4a19-b0cb-d24f48f71b53")>]
[<assembly: AssemblyVersion("0.9.2.0")>]
[<assembly: AssemblyFileVersion("1.0.0.0")>]
do
()

140
src/MyWebLog.App/Data/Category.fs
View File

@@ -1,140 +0,0 @@
module MyWebLog.Data.RethinkDB.Category
open MyWebLog.Entities
open RethinkDb.Driver.Ast
let private r = RethinkDb.Driver.RethinkDB.R
/// Get all categories for a web log
let getAllCategories conn (webLogId : string) =
async {
return! r.Table(Table.Category)
.GetAll(webLogId).OptArg("index", "WebLogId")
.OrderBy("Name")
.RunResultAsync<Category list> conn
}
|> Async.RunSynchronously
/// Get a specific category by its Id
let tryFindCategory conn webLogId catId : Category option =
async {
let! c =
r.Table(Table.Category)
.Get(catId)
.RunResultAsync<Category> conn
return
match box c with
| null -> None
| catt ->
let cat : Category = unbox catt
match cat.WebLogId = webLogId with true -> Some cat | _ -> None
}
|> Async.RunSynchronously
/// Add a category
let addCategory conn (cat : Category) =
async {
do! r.Table(Table.Category)
.Insert(cat)
.RunResultAsync conn
}
|> Async.RunSynchronously
type CategoryUpdateRecord =
{ Name : string
Slug : string
Description : string option
ParentId : string option
}
/// Update a category
let updateCategory conn (cat : Category) =
match tryFindCategory conn cat.WebLogId cat.Id with
| Some _ ->
async {
do! r.Table(Table.Category)
.Get(cat.Id)
.Update(
{ CategoryUpdateRecord.Name = cat.Name
Slug = cat.Slug
Description = cat.Description
ParentId = cat.ParentId
})
.RunResultAsync conn
}
|> Async.RunSynchronously
| _ -> ()
/// Update a category's children
let updateChildren conn webLogId parentId (children : string list) =
match tryFindCategory conn webLogId parentId with
| Some _ ->
async {
do! r.Table(Table.Category)
.Get(parentId)
.Update(dict [ "Children", children ])
.RunResultAsync conn
}
|> Async.RunSynchronously
| _ -> ()
/// Delete a category
let deleteCategory conn (cat : Category) =
async {
// Remove the category from its parent
match cat.ParentId with
| Some parentId ->
match tryFindCategory conn cat.WebLogId parentId with
| Some parent -> parent.Children
|> List.filter (fun childId -> childId <> cat.Id)
|> updateChildren conn cat.WebLogId parentId
| _ -> ()
| _ -> ()
// Move this category's children to its parent
cat.Children
|> List.map (fun childId ->
match tryFindCategory conn cat.WebLogId childId with
| Some _ ->
async {
do! r.Table(Table.Category)
.Get(childId)
.Update(dict [ "ParentId", cat.ParentId ])
.RunResultAsync conn
}
|> Some
| _ -> None)
|> List.filter Option.isSome
|> List.map Option.get
|> List.iter Async.RunSynchronously
// Remove the category from posts where it is assigned
let! posts =
r.Table(Table.Post)
.GetAll(cat.WebLogId).OptArg("index", "WebLogId")
.Filter(ReqlFunction1 (fun p -> upcast p.["CategoryIds"].Contains cat.Id))
.RunResultAsync<Post list> conn
|> Async.AwaitTask
posts
|> List.map (fun post ->
async {
do! r.Table(Table.Post)
.Get(post.Id)
.Update(dict [ "CategoryIds", post.CategoryIds |> List.filter (fun c -> c <> cat.Id) ])
.RunResultAsync conn
})
|> List.iter Async.RunSynchronously
// Now, delete the category
do! r.Table(Table.Category)
.Get(cat.Id)
.Delete()
.RunResultAsync conn
}
|> Async.RunSynchronously
/// Get a category by its slug
let tryFindCategoryBySlug conn (webLogId : string) (slug : string) =
async {
let! cat = r.Table(Table.Category)
.GetAll(r.Array (webLogId, slug)).OptArg("index", "Slug")
.RunResultAsync<Category list> conn
return cat |> List.tryHead
}
|> Async.RunSynchronously

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

@@ -1,43 +0,0 @@
namespace MyWebLog.Data.RethinkDB
open RethinkDb.Driver
open RethinkDb.Driver.Net
open Newtonsoft.Json
/// Data configuration
type DataConfig =
{ /// The hostname for the RethinkDB server
[<JsonProperty("hostname")>]
Hostname : string
/// The port for the RethinkDB server
[<JsonProperty("port")>]
Port : int
/// The authorization key to use when connecting to the server
[<JsonProperty("authKey")>]
AuthKey : string
/// How long an attempt to connect to the server should wait before giving up
[<JsonProperty("timeout")>]
Timeout : int
/// The name of the default database to use on the connection
[<JsonProperty("database")>]
Database : string
/// A connection to the RethinkDB server using the configuration in this object
[<JsonIgnore>]
Conn : IConnection }
with
/// Use RethinkDB defaults for non-provided options, and connect to the server
static member Connect config =
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 () }
(host >> port >> auth >> timeout >> db >> connect) config

16
src/MyWebLog.App/Data/Extensions.fs
View File

@@ -1,16 +0,0 @@
[<AutoOpen>]
module MyWebLog.Data.RethinkDB.Extensions
open System.Threading.Tasks
// H/T: Suave
type AsyncBuilder with
/// An extension method that overloads the standard 'Bind' of the 'async' builder. The new overload awaits on
/// a standard .NET task
member x.Bind(t : Task<'T>, f:'T -> Async<'R>) : Async<'R> = async.Bind(Async.AwaitTask t, f)
/// An extension method that overloads the standard 'Bind' of the 'async' builder. The new overload awaits on
/// a standard .NET task which does not commpute a value
member x.Bind(t : Task, f : unit -> Async<'R>) : Async<'R> = async.Bind(Async.AwaitTask t, f)
member x.ReturnFrom(t : Task<'T>) = Async.AwaitTask t

98
src/MyWebLog.App/Data/Page.fs
View File

@@ -1,98 +0,0 @@
module MyWebLog.Data.RethinkDB.Page
open MyWebLog.Entities
open RethinkDb.Driver.Ast
let private r = RethinkDb.Driver.RethinkDB.R
/// Try to find a page by its Id, optionally including revisions
let tryFindPageById conn webLogId (pageId : string) includeRevs =
async {
let q =
r.Table(Table.Page)
.Get pageId
let! thePage =
match includeRevs with
| true -> q.RunResultAsync<Page> conn
| _ -> q.Without("Revisions").RunResultAsync<Page> conn
return
match box thePage with
| null -> None
| page ->
let pg : Page = unbox page
match pg.WebLogId = webLogId with true -> Some pg | _ -> None
}
|> Async.RunSynchronously
/// Find a page by its permalink
let tryFindPageByPermalink conn (webLogId : string) (permalink : string) =
async {
let! pg =
r.Table(Table.Page)
.GetAll(r.Array (webLogId, permalink)).OptArg("index", "Permalink")
.Without("Revisions")
.RunResultAsync<Page list> conn
return List.tryHead pg
}
|> Async.RunSynchronously
/// Get a list of all pages (excludes page text and revisions)
let findAllPages conn (webLogId : string) =
async {
return!
r.Table(Table.Page)
.GetAll(webLogId).OptArg("index", "WebLogId")
.OrderBy("Title")
.Without("Text", "Revisions")
.RunResultAsync<Page list> conn
}
|> Async.RunSynchronously
/// Add a page
let addPage conn (page : Page) =
async {
do! r.Table(Table.Page)
.Insert(page)
.RunResultAsync conn
}
|> (Async.RunSynchronously >> ignore)
type PageUpdateRecord =
{ Title : string
Permalink : string
PublishedOn : int64
UpdatedOn : int64
ShowInPageList : bool
Text : string
Revisions : Revision list }
/// Update a page
let updatePage conn (page : Page) =
match tryFindPageById conn page.WebLogId page.Id false with
| Some _ ->
async {
do! r.Table(Table.Page)
.Get(page.Id)
.Update({ PageUpdateRecord.Title = page.Title
Permalink = page.Permalink
PublishedOn = page.PublishedOn
UpdatedOn = page.UpdatedOn
ShowInPageList = page.ShowInPageList
Text = page.Text
Revisions = page.Revisions })
.RunResultAsync conn
}
|> (Async.RunSynchronously >> ignore)
| _ -> ()
/// Delete a page
let deletePage conn webLogId pageId =
match tryFindPageById conn webLogId pageId false with
| Some _ ->
async {
do! r.Table(Table.Page)
.Get(pageId)
.Delete()
.RunResultAsync conn
}
|> (Async.RunSynchronously >> ignore)
| _ -> ()

225
src/MyWebLog.App/Data/Post.fs
View File

@@ -1,225 +0,0 @@
module MyWebLog.Data.RethinkDB.Post
open MyWebLog.Entities
open RethinkDb.Driver.Ast
let private r = RethinkDb.Driver.RethinkDB.R
/// Shorthand to select all published posts for a web log
let private publishedPosts (webLogId : string) =
r.Table(Table.Post)
.GetAll(r.Array (webLogId, PostStatus.Published)).OptArg("index", "WebLogAndStatus")
.Without("Revisions")
// This allows us to count comments without retrieving them all
.Merge(ReqlFunction1 (fun p ->
upcast r.HashMap(
"Comments", r.Table(Table.Comment)
.GetAll(p.["id"]).OptArg("index", "PostId")
.Pluck("id")
.CoerceTo("array"))))
/// Shorthand to sort posts by published date, slice for the given page, and return a list
let private toPostList conn pageNbr nbrPerPage (filter : ReqlExpr) =
async {
return!
filter
.OrderBy(r.Desc "PublishedOn")
.Slice((pageNbr - 1) * nbrPerPage, pageNbr * nbrPerPage)
.RunResultAsync<Post list> conn
}
|> Async.RunSynchronously
/// Shorthand to get a newer or older post
let private adjacentPost conn (post : Post) (theFilter : ReqlExpr -> obj) (sort : obj) =
async {
let! post =
(publishedPosts post.WebLogId)
.Filter(theFilter)
.OrderBy(sort)
.Limit(1)
.RunResultAsync<Post list> conn
return List.tryHead post
}
|> Async.RunSynchronously
/// Find a newer post
let private newerPost conn post theFilter = adjacentPost conn post theFilter <| r.Asc "PublishedOn"
/// Find an older post
let private olderPost conn post theFilter = adjacentPost conn post theFilter <| r.Desc "PublishedOn"
/// Get a page of published posts
let findPageOfPublishedPosts conn webLogId pageNbr nbrPerPage =
publishedPosts webLogId
|> toPostList conn pageNbr nbrPerPage
/// Get a page of published posts assigned to a given category
let findPageOfCategorizedPosts conn webLogId (categoryId : string) pageNbr nbrPerPage =
(publishedPosts webLogId)
.Filter(ReqlFunction1 (fun p -> upcast p.["CategoryIds"].Contains categoryId))
|> toPostList conn pageNbr nbrPerPage
/// Get a page of published posts tagged with a given tag
let findPageOfTaggedPosts conn webLogId (tag : string) pageNbr nbrPerPage =
(publishedPosts webLogId)
.Filter(ReqlFunction1 (fun p -> upcast p.["Tags"].Contains tag))
|> toPostList conn pageNbr nbrPerPage
/// Try to get the next newest post from the given post
let tryFindNewerPost conn post = newerPost conn post (fun p -> upcast p.["PublishedOn"].Gt post.PublishedOn)
/// Try to get the next newest post assigned to the given category
let tryFindNewerCategorizedPost conn (categoryId : string) post =
newerPost conn post (fun p -> upcast p.["PublishedOn"].Gt(post.PublishedOn)
.And(p.["CategoryIds"].Contains categoryId))
/// Try to get the next newest tagged post from the given tagged post
let tryFindNewerTaggedPost conn (tag : string) post =
newerPost conn post (fun p -> upcast p.["PublishedOn"].Gt(post.PublishedOn).And(p.["Tags"].Contains tag))
/// Try to get the next oldest post from the given post
let tryFindOlderPost conn post = olderPost conn post (fun p -> upcast p.["PublishedOn"].Lt post.PublishedOn)
/// Try to get the next oldest post assigned to the given category
let tryFindOlderCategorizedPost conn (categoryId : string) post =
olderPost conn post (fun p -> upcast p.["PublishedOn"].Lt(post.PublishedOn)
.And(p.["CategoryIds"].Contains categoryId))
/// Try to get the next oldest tagged post from the given tagged post
let tryFindOlderTaggedPost conn (tag : string) post =
olderPost conn post (fun p -> upcast p.["PublishedOn"].Lt(post.PublishedOn).And(p.["Tags"].Contains tag))
/// Get a page of all posts in all statuses
let findPageOfAllPosts conn (webLogId : string) pageNbr nbrPerPage =
// FIXME: sort unpublished posts by their last updated date
async {
// .orderBy(r.desc(r.branch(r.row("Status").eq("Published"), r.row("PublishedOn"), r.row("UpdatedOn"))))
return!
r.Table(Table.Post)
.GetAll(webLogId).OptArg("index", "WebLogId")
.OrderBy(r.Desc (ReqlFunction1 (fun p ->
upcast r.Branch (p.["Status"].Eq("Published"), p.["PublishedOn"], p.["UpdatedOn"]))))
.Slice((pageNbr - 1) * nbrPerPage, pageNbr * nbrPerPage)
.RunResultAsync<Post list> conn
}
|> Async.RunSynchronously
/// Try to find a post by its Id and web log Id
let tryFindPost conn webLogId postId : Post option =
async {
let! p =
r.Table(Table.Post)
.Get(postId)
.RunAtomAsync<Post> conn
return
match box p with
| null -> None
| pst ->
let post : Post = unbox pst
match post.WebLogId = webLogId with true -> Some post | _ -> None
}
|> Async.RunSynchronously
/// Try to find a post by its permalink
let tryFindPostByPermalink conn webLogId permalink =
async {
let! post =
r.Table(Table.Post)
.GetAll(r.Array (webLogId, permalink)).OptArg("index", "Permalink")
.Filter(ReqlFunction1 (fun p -> upcast p.["Status"].Eq PostStatus.Published))
.Without("Revisions")
.Merge(ReqlFunction1 (fun p ->
upcast r.HashMap(
"Categories", r.Table(Table.Category)
.GetAll(r.Args p.["CategoryIds"])
.Without("Children")
.OrderBy("Name")
.CoerceTo("array")).With(
"Comments", r.Table(Table.Comment)
.GetAll(p.["id"]).OptArg("index", "PostId")
.OrderBy("PostedOn")
.CoerceTo("array"))))
.RunResultAsync<Post list> conn
return List.tryHead post
}
|> Async.RunSynchronously
/// Try to find a post by its prior permalink
let tryFindPostByPriorPermalink conn (webLogId : string) (permalink : string) =
async {
let! post =
r.Table(Table.Post)
.GetAll(webLogId).OptArg("index", "WebLogId")
.Filter(ReqlFunction1 (fun p ->
upcast p.["PriorPermalinks"].Contains(permalink).And(p.["Status"].Eq PostStatus.Published)))
.Without("Revisions")
.RunResultAsync<Post list> conn
return List.tryHead post
}
|> Async.RunSynchronously
/// Get a set of posts for RSS
let findFeedPosts conn webLogId nbr : (Post * User option) list =
let tryFindUser userId =
async {
let! u =
r.Table(Table.User)
.Get(userId)
.RunAtomAsync<User> conn
return match box u with null -> None | user -> Some <| unbox user
}
|> Async.RunSynchronously
(publishedPosts webLogId)
.Merge(ReqlFunction1 (fun post ->
upcast r.HashMap(
"Categories", r.Table(Table.Category)
.GetAll(r.Args post.["CategoryIds"])
.OrderBy("Name")
.Pluck("id", "Name")
.CoerceTo("array"))))
|> toPostList conn 1 nbr
|> List.map (fun post -> post, tryFindUser post.AuthorId)
/// Add a post
let addPost conn post =
async {
do! r.Table(Table.Post)
.Insert(post)
.RunResultAsync conn
}
|> (Async.RunSynchronously >> ignore)
/// Update a post
let updatePost conn (post : Post) =
async {
do! r.Table(Table.Post)
.Get(post.Id)
.Replace( { post with Categories = []
Comments = [] } )
.RunResultAsync conn
}
|> (Async.RunSynchronously >> ignore)
/// Save a post
let savePost conn (post : Post) =
match post.Id with
| "new" ->
let newPost = { post with Id = string <| System.Guid.NewGuid() }
async {
do! r.Table(Table.Post)
.Insert(newPost)
.RunResultAsync conn
}
|> Async.RunSynchronously
newPost.Id
| _ ->
async {
do! r.Table(Table.Post)
.Get(post.Id)
.Replace( { post with Categories = []
Comments = [] } )
.RunResultAsync conn
}
|> Async.RunSynchronously
post.Id

48
src/MyWebLog.App/Data/RethinkMyWebLogData.fs
View File

@@ -1,48 +0,0 @@
namespace MyWebLog.Data.RethinkDB
open MyWebLog.Data
open RethinkDb.Driver.Net
/// RethinkDB implementation of myWebLog data persistence
type RethinkMyWebLogData(conn : IConnection, cfg : DataConfig) =
interface IMyWebLogData with
member __.SetUp = fun () -> SetUp.startUpCheck cfg
member __.AllCategories = Category.getAllCategories conn
member __.CategoryById = Category.tryFindCategory conn
member __.CategoryBySlug = Category.tryFindCategoryBySlug conn
member __.AddCategory = Category.addCategory conn
member __.UpdateCategory = Category.updateCategory conn
member __.UpdateChildren = Category.updateChildren conn
member __.DeleteCategory = Category.deleteCategory conn
member __.PageById = Page.tryFindPageById conn
member __.PageByPermalink = Page.tryFindPageByPermalink conn
member __.AllPages = Page.findAllPages conn
member __.AddPage = Page.addPage conn
member __.UpdatePage = Page.updatePage conn
member __.DeletePage = Page.deletePage conn
member __.PageOfPublishedPosts = Post.findPageOfPublishedPosts conn
member __.PageOfCategorizedPosts = Post.findPageOfCategorizedPosts conn
member __.PageOfTaggedPosts = Post.findPageOfTaggedPosts conn
member __.NewerPost = Post.tryFindNewerPost conn
member __.NewerCategorizedPost = Post.tryFindNewerCategorizedPost conn
member __.NewerTaggedPost = Post.tryFindNewerTaggedPost conn
member __.OlderPost = Post.tryFindOlderPost conn
member __.OlderCategorizedPost = Post.tryFindOlderCategorizedPost conn
member __.OlderTaggedPost = Post.tryFindOlderTaggedPost conn
member __.PageOfAllPosts = Post.findPageOfAllPosts conn
member __.PostById = Post.tryFindPost conn
member __.PostByPermalink = Post.tryFindPostByPermalink conn
member __.PostByPriorPermalink = Post.tryFindPostByPriorPermalink conn
member __.FeedPosts = Post.findFeedPosts conn
member __.AddPost = Post.addPost conn
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

100
src/MyWebLog.App/Data/SetUp.fs
View File

@@ -1,100 +0,0 @@
module MyWebLog.Data.RethinkDB.SetUp
open RethinkDb.Driver.Ast
open System
let private r = RethinkDb.Driver.RethinkDB.R
let private logStep step = Console.Out.WriteLine (sprintf "[myWebLog] %s" step)
let private logStepStart text = Console.Out.Write (sprintf "[myWebLog] %s..." text)
let private logStepDone () = Console.Out.WriteLine (" done.")
/// Ensure the myWebLog database exists
let private checkDatabase (cfg : DataConfig) =
async {
logStep "|> Checking database"
let! dbs = r.DbList().RunResultAsync<string list> cfg.Conn
match List.contains cfg.Database dbs with
| true -> ()
| _ -> logStepStart (sprintf " %s database not found - creating" cfg.Database)
do! r.DbCreate(cfg.Database).RunResultAsync cfg.Conn
logStepDone ()
}
/// Ensure all required tables exist
let private checkTables cfg =
async {
logStep "|> Checking tables"
let! tables = r.Db(cfg.Database).TableList().RunResultAsync<string list> cfg.Conn
[ Table.Category; Table.Comment; Table.Page; Table.Post; Table.User; Table.WebLog ]
|> List.filter (fun tbl -> not (List.contains tbl tables))
|> List.iter (fun tbl -> logStepStart (sprintf " Creating table %s" tbl)
async { do! (r.TableCreate tbl).RunResultAsync cfg.Conn } |> Async.RunSynchronously
logStepDone ())
}
/// Shorthand to get the table
let private tbl cfg table = r.Db(cfg.Database).Table table
/// Create the given index
let private createIndex cfg table (index : string * (ReqlExpr -> obj) option) =
async {
let idxName, idxFunc = index
logStepStart (sprintf """ Creating index "%s" on table %s""" idxName table)
do! (match idxFunc with
| Some f -> (tbl cfg table).IndexCreate(idxName, f)
| None -> (tbl cfg table).IndexCreate(idxName))
.RunResultAsync cfg.Conn
logStepDone ()
}
/// Ensure that the given indexes exist, and create them if required
let private ensureIndexes cfg (indexes : (string * (string * (ReqlExpr -> obj) option) list) list) =
let ensureForTable (tblName, idxs) =
async {
let! idx = (tbl cfg tblName).IndexList().RunResultAsync<string list> cfg.Conn
idxs
|> List.filter (fun (idxName, _) -> not (List.contains idxName idx))
|> List.map (fun index -> createIndex cfg tblName index)
|> List.iter Async.RunSynchronously
}
|> Async.RunSynchronously
indexes
|> List.iter ensureForTable
/// Create an index on web log Id and the given field
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 private checkIndexes cfg =
logStep "|> Checking indexes"
[ Table.Category, [ "WebLogId", None
"Slug", webLogField "Slug"
]
Table.Comment, [ "PostId", None
]
Table.Page, [ "WebLogId", None
"Permalink", webLogField "Permalink"
]
Table.Post, [ "WebLogId", None
"WebLogAndStatus", webLogField "Status"
"Permalink", webLogField "Permalink"
]
Table.User, [ "UserName", None
]
Table.WebLog, [ "UrlBase", None
]
]
|> ensureIndexes cfg
/// Start up checks to ensure the database, tables, and indexes exist
let startUpCheck cfg =
async {
logStep "Database Start Up Checks Starting"
do! checkDatabase cfg
do! checkTables cfg
checkIndexes cfg
logStep "Database Start Up Checks Complete"
}
|> Async.RunSynchronously

21
src/MyWebLog.App/Data/Table.fs
View File

@@ -1,21 +0,0 @@
/// Constants for tables used in myWebLog
[<RequireQualifiedAccess>]
module MyWebLog.Data.RethinkDB.Table
/// The Category table
let Category = "Category"
/// The Comment table
let Comment = "Comment"
/// The Page table
let Page = "Page"
/// The Post table
let Post = "Post"
/// The WebLog table
let WebLog = "WebLog"
/// The User table
let User = "User"

31
src/MyWebLog.App/Data/User.fs
View File

@@ -1,31 +0,0 @@
module MyWebLog.Data.RethinkDB.User
open MyWebLog.Entities
open RethinkDb.Driver.Ast
let private r = RethinkDb.Driver.RethinkDB.R
/// Log on a user
// NOTE: The significant length of a RethinkDB index is 238 - [PK size]; as we're storing 1,024 characters of password,
// including it in an index does not get any performance gain, and would unnecessarily bloat the index. See
// http://rethinkdb.com/docs/secondary-indexes/java/ for more information.
let tryUserLogOn conn (email : string) (passwordHash : string) =
async {
let! user =
r.Table(Table.User)
.GetAll(email).OptArg("index", "UserName")
.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

39
src/MyWebLog.App/Data/WebLog.fs
View File

@@ -1,39 +0,0 @@
module MyWebLog.Data.RethinkDB.WebLog
open MyWebLog.Entities
open RethinkDb.Driver.Ast
let private r = RethinkDb.Driver.RethinkDB.R
/// Detemine the web log by the URL base
let tryFindWebLogByUrlBase conn (urlBase : string) =
async {
let! cursor =
r.Table(Table.WebLog)
.GetAll(urlBase).OptArg("index", "UrlBase")
.Merge(ReqlFunction1 (fun w ->
upcast r.HashMap(
"PageList", r.Table(Table.Page)
.GetAll(w.G("id")).OptArg("index", "WebLogId")
.Filter(ReqlFunction1 (fun pg -> upcast pg.["ShowInPageList"].Eq true))
.OrderBy("Title")
.Pluck("Title", "Permalink")
.CoerceTo("array"))))
.RunCursorAsync<WebLog> conn
return cursor |> Seq.tryHead
}
|> Async.RunSynchronously
/// Get counts for the admin dashboard
let findDashboardCounts conn (webLogId : string) =
async {
return!
r.Expr(
r.HashMap(
"Pages", r.Table(Table.Page ).GetAll(webLogId).OptArg("index", "WebLogId").Count()).With(
"Posts", r.Table(Table.Post ).GetAll(webLogId).OptArg("index", "WebLogId").Count()).With(
"Categories", r.Table(Table.Category).GetAll(webLogId).OptArg("index", "WebLogId").Count()))
.RunResultAsync<DashboardCounts> conn
}
|> Async.RunSynchronously

301
src/MyWebLog.App/Entities/Entities.fs
View File

@@ -1,301 +0,0 @@
namespace MyWebLog.Entities
open Newtonsoft.Json
// --- Constants ---
/// Constants to use for revision source language
[<RequireQualifiedAccess>]
module RevisionSource =
[<Literal>]
let Markdown = "markdown"
[<Literal>]
let HTML = "html"
/// Constants to use for authorization levels
[<RequireQualifiedAccess>]
module AuthorizationLevel =
[<Literal>]
let Administrator = "Administrator"
[<Literal>]
let User = "User"
/// Constants to use for post statuses
[<RequireQualifiedAccess>]
module PostStatus =
[<Literal>]
let Draft = "Draft"
[<Literal>]
let Published = "Published"
/// Constants to use for comment statuses
[<RequireQualifiedAccess>]
module CommentStatus =
[<Literal>]
let Approved = "Approved"
[<Literal>]
let Pending = "Pending"
[<Literal>]
let Spam = "Spam"
// --- Entities ---
/// A revision of a post or page
type Revision =
{ /// The instant which this revision was saved
AsOf : int64
/// The source language
SourceType : string
/// The text
Text : string }
with
/// An empty revision
static member Empty =
{ AsOf = int64 0
SourceType = RevisionSource.HTML
Text = "" }
/// A page with static content
type Page =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The Id of the web log to which this page belongs
WebLogId : string
/// The Id of the author of this page
AuthorId : string
/// The title of the page
Title : string
/// The link at which this page is displayed
Permalink : string
/// The instant this page was published
PublishedOn : int64
/// The instant this page was last updated
UpdatedOn : int64
/// Whether this page shows as part of the web log's navigation
ShowInPageList : bool
/// The current text of the page
Text : string
/// Revisions of this page
Revisions : Revision list }
with
static member Empty =
{ Id = ""
WebLogId = ""
AuthorId = ""
Title = ""
Permalink = ""
PublishedOn = int64 0
UpdatedOn = int64 0
ShowInPageList = false
Text = ""
Revisions = []
}
/// An entry in the list of pages displayed as part of the web log (derived via query)
type PageListEntry =
{ Permalink : string
Title : string }
/// A web log
type WebLog =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The name
Name : string
/// The subtitle
Subtitle : string option
/// The default page ("posts" or a page Id)
DefaultPage : string
/// The path of the theme (within /views/themes)
ThemePath : string
/// The URL base
UrlBase : string
/// The time zone in which dates/times should be displayed
TimeZone : string
/// A list of pages to be rendered as part of the site navigation (not stored)
PageList : PageListEntry list }
with
/// An empty web log
static member Empty =
{ Id = ""
Name = ""
Subtitle = None
DefaultPage = ""
ThemePath = "default"
UrlBase = ""
TimeZone = "America/New_York"
PageList = [] }
/// An authorization between a user and a web log
type Authorization =
{ /// The Id of the web log to which this authorization grants access
WebLogId : string
/// The level of access granted by this authorization
Level : string }
/// A user of myWebLog
type User =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The user name (e-mail address)
UserName : string
/// The first name
FirstName : string
/// The last name
LastName : string
/// The user's preferred name
PreferredName : string
/// The hash of the user's password
PasswordHash : string
/// The URL of the user's personal site
Url : string option
/// The user's authorizations
Authorizations : Authorization list }
with
/// An empty user
static member Empty =
{ Id = ""
UserName = ""
FirstName = ""
LastName = ""
PreferredName = ""
PasswordHash = ""
Url = None
Authorizations = [] }
/// Claims for this user
[<JsonIgnore>]
member this.Claims = this.Authorizations
|> List.map (fun auth -> sprintf "%s|%s" auth.WebLogId auth.Level)
/// A category to which posts may be assigned
type Category =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The Id of the web log to which this category belongs
WebLogId : string
/// The displayed name
Name : string
/// The slug (used in category URLs)
Slug : string
/// A longer description of the category
Description : string option
/// The parent Id of this category (if a subcategory)
ParentId : string option
/// The categories for which this category is the parent
Children : string list }
with
/// An empty category
static member Empty =
{ Id = "new"
WebLogId = ""
Name = ""
Slug = ""
Description = None
ParentId = None
Children = [] }
/// A comment (applies to a post)
type Comment =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The Id of the post to which this comment applies
PostId : string
/// The Id of the comment to which this comment is a reply
InReplyToId : string option
/// The name of the commentor
Name : string
/// The e-mail address of the commentor
Email : string
/// The URL of the commentor's personal website
Url : string option
/// The status of the comment
Status : string
/// The instant the comment was posted
PostedOn : int64
/// The text of the comment
Text : string }
with
static member Empty =
{ Id = ""
PostId = ""
InReplyToId = None
Name = ""
Email = ""
Url = None
Status = CommentStatus.Pending
PostedOn = int64 0
Text = "" }
/// A post
type Post =
{ /// The Id
[<JsonProperty("id")>]
Id : string
/// The Id of the web log to which this post belongs
WebLogId : string
/// The Id of the author of this post
AuthorId : string
/// The status
Status : string
/// The title
Title : string
/// The link at which the post resides
Permalink : string
/// The instant on which the post was originally published
PublishedOn : int64
/// The instant on which the post was last updated
UpdatedOn : int64
/// The text of the post
Text : string
/// The Ids of the categories to which this is assigned
CategoryIds : string list
/// The tags for the post
Tags : string list
/// The permalinks at which this post may have once resided
PriorPermalinks : string list
/// Revisions of this post
Revisions : Revision list
/// The categories to which this is assigned (not stored in database)
Categories : Category list
/// The comments (not stored in database)
Comments : Comment list }
with
static member Empty =
{ Id = "new"
WebLogId = ""
AuthorId = ""
Status = PostStatus.Draft
Title = ""
Permalink = ""
PublishedOn = int64 0
UpdatedOn = int64 0
Text = ""
CategoryIds = []
Tags = []
PriorPermalinks = []
Revisions = []
Categories = []
Comments = [] }
// --- UI Support ---
/// Counts of items displayed on the admin dashboard
type DashboardCounts =
{ /// The number of pages for the web log
Pages : int
/// The number of pages for the web log
Posts : int
/// The number of categories for the web log
Categories : int }

117
src/MyWebLog.App/Entities/IMyWebLogData.fs
View File

@@ -1,117 +0,0 @@
namespace MyWebLog.Data
open MyWebLog.Entities
/// Interface required to provide data to myWebLog's logic layer
type IMyWebLogData =
/// Function to set up the data store
abstract SetUp : (unit -> unit)
// --- Category ---
/// Get all categories for a web log
abstract AllCategories : (string -> Category list)
/// Try to find a category by its Id and web log Id (web log, category Ids)
abstract CategoryById : (string -> string -> Category option)
/// Try to find a category by its slug (web log Id, slug)
abstract CategoryBySlug : (string -> string -> Category option)
/// Add a category
abstract AddCategory : (Category -> unit)
/// Update a category
abstract UpdateCategory : (Category -> unit)
/// Update a category's children
abstract UpdateChildren : (string -> string -> string list -> unit)
/// Delete a Category
abstract DeleteCategory : (Category -> unit)
// --- Page ---
/// Try to find a page by its Id and web log Id (web log, page Ids), choosing whether to include revisions
abstract PageById : (string -> string -> bool -> Page option)
/// Try to find a page by its permalink and web log Id (web log Id, permalink)
abstract PageByPermalink : (string -> string -> Page option)
/// Get all pages for a web log
abstract AllPages : (string -> Page list)
/// Add a page
abstract AddPage : (Page -> unit)
/// Update a page
abstract UpdatePage : (Page -> unit)
/// Delete a page by its Id and web log Id (web log, page Ids)
abstract DeletePage : (string -> string -> unit)
// --- Post ---
/// Find a page of published posts for the given web log (web log Id, page #, # per page)
abstract PageOfPublishedPosts : (string -> int -> int -> Post list)
/// Find a page of published posts within a given category (web log Id, cat Id, page #, # per page)
abstract PageOfCategorizedPosts : (string -> string -> int -> int -> Post list)
/// Find a page of published posts tagged with a given tag (web log Id, tag, page #, # per page)
abstract PageOfTaggedPosts : (string -> string -> int -> int -> Post list)
/// Try to find the next newer published post for the given post
abstract NewerPost : (Post -> Post option)
/// Try to find the next newer published post within a given category
abstract NewerCategorizedPost : (string -> Post -> Post option)
/// Try to find the next newer published post tagged with a given tag
abstract NewerTaggedPost : (string -> Post -> Post option)
/// Try to find the next older published post for the given post
abstract OlderPost : (Post -> Post option)
/// Try to find the next older published post within a given category
abstract OlderCategorizedPost : (string -> Post -> Post option)
/// Try to find the next older published post tagged with a given tag
abstract OlderTaggedPost : (string -> Post -> Post option)
/// Find a page of all posts for the given web log (web log Id, page #, # per page)
abstract PageOfAllPosts : (string -> int -> int -> Post list)
/// Try to find a post by its Id and web log Id (web log, post Ids)
abstract PostById : (string -> string -> Post option)
/// Try to find a post by its permalink (web log Id, permalink)
abstract PostByPermalink : (string -> string -> Post option)
/// Try to find a post by a prior permalink (web log Id, permalink)
abstract PostByPriorPermalink : (string -> string -> Post option)
/// Get posts for the RSS feed for the given web log and number of posts
abstract FeedPosts : (string -> int -> (Post * User option) list)
/// Add a post
abstract AddPost : (Post -> unit)
/// Update a post
abstract UpdatePost : (Post -> unit)
// --- User ---
/// 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
abstract WebLogByUrlBase : (string -> WebLog option)
/// Get dashboard counts for a web log
abstract DashboardCounts : (string -> DashboardCounts)

17
src/MyWebLog.App/Keys.fs
View File

@@ -1,17 +0,0 @@
[<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"

56
src/MyWebLog.App/Logic/Category.fs
View File

@@ -1,56 +0,0 @@
module MyWebLog.Logic.Category
open MyWebLog.Data
open MyWebLog.Entities
/// Sort categories by their name, with their children sorted below them, including an indent level
let sortCategories categories =
let rec getChildren (cat : Category) indent =
seq {
yield cat, indent
for child in categories |> List.filter (fun c -> c.ParentId = Some cat.Id) do
yield! getChildren child (indent + 1)
}
categories
|> List.filter (fun c -> c.ParentId.IsNone)
|> List.map (fun c -> getChildren c 0)
|> Seq.collect id
|> Seq.toList
/// Find all categories for a given web log
let findAllCategories (data : IMyWebLogData) webLogId =
data.AllCategories webLogId
|> sortCategories
/// Try to find a category for a given web log Id and category Id
let tryFindCategory (data : IMyWebLogData) webLogId catId = data.CategoryById webLogId catId
/// Try to find a category by its slug for a given web log
let tryFindCategoryBySlug (data : IMyWebLogData) webLogId slug = data.CategoryBySlug webLogId slug
/// Save a category
let saveCategory (data : IMyWebLogData) (cat : Category) =
match cat.Id with
| "new" -> let newCat = { cat with Id = string <| System.Guid.NewGuid() }
data.AddCategory newCat
newCat.Id
| _ -> data.UpdateCategory cat
cat.Id
/// Remove a category from its parent
let removeCategoryFromParent (data : IMyWebLogData) webLogId parentId catId =
match tryFindCategory data webLogId parentId with
| Some parent -> parent.Children
|> List.filter (fun childId -> childId <> catId)
|> data.UpdateChildren webLogId parentId
| None -> ()
/// Add a category to a given parent
let addCategoryToParent (data : IMyWebLogData) webLogId parentId catId =
match tryFindCategory data webLogId parentId with
| Some parent -> catId :: parent.Children
|> data.UpdateChildren webLogId parentId
| None -> ()
/// Delete a category
let deleteCategory (data : IMyWebLogData) cat = data.DeleteCategory cat

29
src/MyWebLog.App/Logic/Page.fs
View File

@@ -1,29 +0,0 @@
/// Logic for manipulating <see cref="Page" /> entities
module MyWebLog.Logic.Page
open MyWebLog.Data
open MyWebLog.Entities
/// Find a page by its Id and web log Id
let tryFindPage (data : IMyWebLogData) webLogId pageId = data.PageById webLogId pageId true
/// Find a page by its Id and web log Id, without the revision list
let tryFindPageWithoutRevisions (data : IMyWebLogData) webLogId pageId = data.PageById webLogId pageId false
/// Find a page by its permalink
let tryFindPageByPermalink (data : IMyWebLogData) webLogId permalink = data.PageByPermalink webLogId permalink
/// Find a list of all pages (excludes text and revisions)
let findAllPages (data : IMyWebLogData) webLogId = data.AllPages webLogId
/// Save a page
let savePage (data : IMyWebLogData) (page : Page) =
match page.Id with
| "new" -> let newPg = { page with Id = string <| System.Guid.NewGuid () }
data.AddPage newPg
newPg.Id
| _ -> data.UpdatePage page
page.Id
/// Delete a page
let deletePage (data : IMyWebLogData) webLogId pageId = data.DeletePage webLogId pageId

60
src/MyWebLog.App/Logic/Post.fs
View File

@@ -1,60 +0,0 @@
/// Logic for manipulating <see cref="Post" /> entities
module MyWebLog.Logic.Post
open MyWebLog.Data
open MyWebLog.Entities
/// Find a page of published posts
let findPageOfPublishedPosts (data : IMyWebLogData) webLogId pageNbr nbrPerPage =
data.PageOfPublishedPosts webLogId pageNbr nbrPerPage
/// Find a pages of published posts in a given category
let findPageOfCategorizedPosts (data : IMyWebLogData) webLogId catId pageNbr nbrPerPage =
data.PageOfCategorizedPosts webLogId catId pageNbr nbrPerPage
/// Find a page of published posts tagged with a given tag
let findPageOfTaggedPosts (data : IMyWebLogData) webLogId tag pageNbr nbrPerPage =
data.PageOfTaggedPosts webLogId tag pageNbr nbrPerPage
/// Find the next newer published post for the given post
let tryFindNewerPost (data : IMyWebLogData) post = data.NewerPost post
/// Find the next newer published post in a given category for the given post
let tryFindNewerCategorizedPost (data : IMyWebLogData) catId post = data.NewerCategorizedPost catId post
/// Find the next newer published post tagged with a given tag for the given post
let tryFindNewerTaggedPost (data : IMyWebLogData) tag post = data.NewerTaggedPost tag post
/// Find the next older published post for the given post
let tryFindOlderPost (data : IMyWebLogData) post = data.OlderPost post
/// Find the next older published post in a given category for the given post
let tryFindOlderCategorizedPost (data : IMyWebLogData) catId post = data.OlderCategorizedPost catId post
/// Find the next older published post tagged with a given tag for the given post
let tryFindOlderTaggedPost (data : IMyWebLogData) tag post = data.OlderTaggedPost tag post
/// Find a page of all posts for a web log
let findPageOfAllPosts (data : IMyWebLogData) webLogId pageNbr nbrPerPage =
data.PageOfAllPosts webLogId pageNbr nbrPerPage
/// Try to find a post by its Id
let tryFindPost (data : IMyWebLogData) webLogId postId = data.PostById webLogId postId
/// Try to find a post by its permalink
let tryFindPostByPermalink (data : IMyWebLogData) webLogId permalink = data.PostByPermalink webLogId permalink
/// Try to find a post by its prior permalink
let tryFindPostByPriorPermalink (data : IMyWebLogData) webLogId permalink = data.PostByPriorPermalink webLogId permalink
/// Find posts for the RSS feed
let findFeedPosts (data : IMyWebLogData) webLogId nbrOfPosts = data.FeedPosts webLogId nbrOfPosts
/// Save a post
let savePost (data : IMyWebLogData) (post : Post) =
match post.Id with
| "new" -> let newPost = { post with Id = string <| System.Guid.NewGuid() }
data.AddPost newPost
newPost.Id
| _ -> data.UpdatePost post
post.Id

9
src/MyWebLog.App/Logic/User.fs
View File

@@ -1,9 +0,0 @@
/// Logic for manipulating <see cref="User" /> entities
module MyWebLog.Logic.User
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

11
src/MyWebLog.App/Logic/WebLog.fs
View File

@@ -1,11 +0,0 @@
/// Logic for manipulating <see cref="WebLog" /> entities
module MyWebLog.Logic.WebLog
open MyWebLog.Data
open MyWebLog.Entities
/// Find a web log by its URL base
let tryFindWebLogByUrlBase (data : IMyWebLogData) urlBase = data.WebLogByUrlBase urlBase
/// Find the counts for the admin dashboard
let findDashboardCounts (data : IMyWebLogData) webLogId = data.DashboardCounts webLogId

22
src/MyWebLog.App/Modules/AdminModule.fs
View File

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

97
src/MyWebLog.App/Modules/CategoryModule.fs
View File

@@ -1,97 +0,0 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Logic.Category
open MyWebLog.Entities
open MyWebLog.Resources
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open RethinkDb.Driver.Net
/// Handle /category and /categories URLs
type CategoryModule (data : IMyWebLogData) as this =
inherit NancyModule ()
do
this.Get ("/categories", fun _ -> this.CategoryList ())
this.Get ("/category/{id}/edit", fun p -> this.EditCategory (downcast p))
this.Post ("/category/{id}/edit", fun p -> this.SaveCategory (downcast p))
this.Post ("/category/{id}/delete", fun p -> this.DeleteCategory (downcast p))
/// 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)))
model.PageTitle <- Strings.get "Categories"
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 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 c ->
IndentedCategory.Create c (fun catId -> catId = defaultArg cat.ParentId ""))
model.PageTitle <- Strings.get <| match catId with "new" -> "AddNewCategory" | _ -> "EditCategory"
upcast this.View.["admin/category/edit", model]
| _ -> this.NotFound ()
/// Save a category
member this.SaveCategory (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
let form = this.Bind<CategoryForm> ()
match catId with
| "new" -> Some { Category.Empty with WebLogId = this.WebLog.Id }
| _ -> tryFindCategory data this.WebLog.Id catId
|> 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
| Some parentId -> removeCategoryFromParent data this.WebLog.Id parentId newCatId
| _ -> ()
match cat.ParentId with
| Some parentId -> addCategoryToParent data this.WebLog.Id parentId newCatId
| _ -> ()
let model = MyWebLogModel (this.Context, this.WebLog)
model.AddMessage
{ UserMessage.Empty with
Message = System.String.Format
(Strings.get "MsgCategoryEditSuccess",
Strings.get (match catId with "new" -> "Added" | _ -> "Updated"))
}
this.Redirect (sprintf "/category/%s/edit" newCatId) model
| _ -> this.NotFound ()
/// Delete a category
member this.DeleteCategory (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let catId = parameters.["id"].ToString ()
match tryFindCategory data this.WebLog.Id catId with
| Some cat ->
deleteCategory data cat
let model = MyWebLogModel (this.Context, this.WebLog)
model.AddMessage
{ UserMessage.Empty with Message = System.String.Format(Strings.get "MsgCategoryDeleted", cat.Name) }
this.Redirect "/categories" model
| _ -> this.NotFound ()

36
src/MyWebLog.App/Modules/ModuleExtensions.fs
View File

@@ -1,36 +0,0 @@
[<AutoOpen>]
module MyWebLog.ModuleExtensions
open MyWebLog.Entities
open Nancy
open Nancy.Security
open System
open System.Security.Claims
/// Parent class for all myWebLog Nancy modules
type NancyModule with
/// Strongly-typed access to the web log for the current request
member this.WebLog = this.Context.Items.[Keys.WebLog] :?> WebLog
/// Display a view using the theme specified for the web log
member this.ThemedView view (model : MyWebLogModel) : obj =
upcast this.View.[(sprintf "themes/%s/%s" this.WebLog.ThemePath view), model]
/// Return a 404
member this.NotFound () : obj = upcast HttpStatusCode.NotFound
/// Redirect a request, storing messages in the session if they exist
member this.Redirect url (model : MyWebLogModel) : obj =
match List.length model.Messages with
| 0 -> ()
| _ -> this.Session.[Keys.Messages] <- model.Messages
// 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 = Predicate<Claim> (fun claim ->
claim.Type = ClaimTypes.Role && claim.Value = sprintf "%s|%s" this.WebLog.Id level)
this.RequiresAuthentication ()
this.RequiresClaims [| findClaim |]

97
src/MyWebLog.App/Modules/PageModule.fs
View File

@@ -1,97 +0,0 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.Page
open MyWebLog.Resources
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open NodaTime
open RethinkDb.Driver.Net
/// Handle /pages and /page URLs
type PageModule (data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule ()
do
this.Get ("/pages", fun _ -> this.PageList ())
this.Get ("/page/{id}/edit", fun p -> this.EditPage (downcast p))
this.Post ("/page/{id}/edit", fun p -> this.SavePage (downcast p))
this.Delete ("/page/{id}/delete", fun p -> this.DeletePage (downcast p))
/// 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)))
model.PageTitle <- Strings.get "Pages"
upcast this.View.["admin/page/list", model]
/// Edit a page
member this.EditPage (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
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
|> List.sortByDescending (fun r -> r.AsOf)
|> List.tryHead with
| Some r -> r
| _ -> Revision.Empty
let model = EditPageModel (this.Context, this.WebLog, page, rev)
model.PageTitle <- Strings.get <| match pageId with "new" -> "AddNewPage" | _ -> "EditPage"
upcast this.View.["admin/page/edit", model]
| _ -> this.NotFound ()
/// Save a page
member this.SavePage (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken ()
this.RequiresAccessLevel AuthorizationLevel.Administrator
let pageId = parameters.["id"].ToString ()
let form = this.Bind<EditPageForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
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
PublishedOn = match pageId with "new" -> now | _ -> page.PublishedOn
UpdatedOn = now
ShowInPageList = form.ShowInPageList
Text = match form.Source with
| RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text
| _ -> form.Text
Revisions = { AsOf = now
SourceType = form.Source
Text = form.Text
} :: page.Revisions
}
|> savePage data
let model = MyWebLogModel (this.Context, this.WebLog)
model.AddMessage
{ UserMessage.Empty with
Message = System.String.Format
(Strings.get "MsgPageEditSuccess",
Strings.get (match pageId with "new" -> "Added" | _ -> "Updated"))
}
this.Redirect (sprintf "/page/%s/edit" pId) model
| _ -> this.NotFound ()
/// Delete a page
member this.DeletePage (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken ()
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
let model = MyWebLogModel (this.Context, this.WebLog)
model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgPageDeleted" }
this.Redirect "/pages" model
| _ -> this.NotFound ()

317
src/MyWebLog.App/Modules/PostModule.fs
View File

@@ -1,317 +0,0 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.Category
open MyWebLog.Logic.Page
open MyWebLog.Logic.Post
open MyWebLog.Resources
open Nancy
open Nancy.ModelBinding
open Nancy.Security
open Nancy.Session.Persistable
open NodaTime
open RethinkDb.Driver.Net
open System
open System.Xml.Linq
type NewsItem =
{ Title : string
Link : string
ReleaseDate : DateTime
Description : string
}
/// Routes dealing with posts (including the home page, /tag, /category, RSS, and catch-all routes)
type PostModule (data : IMyWebLogData, clock : IClock) as this =
inherit NancyModule ()
/// Get the page number from the dictionary
let getPage (parameters : DynamicDictionary) =
match parameters.ContainsKey "page" with
| true -> match System.Int32.TryParse (parameters.["page"].ToString ()) with true, pg -> pg | _ -> 1
| _ -> 1
/// Convert a list of posts to a list of posts for display
let forDisplay posts = posts |> List.map (fun post -> PostForDisplay (this.WebLog, post))
/// Generate an RSS/Atom feed of the latest posts
let generateFeed format : obj =
let myChannelFeed channelTitle channelLink channelDescription (items : NewsItem list) =
let xn = XName.Get
let elem name (valu : string) = XElement (xn name, valu)
let elems =
items
|> List.sortByDescending (fun i -> i.ReleaseDate)
|> List.map (fun i ->
XElement (
xn "item",
elem "title" (System.Net.WebUtility.HtmlEncode i.Title),
elem "link" i.Link,
elem "guid" i.Link,
elem "pubDate" (i.ReleaseDate.ToString "r"),
elem "description" (System.Net.WebUtility.HtmlEncode i.Description)
))
XDocument (
XDeclaration ("1.0", "utf-8", "yes"),
XElement (
xn "rss",
XAttribute (xn "version", "2.0"),
elem "title" channelTitle,
elem "link" channelLink,
elem "description" (defaultArg channelDescription ""),
elem "language" "en-us",
XElement (xn "channel", elems))
|> box)
let schemeAndUrl = sprintf "%s://%s" this.Request.Url.Scheme this.WebLog.UrlBase
let feed =
findFeedPosts data this.WebLog.Id 10
|> List.map (fun (post, _) ->
{ Title = post.Title
Link = sprintf "%s/%s" schemeAndUrl post.Permalink
ReleaseDate = Instant.FromUnixTimeTicks(post.PublishedOn).ToDateTimeOffset().DateTime
Description = post.Text
})
|> myChannelFeed this.WebLog.Name schemeAndUrl this.WebLog.Subtitle
let stream = new IO.MemoryStream ()
Xml.XmlWriter.Create stream |> feed.Save
//|> match format with "atom" -> feed.SaveAsAtom10 | _ -> feed.SaveAsRss20
stream.Position <- 0L
upcast this.Response.FromStream (stream, sprintf "application/%s+xml" format)
// TODO: how to return this?
(*
let feed =
SyndicationFeed(
this.WebLog.Name, defaultArg this.WebLog.Subtitle null,
Uri(sprintf "%s://%s" this.Request.Url.Scheme this.WebLog.UrlBase), null,
(match posts |> List.tryHead with
| Some (post, _) -> Instant(post.UpdatedOn).ToDateTimeOffset ()
| _ -> System.DateTimeOffset(System.DateTime.MinValue)),
posts
|> List.map (fun (post, user) ->
let item =
SyndicationItem(
BaseUri = Uri(sprintf "%s://%s/%s" this.Request.Url.Scheme this.WebLog.UrlBase post.Permalink),
PublishDate = Instant(post.PublishedOn).ToDateTimeOffset (),
LastUpdatedTime = Instant(post.UpdatedOn).ToDateTimeOffset (),
Title = TextSyndicationContent(post.Title),
Content = TextSyndicationContent(post.Text, TextSyndicationContentKind.Html))
user
|> Option.iter (fun u -> item.Authors.Add
(SyndicationPerson(u.UserName, u.PreferredName, defaultArg u.Url null)))
post.Categories
|> List.iter (fun c -> item.Categories.Add(SyndicationCategory(c.Name)))
item))
let stream = new IO.MemoryStream()
Xml.XmlWriter.Create(stream)
|> match format with "atom" -> feed.SaveAsAtom10 | _ -> feed.SaveAsRss20
stream.Position <- int64 0
upcast this.Response.FromStream(stream, sprintf "application/%s+xml" format) *)
do
this.Get ("/", fun _ -> this.HomePage ())
this.Get ("/{permalink*}", fun p -> this.CatchAll (downcast p))
this.Get ("/posts/page/{page:int}", fun p -> this.PublishedPostsPage (getPage <| downcast p))
this.Get ("/category/{slug}", fun p -> this.CategorizedPosts (downcast p))
this.Get ("/category/{slug}/page/{page:int}", fun p -> this.CategorizedPosts (downcast p))
this.Get ("/tag/{tag}", fun p -> this.TaggedPosts (downcast p))
this.Get ("/tag/{tag}/page/{page:int}", fun p -> this.TaggedPosts (downcast p))
this.Get ("/feed", fun _ -> this.Feed ())
this.Get ("/posts/list", fun _ -> this.PostList 1)
this.Get ("/posts/list/page/{page:int}", fun p -> this.PostList (getPage <| downcast p))
this.Get ("/post/{postId}/edit", fun p -> this.EditPost (downcast p))
this.Post ("/post/{postId}/edit", fun p -> this.SavePost (downcast p))
// ---- Display posts to users ----
/// Display a page of published posts
member this.PublishedPostsPage pageNbr : obj =
let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfPublishedPosts data this.WebLog.Id pageNbr 10 |> forDisplay
model.HasNewer <- match pageNbr with
| 1 -> false
| _ -> match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerPost data (List.last model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderPost data (List.head model.Posts).Post
model.UrlPrefix <- "/posts"
model.PageTitle <- match pageNbr with 1 -> "" | _ -> sprintf "%s%i" (Strings.get "PageHash") pageNbr
this.ThemedView "index" model
/// Display either the newest posts or the configured home page
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)
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
member this.CatchAll (parameters : DynamicDictionary) : obj =
let url = parameters.["permalink"].ToString ()
match tryFindPostByPermalink data this.WebLog.Id url with
| Some post -> // Hopefully the most common result; the permalink is a permalink!
let model = PostModel(this.Context, this.WebLog, post)
model.NewerPost <- tryFindNewerPost data post
model.OlderPost <- tryFindOlderPost data post
model.PageTitle <- post.Title
this.ThemedView "single" model
| _ -> // Maybe it's a page permalink instead...
match tryFindPageByPermalink data 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
| _ -> // Maybe it's an old permalink for a post
match tryFindPostByPriorPermalink data this.WebLog.Id url with
| Some post -> // Redirect them to the proper permalink
upcast this.Response.AsRedirect(sprintf "/%s" post.Permalink)
.WithStatusCode HttpStatusCode.MovedPermanently
| _ -> this.NotFound ()
/// Display categorized posts
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
let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfCategorizedPosts data this.WebLog.Id cat.Id pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerCategorizedPost data cat.Id
(List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderCategorizedPost data 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
| _ -> sprintf "Posts in the \"%s\" category" cat.Name
this.ThemedView "index" model
| _ -> this.NotFound ()
/// Display tagged posts
member this.TaggedPosts (parameters : DynamicDictionary) : obj =
let tag = parameters.["tag"].ToString ()
let pageNbr = getPage parameters
let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfTaggedPosts data this.WebLog.Id tag pageNbr 10 |> forDisplay
model.HasNewer <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindNewerTaggedPost data tag (List.head model.Posts).Post
model.HasOlder <- match List.isEmpty model.Posts with
| true -> false
| _ -> Option.isSome <| tryFindOlderTaggedPost data 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.Subtitle <- Some <| sprintf "Posts tagged \"%s\"" tag
this.ThemedView "index" model
/// Generate an RSS feed
member this.Feed () : obj =
let query = this.Request.Query :?> DynamicDictionary
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"
// ---- Administer posts ----
/// Display a page of posts in the admin area
member this.PostList pageNbr : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let model = PostsModel (this.Context, this.WebLog)
model.PageNbr <- pageNbr
model.Posts <- findPageOfAllPosts data this.WebLog.Id pageNbr 25 |> forDisplay
model.HasNewer <- pageNbr > 1
model.HasOlder <- List.length model.Posts > 24
model.UrlPrefix <- "/posts/list"
model.PageTitle <- Strings.get "Posts"
upcast this.View.["admin/post/list", model]
/// Edit a post
member this.EditPost (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
let postId = parameters.["postId"].ToString ()
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
| None -> Revision.Empty
let model = EditPostModel (this.Context, this.WebLog, post, rev)
model.Categories <- findAllCategories data this.WebLog.Id
|> List.map (fun cat ->
DisplayCategory.Create cat (post.CategoryIds |> List.contains (fst cat).Id))
model.PageTitle <- Strings.get <| match post.Id with "new" -> "AddNewPost" | _ -> "EditPost"
upcast this.View.["admin/post/edit", model]
| _ -> this.NotFound ()
/// Save a post
member this.SavePost (parameters : DynamicDictionary) : obj =
this.RequiresAccessLevel AuthorizationLevel.Administrator
this.ValidateCsrfToken ()
let postId = parameters.["postId"].ToString ()
let form = this.Bind<EditPostForm> ()
let now = clock.GetCurrentInstant().ToUnixTimeTicks ()
match postId with "new" -> Some Post.Empty | _ -> tryFindPost data this.WebLog.Id postId
|> function
| Some p ->
let justPublished = p.PublishedOn = 0L && 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
Title = form.Title
Permalink = form.Permalink
PublishedOn = match justPublished with true -> now | _ -> post.PublishedOn
UpdatedOn = now
Text = match form.Source with
| RevisionSource.Markdown -> (* Markdown.TransformHtml *) form.Text
| _ -> form.Text
CategoryIds = Array.toList form.Categories
Tags = form.Tags.Split ','
|> Seq.map (fun t -> t.Trim().ToLowerInvariant ())
|> Seq.sort
|> Seq.toList
Revisions = { AsOf = now
SourceType = form.Source
Text = form.Text } :: post.Revisions }
|> savePost data
let model = MyWebLogModel(this.Context, this.WebLog)
model.AddMessage
{ UserMessage.Empty with
Message = System.String.Format
(Strings.get "MsgPostEditSuccess",
Strings.get (match postId with "new" -> "Added" | _ -> "Updated"),
(match justPublished with true -> Strings.get "AndPublished" | _ -> ""))
}
this.Redirect (sprintf "/post/%s/edit" pId) model
| _ -> this.NotFound ()

64
src/MyWebLog.App/Modules/UserModule.fs
View File

@@ -1,64 +0,0 @@
namespace MyWebLog
open MyWebLog.Data
open MyWebLog.Entities
open MyWebLog.Logic.User
open MyWebLog.Resources
open Nancy
open Nancy.Authentication.Forms
open Nancy.Cryptography
open Nancy.ModelBinding
open Nancy.Security
open Nancy.Session.Persistable
open RethinkDb.Driver.Net
open System.Text
/// Handle /user URLs
type UserModule (data : IMyWebLogData, cfg : AppConfig) as this =
inherit NancyModule ("/user")
/// Hash the user's password
let pbkdf2 (pw : string) =
PassphraseKeyGenerator(pw, cfg.PasswordSalt, 4096).GetBytes 512
|> Seq.fold (fun acc byt -> sprintf "%s%s" acc (byt.ToString "x2")) ""
do
this.Get ("/log-on", fun _ -> this.ShowLogOn ())
this.Post ("/log-on", fun p -> this.DoLogOn (downcast p))
this.Get ("/log-off", fun _ -> this.LogOff ())
/// Show the log on page
member this.ShowLogOn () : obj =
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.PageTitle <- Strings.get "LogOn"
upcast this.View.["admin/user/log-on", model]
/// Process a user log on
member this.DoLogOn (parameters : DynamicDictionary) : obj =
this.ValidateCsrfToken ()
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
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
Message = Strings.get "ErrBadLogOnAttempt" }
|> model.AddMessage
this.Redirect (sprintf "/user/log-on?returnUrl=%s" form.ReturnUrl) model
/// Log a user off
member this.LogOff () : obj =
this.Session.DeleteAll ()
let model = MyWebLogModel (this.Context, this.WebLog)
model.AddMessage { UserMessage.Empty with Message = Strings.get "MsgLogOffSuccess" }
this.Redirect "" model |> ignore
upcast this.LogoutAndRedirect "/"

21
src/MyWebLog.App/MyWebLog.App.xproj
View File

@@ -1,21 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<Project ToolsVersion="14.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<VisualStudioVersion Condition="'$(VisualStudioVersion)' == ''">14.0</VisualStudioVersion>
<VSToolsPath Condition="'$(VSToolsPath)' == ''">$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)</VSToolsPath>
</PropertyGroup>
<Import Project="$(VSToolsPath)\DotNet\Microsoft.DotNet.Props" Condition="'$(VSToolsPath)' != ''" />
<PropertyGroup Label="Globals">
<ProjectGuid>9cea3a8b-e8aa-44e6-9f5f-2095ceed54eb</ProjectGuid>
<RootNamespace>Nancy.Session.Persistable</RootNamespace>
<BaseIntermediateOutputPath Condition="'$(BaseIntermediateOutputPath)'=='' ">.\obj</BaseIntermediateOutputPath>
<OutputPath Condition="'$(OutputPath)'=='' ">.\bin\</OutputPath>
<TargetFrameworkVersion>v4.5.2</TargetFrameworkVersion>
</PropertyGroup>
<PropertyGroup>
<SchemaVersion>2.0</SchemaVersion>
</PropertyGroup>
<Import Project="$(VSToolsPath)\DotNet\Microsoft.DotNet.targets" Condition="'$(VSToolsPath)' != ''" />
</Project>

42
src/MyWebLog.App/Strings.fs
View File

@@ -1,42 +0,0 @@
module MyWebLog.Resources.Strings
open MyWebLog
open Newtonsoft.Json
open System.Collections.Generic
open System.Reflection
/// The locales we'll try to load
let private supportedLocales = [ "en-US" ]
/// The fallback locale, if a key is not found in a non-default locale
let private fallbackLocale = "en-US"
/// Get an embedded JSON file as a string
let private getEmbedded locale =
use rdr =
new System.IO.StreamReader
(typeof<AppConfig>.GetTypeInfo().Assembly.GetManifestResourceStream(sprintf "MyWebLog.App.%s.json" locale))
rdr.ReadToEnd()
/// The dictionary of localized strings
let private strings =
supportedLocales
|> List.map (fun loc -> loc, JsonConvert.DeserializeObject<Dictionary<string, string>>(getEmbedded loc))
|> dict
/// Get a key from the resources file for the given locale
let getForLocale locale key =
let getString thisLocale =
match strings.ContainsKey thisLocale with
| true -> match strings.[thisLocale].ContainsKey key with
| true -> Some strings.[thisLocale].[key]
| _ -> None
| _ -> None
match getString locale with
| Some xlat -> Some xlat
| _ when locale <> fallbackLocale -> getString fallbackLocale
| _ -> None
|> function Some xlat -> xlat | _ -> sprintf "%s.%s" locale key
/// Translate the key for the current locale
let get key = getForLocale System.Globalization.CultureInfo.CurrentCulture.Name key

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

@@ -1,504 +0,0 @@
namespace MyWebLog
open MyWebLog.Entities
open MyWebLog.Logic.WebLog
open MyWebLog.Resources
open Nancy
open Nancy.Session.Persistable
open Newtonsoft.Json
open NodaTime
open NodaTime.Text
open System
open System.Net
/// Levels for a user message
[<RequireQualifiedAccess>]
module Level =
/// An informational message
let Info = "Info"
/// A message regarding a non-fatal but non-optimal condition
let Warning = "WARNING"
/// A message regarding a failure of the expected result
let Error = "ERROR"
/// A message for the user
type UserMessage =
{ /// The level of the message (use Level module constants)
Level : string
/// The text of the message
Message : string
/// Further details regarding the message
Details : string option }
with
/// An empty message
static member Empty =
{ Level = Level.Info
Message = ""
Details = None }
/// Display version
[<JsonIgnore>]
member this.ToDisplay =
let classAndLabel =
dict [
Level.Error, ("danger", Strings.get "Error")
Level.Warning, ("warning", Strings.get "Warning")
Level.Info, ("info", "")
]
seq {
yield "<div class=\"alert alert-dismissable alert-"
yield fst classAndLabel.[this.Level]
yield "\" role=\"alert\"><button type=\"button\" class=\"close\" data-dismiss=\"alert\" aria-label=\""
yield Strings.get "Close"
yield "\">&times;</button><strong>"
match snd classAndLabel.[this.Level] with
| "" -> ()
| lbl -> yield lbl.ToUpper ()
yield " &#xbb; "
yield this.Message
yield "</strong>"
match this.Details with
| Some d -> yield "<br />"
yield d
| None -> ()
yield "</div>"
}
|> Seq.reduce (+)
/// Helpers to format local date/time using NodaTime
module FormatDateTime =
/// Convert ticks to a zoned date/time
let zonedTime timeZone ticks = Instant.FromUnixTimeTicks(ticks).InZone(DateTimeZoneProviders.Tzdb.[timeZone])
/// Display a long date
let longDate timeZone ticks =
zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("MMMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format
/// Display a short date
let shortDate timeZone ticks =
zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("MMM d',' yyyy", DateTimeZoneProviders.Tzdb).Format
/// Display the time
let time timeZone ticks =
(zonedTime timeZone ticks
|> ZonedDateTimePattern.CreateWithCurrentCulture("h':'mmtt", DateTimeZoneProviders.Tzdb).Format).ToLower ()
/// Parent view model for all myWebLog views
type MyWebLogModel (ctx : NancyContext, webLog : WebLog) as this =
/// Get the messages from the session
let getMessages () =
let msg = ctx.Request.PersistableSession.GetOrDefault<UserMessage list> (Keys.Messages, [])
match List.length msg with
| 0 -> ()
| _ -> ctx.Request.Session.Delete Keys.Messages
msg
/// Generate a footer logo with the given scheme
let footerLogo scheme =
seq {
yield sprintf "<img src=\"/content/logo-%s.png\" alt=\"myWebLog\" title=\"" scheme
yield sprintf "%s %s &bull; " (Strings.get "PoweredBy") this.Generator
yield Strings.get "LoadedIn"
yield " "
yield TimeSpan(System.DateTime.Now.Ticks - this.RequestStart).TotalSeconds.ToString "f3"
yield " "
yield (Strings.get "Seconds").ToLower ()
yield "\" height=\"30\" />"
}
|> Seq.reduce (+)
/// The web log for this request
member this.WebLog = webLog
/// The subtitle for the webLog (SSVE can't do IsSome that deep)
member this.WebLogSubtitle = defaultArg this.WebLog.Subtitle ""
/// User messages
member val Messages = getMessages () with get, set
/// The currently logged in user
member this.User = ctx.Request.PersistableSession.GetOrDefault<User> (Keys.User, User.Empty)
/// The title of the page
member val PageTitle = "" with get, set
/// The name and version of the application
member this.Generator = sprintf "myWebLog %s" (ctx.Items.[Keys.Version].ToString ())
/// The request start time
member this.RequestStart = ctx.Items.[Keys.RequestStart] :?> int64
/// Is a user authenticated for this request?
member this.IsAuthenticated = "" <> this.User.Id
/// Add a message to the output
member this.AddMessage message = this.Messages <- message :: this.Messages
/// Display a long date
member this.DisplayLongDate ticks = FormatDateTime.longDate this.WebLog.TimeZone ticks
/// Display a short date
member this.DisplayShortDate ticks = FormatDateTime.shortDate this.WebLog.TimeZone ticks
/// Display the time
member this.DisplayTime ticks = FormatDateTime.time this.WebLog.TimeZone ticks
/// The page title with the web log name appended
member this.DisplayPageTitle =
match this.PageTitle 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
/// An image with the version and load time in the tool tip (using light text)
member this.FooterLogoLight = footerLogo "light"
/// An image with the version and load time in the tool tip (using dark text)
member this.FooterLogoDark = footerLogo "dark"
// ---- Admin models ----
/// Admin Dashboard view model
type DashboardModel (ctx, webLog, counts : DashboardCounts) =
inherit MyWebLogModel (ctx, webLog)
/// The number of posts for the current web log
member val Posts = counts.Posts with get, set
/// The number of pages for the current web log
member val Pages = counts.Pages with get, set
/// The number of categories for the current web log
member val Categories = counts.Categories with get, set
// ---- Category models ----
type IndentedCategory =
{ Category : Category
Indent : int
Selected : bool }
with
/// Create an indented category
static member Create cat isSelected =
{ Category = fst cat
Indent = snd cat
Selected = isSelected (fst cat).Id }
/// Display name for a category on the list page, complete with indents
member this.ListName = sprintf "%s%s" (String.replicate this.Indent " &#xbb; &nbsp; ") this.Category.Name
/// Display for this category as an option within a select box
member this.Option =
seq {
yield sprintf "<option value=\"%s\"" this.Category.Id
yield (match this.Selected with | true -> """ selected="selected">""" | _ -> ">")
yield String.replicate this.Indent " &nbsp; &nbsp; "
yield this.Category.Name
yield "</option>"
}
|> String.concat ""
/// Does the category have a description?
member this.HasDescription = this.Category.Description.IsSome
/// Model for the list of categories
type CategoryListModel (ctx, webLog, categories) =
inherit MyWebLogModel (ctx, webLog)
/// The categories
member this.Categories : IndentedCategory list = categories
/// Form for editing a category
type CategoryForm (category : Category) =
new() = CategoryForm (Category.Empty)
/// The name of the category
member val Name = category.Name with get, set
/// The slug of the category (used in category URLs)
member val Slug = category.Slug with get, set
/// The description of the category
member val Description = defaultArg category.Description "" with get, set
/// The parent category for this one
member val ParentId = defaultArg category.ParentId "" with get, set
/// Model for editing a category
type CategoryEditModel (ctx, webLog, category) =
inherit MyWebLogModel (ctx, webLog)
/// The form with the category information
member val Form = CategoryForm (category) with get, set
/// The category being edited
member val Category = category
/// The categories
member val Categories : IndentedCategory list = [] with get, set
// ---- Page models ----
/// Model for page display
type PageModel (ctx, webLog, page) =
inherit MyWebLogModel (ctx, webLog)
/// The page to be displayed
member this.Page : Page = page
/// Wrapper for a page with additional properties
type PageForDisplay (webLog, page) =
/// The page
member this.Page : Page = page
/// The time zone of the web log
member this.TimeZone = webLog.TimeZone
/// The date the page was last updated
member this.UpdatedDate = FormatDateTime.longDate this.TimeZone page.UpdatedOn
/// The time the page was last updated
member this.UpdatedTime = FormatDateTime.time this.TimeZone page.UpdatedOn
/// Model for page list display
type PagesModel (ctx, webLog, pages) =
inherit MyWebLogModel (ctx, webLog)
/// The pages
member this.Pages : PageForDisplay list = pages
/// Form used to edit a page
type EditPageForm() =
/// The title of the page
member val Title = "" with get, set
/// The link for the page
member val Permalink = "" with get, set
/// The source type of the revision
member val Source = "" with get, set
/// The text of the revision
member val Text = "" with get, set
/// Whether to show the page in the web log's page list
member val ShowInPageList = false with get, set
/// Fill the form with applicable values from a page
member this.ForPage (page : Page) =
this.Title <- page.Title
this.Permalink <- page.Permalink
this.ShowInPageList <- page.ShowInPageList
this
/// Fill the form with applicable values from a revision
member this.ForRevision rev =
this.Source <- rev.SourceType
this.Text <- rev.Text
this
/// Model for the edit page page
type EditPageModel (ctx, webLog, page, revision) =
inherit MyWebLogModel (ctx, webLog)
/// The page edit form
member val Form = EditPageForm().ForPage(page).ForRevision(revision)
/// The page itself
member this.Page = page
/// The page's published date
member this.PublishedDate = this.DisplayLongDate page.PublishedOn
/// The page's published time
member this.PublishedTime = this.DisplayTime page.PublishedOn
/// The page's last updated date
member this.LastUpdatedDate = this.DisplayLongDate page.UpdatedOn
/// The page's last updated time
member this.LastUpdatedTime = this.DisplayTime page.UpdatedOn
/// Is this a new page?
member this.IsNew = "new" = page.Id
/// Generate a checked attribute if this page shows in the page list
member this.PageListChecked = match page.ShowInPageList with true -> "checked=\"checked\"" | _ -> ""
// ---- Post models ----
/// Formatter for comment information
type CommentForDisplay (comment : Comment, tz) =
/// The comment on which this model is based
member this.Comment = comment
/// The commentor (linked with a URL if there is one)
member this.Commentor =
match comment.Url with Some url -> sprintf "<a href=\"%s\">%s</a>" url comment.Name | _ -> comment.Name
/// The date/time this comment was posted
member this.CommentedOn =
sprintf "%s / %s" (FormatDateTime.longDate tz comment.PostedOn) (FormatDateTime.time tz comment.PostedOn)
/// Model for single post display
type PostModel (ctx, webLog, post) =
inherit MyWebLogModel (ctx, webLog)
/// The post being displayed
member this.Post : Post = post
/// The next newer post
member val NewerPost : Post option = None with get, set
/// The next older post
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
member this.PublishedTime = this.DisplayTime this.Post.PublishedOn
/// The number of comments
member this.CommentCount =
match post.Comments |> List.length with
| 0 -> Strings.get "NoComments"
| 1 -> Strings.get "OneComment"
| x -> String.Format (Strings.get "XComments", x)
/// The comments for display
member this.Comments = post.Comments
|> List.filter (fun c -> c.Status = CommentStatus.Approved)
|> List.map (fun c -> CommentForDisplay (c, webLog.TimeZone))
/// Does the post have tags?
member this.HasTags = not <| List.isEmpty post.Tags
/// Get the tags sorted
member this.Tags = post.Tags
|> List.sort
|> List.map (fun tag -> tag, tag.Replace(' ', '+'))
/// Does this post have a newer post?
member this.HasNewer = this.NewerPost.IsSome
/// Does this post have an older post?
member this.HasOlder = this.OlderPost.IsSome
/// Wrapper for a post with additional properties
type PostForDisplay (webLog : WebLog, post : Post) =
/// Turn tags into a pipe-delimited string of tags
let pipedTags tags = tags |> List.reduce (fun acc x -> sprintf "%s | %s" acc x)
/// The actual post
member this.Post = post
/// The time zone for the web log to which this post belongs
member this.TimeZone = webLog.TimeZone
/// The date the post was published
member this.PublishedDate =
match this.Post.Status with
| PostStatus.Published -> FormatDateTime.longDate this.TimeZone this.Post.PublishedOn
| _ -> FormatDateTime.longDate this.TimeZone this.Post.UpdatedOn
/// The time the post was published
member this.PublishedTime =
match this.Post.Status with
| PostStatus.Published -> FormatDateTime.time this.TimeZone this.Post.PublishedOn
| _ -> FormatDateTime.time this.TimeZone this.Post.UpdatedOn
/// The number of comments
member this.CommentCount =
match post.Comments |> List.length with
| 0 -> Strings.get "NoComments"
| 1 -> Strings.get "OneComment"
| x -> String.Format (Strings.get "XComments", x)
/// Tags
member this.Tags =
match List.length this.Post.Tags with
| 0 -> ""
| 1 | 2 | 3 | 4 | 5 -> this.Post.Tags |> pipedTags
| count -> sprintf "%s %s" (this.Post.Tags |> List.take 3 |> pipedTags)
(System.String.Format(Strings.get "andXMore", count - 3))
/// Model for all page-of-posts pages
type PostsModel (ctx, webLog) =
inherit MyWebLogModel (ctx, webLog)
/// The subtitle for the page
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
member val PageNbr = 0 with get, set
/// Whether there is a newer page of posts for the list
member val HasNewer = false with get, set
/// Whether there is an older page of posts for the list
member val HasOlder = true with get, set
/// The prefix for the next/prior links
member val UrlPrefix = "" with get, set
/// The link for the next newer page of posts
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)
/// The link for the prior (older) page of posts
member this.OlderLink = sprintf "%s/page/%i" this.UrlPrefix (this.PageNbr + 1)
/// Form for editing a post
type EditPostForm () =
/// The title of the post
member val Title = "" with get, set
/// The permalink for the post
member val Permalink = "" with get, set
/// The source type for this revision
member val Source = "" with get, set
/// The text
member val Text = "" with get, set
/// Tags for the post
member val Tags = "" with get, set
/// The selected category Ids for the post
member val Categories : string[] = [||] with get, set
/// Whether the post should be published
member val PublishNow = false with get, set
/// Fill the form with applicable values from a post
member this.ForPost (post : Post) =
this.Title <- post.Title
this.Permalink <- post.Permalink
this.Tags <- match List.isEmpty post.Tags with
| true -> ""
| _ -> List.reduce (fun acc x -> sprintf "%s, %s" acc x) post.Tags
this.Categories <- List.toArray post.CategoryIds
this.PublishNow <- post.Status = PostStatus.Published || "new" = post.Id
this
/// Fill the form with applicable values from a revision
member this.ForRevision rev =
this.Source <- rev.SourceType
this.Text <- rev.Text
this
/// Category information for display
type DisplayCategory = {
Id : string
Indent : string
Name : string
Description : string
IsChecked : bool
}
with
/// Create a display category
static member Create (cat : Category, indent) isChecked =
{ Id = cat.Id
Indent = String.replicate indent " &nbsp; &nbsp; "
Name = WebUtility.HtmlEncode cat.Name
IsChecked = isChecked
Description = WebUtility.HtmlEncode (match cat.Description with Some d -> d | _ -> cat.Name)
}
/// The "checked" attribute for this category
member this.CheckedAttr
with get() = match this.IsChecked with true -> "checked=\"checked\"" | _ -> ""
/// View model for the edit post page
type EditPostModel (ctx, webLog, post, revision) =
inherit MyWebLogModel (ctx, webLog)
/// The form
member val Form = EditPostForm().ForPost(post).ForRevision(revision) with get, set
/// The post being edited
member val Post = post with get, set
/// The categories to which the post may be assigned
member val Categories : DisplayCategory list = [] with get, set
/// Whether the post is currently published
member this.IsPublished = PostStatus.Published = this.Post.Status
/// The published date
member this.PublishedDate = this.DisplayLongDate this.Post.PublishedOn
/// The published time
member this.PublishedTime = this.DisplayTime this.Post.PublishedOn
/// The "checked" attribute for the Publish Now box
member this.PublishNowCheckedAttr = match this.Form.PublishNow with true -> "checked=\"checked\"" | _ -> ""
// ---- User models ----
/// Form for the log on page
type LogOnForm () =
/// The URL to which the user will be directed upon successful log on
member val ReturnUrl = "" with get, set
/// The e-mail address
member val Email = "" with get, set
/// The user's passwor
member val Password = "" with get, set
/// Model to support the user log on page
type LogOnModel (ctx, webLog) =
inherit MyWebLogModel (ctx, webLog)
/// The log on form
member val Form = LogOnForm () with get, set

83
src/MyWebLog.App/en-US.json
View File

@@ -1,83 +0,0 @@
{
"Action": "Action",
"Added": "Added",
"AddNew": "Add New",
"AddNewCategory": "Add New Category",
"AddNewPage": "Add New Page",
"AddNewPost": "Add New Post",
"Admin": "Admin",
"AndPublished": " and Published",
"andXMore": "and {0} more...",
"at": "at",
"BackToCategoryList": "Back to Category List",
"BackToPageList": "Back to Page List",
"BackToPostList": "Back to Post List",
"Categories": "Categories",
"Category": "Category",
"CategoryDeleteWarning": "Are you sure you wish to delete the category",
"Close": "Close",
"Comments": "Comments",
"Dashboard": "Dashboard",
"Date": "Date",
"Delete": "Delete",
"Description": "Description",
"Edit": "Edit",
"EditCategory": "Edit Category",
"EditPage": "Edit Page",
"EditPost": "Edit Post",
"EmailAddress": "E-mail Address",
"ErrBadAppConfig": "Could not convert config.json to myWebLog configuration",
"ErrBadLogOnAttempt": "Invalid e-mail address or password",
"ErrDataConfig": "Could not convert data-config.json to RethinkDB connection",
"ErrNotConfigured": "is not properly configured for myWebLog",
"Error": "Error",
"LastUpdated": "Last Updated",
"LastUpdatedDate": "Last Updated Date",
"ListAll": "List All",
"LoadedIn": "Loaded in",
"LogOff": "Log Off",
"LogOn": "Log On",
"MsgCategoryDeleted": "Deleted category {0} successfully",
"MsgCategoryEditSuccess": "{0} category successfully",
"MsgLogOffSuccess": "Log off successful | Have a nice day!",
"MsgLogOnSuccess": "Log on successful | Welcome to myWebLog!",
"MsgPageDeleted": "Deleted page successfully",
"MsgPageEditSuccess": "{0} page successfully",
"MsgPostEditSuccess": "{0}{1} post successfully",
"Name": "Name",
"NewerPosts": "Newer Posts",
"NextPost": "Next Post",
"NoComments": "No Comments",
"NoParent": "No Parent",
"OlderPosts": "Older Posts",
"OneComment": "1 Comment",
"PageDeleteWarning": "Are you sure you wish to delete the page",
"PageDetails": "Page Details",
"PageHash": "Page #",
"Pages": "Pages",
"ParentCategory": "Parent Category",
"Password": "Password",
"Permalink": "Permalink",
"PermanentLinkTo": "Permanent Link to",
"PostDetails": "Post Details",
"Posts": "Posts",
"PostsTagged": "Posts Tagged",
"PostStatus": "Post Status",
"PoweredBy": "Powered by",
"PreviousPost": "Previous Post",
"PublishedDate": "Published Date",
"PublishThisPost": "Publish This Post",
"Save": "Save",
"Seconds": "Seconds",
"ShowInPageList": "Show in Page List",
"Slug": "Slug",
"startingWith": "starting with",
"Status": "Status",
"Tags": "Tags",
"Time": "Time",
"Title": "Title",
"Updated": "Updated",
"View": "View",
"Warning": "Warning",
"XComments": "{0} Comments"
}

64
src/MyWebLog.App/project.json
View File

@@ -1,64 +0,0 @@
{
"buildOptions": {
"compilerName": "fsc",
"compile": {
"includeFiles": [
"AssemblyInfo.fs",
"Entities/Entities.fs",
"Entities/IMyWebLogData.fs",
"Data/Extensions.fs",
"Data/Table.fs",
"Data/DataConfig.fs",
"Data/Category.fs",
"Data/Page.fs",
"Data/Post.fs",
"Data/User.fs",
"Data/WebLog.fs",
"Data/SetUp.fs",
"Data/RethinkMyWebLogData.fs",
"Logic/Category.fs",
"Logic/Page.fs",
"Logic/Post.fs",
"Logic/User.fs",
"Logic/WebLog.fs",
"Keys.fs",
"AppConfig.fs",
"Strings.fs",
"ViewModels.fs",
"Modules/ModuleExtensions.fs",
"Modules/AdminModule.fs",
"Modules/CategoryModule.fs",
"Modules/PageModule.fs",
"Modules/PostModule.fs",
"Modules/UserModule.fs",
"App.fs"
]
},
"embed": {
"include": [ "en-US.json" ]
}
},
"dependencies": {
"Nancy": "2.0.0-barneyrubble",
"Nancy.Authentication.Forms": "2.0.0-barneyrubble",
"Nancy.Session.Persistable": "0.9.1-pre",
"Nancy.Session.RethinkDB": "0.9.1-pre",
"Newtonsoft.Json": "9.0.1",
"NodaTime": "2.0.0-alpha20160729",
"RethinkDb.Driver": "2.3.15",
"Suave": "2.0.0-rc2"
},
"frameworks": {
"netstandard1.6": {
"imports": "dnxcore50",
"dependencies": {
"Microsoft.FSharp.Core.netcore": "1.0.0-alpha-161111",
"NETStandard.Library": "1.6.0"
}
}
},
"tools": {
"dotnet-compile-fsc": "1.0.0-preview2-*"
},
"version": "0.9.2"
}

132
src/MyWebLog.Data/Converters.fs Normal file
View File

@@ -0,0 +1,132 @@
/// Converters for discriminated union types
module MyWebLog.Converters
open MyWebLog
open System
/// JSON.NET converters for discriminated union types
module Json =
open Newtonsoft.Json
type CategoryIdConverter () =
inherit JsonConverter<CategoryId> ()
override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) =
writer.WriteValue (CategoryId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) =
(string >> CategoryId) reader.Value
type CommentIdConverter () =
inherit JsonConverter<CommentId> ()
override _.WriteJson (writer : JsonWriter, value : CommentId, _ : JsonSerializer) =
writer.WriteValue (CommentId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : CommentId, _ : bool, _ : JsonSerializer) =
(string >> CommentId) reader.Value
type CustomFeedIdConverter () =
inherit JsonConverter<CustomFeedId> ()
override _.WriteJson (writer : JsonWriter, value : CustomFeedId, _ : JsonSerializer) =
writer.WriteValue (CustomFeedId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedId, _ : bool, _ : JsonSerializer) =
(string >> CustomFeedId) reader.Value
type CustomFeedSourceConverter () =
inherit JsonConverter<CustomFeedSource> ()
override _.WriteJson (writer : JsonWriter, value : CustomFeedSource, _ : JsonSerializer) =
writer.WriteValue (CustomFeedSource.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) =
(string >> CustomFeedSource.parse) reader.Value
type ExplicitRatingConverter () =
inherit JsonConverter<ExplicitRating> ()
override _.WriteJson (writer : JsonWriter, value : ExplicitRating, _ : JsonSerializer) =
writer.WriteValue (ExplicitRating.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : ExplicitRating, _ : bool, _ : JsonSerializer) =
(string >> ExplicitRating.parse) reader.Value
type MarkupTextConverter () =
inherit JsonConverter<MarkupText> ()
override _.WriteJson (writer : JsonWriter, value : MarkupText, _ : JsonSerializer) =
writer.WriteValue (MarkupText.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : MarkupText, _ : bool, _ : JsonSerializer) =
(string >> MarkupText.parse) reader.Value
type PermalinkConverter () =
inherit JsonConverter<Permalink> ()
override _.WriteJson (writer : JsonWriter, value : Permalink, _ : JsonSerializer) =
writer.WriteValue (Permalink.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : Permalink, _ : bool, _ : JsonSerializer) =
(string >> Permalink) reader.Value
type PageIdConverter () =
inherit JsonConverter<PageId> ()
override _.WriteJson (writer : JsonWriter, value : PageId, _ : JsonSerializer) =
writer.WriteValue (PageId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : PageId, _ : bool, _ : JsonSerializer) =
(string >> PageId) reader.Value
type PostIdConverter () =
inherit JsonConverter<PostId> ()
override _.WriteJson (writer : JsonWriter, value : PostId, _ : JsonSerializer) =
writer.WriteValue (PostId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : PostId, _ : bool, _ : JsonSerializer) =
(string >> PostId) reader.Value
type TagMapIdConverter () =
inherit JsonConverter<TagMapId> ()
override _.WriteJson (writer : JsonWriter, value : TagMapId, _ : JsonSerializer) =
writer.WriteValue (TagMapId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : TagMapId, _ : bool, _ : JsonSerializer) =
(string >> TagMapId) reader.Value
type ThemeAssetIdConverter () =
inherit JsonConverter<ThemeAssetId> ()
override _.WriteJson (writer : JsonWriter, value : ThemeAssetId, _ : JsonSerializer) =
writer.WriteValue (ThemeAssetId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeAssetId, _ : bool, _ : JsonSerializer) =
(string >> ThemeAssetId.ofString) reader.Value
type ThemeIdConverter () =
inherit JsonConverter<ThemeId> ()
override _.WriteJson (writer : JsonWriter, value : ThemeId, _ : JsonSerializer) =
writer.WriteValue (ThemeId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeId, _ : bool, _ : JsonSerializer) =
(string >> ThemeId) reader.Value
type WebLogIdConverter () =
inherit JsonConverter<WebLogId> ()
override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) =
writer.WriteValue (WebLogId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) =
(string >> WebLogId) reader.Value
type WebLogUserIdConverter () =
inherit JsonConverter<WebLogUserId> ()
override _.WriteJson (writer : JsonWriter, value : WebLogUserId, _ : JsonSerializer) =
writer.WriteValue (WebLogUserId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogUserId, _ : bool, _ : JsonSerializer) =
(string >> WebLogUserId) reader.Value
open Microsoft.FSharpLu.Json
/// All converters to use for data conversion
let all () : JsonConverter seq =
seq {
// Our converters
CategoryIdConverter ()
CommentIdConverter ()
CustomFeedIdConverter ()
CustomFeedSourceConverter ()
ExplicitRatingConverter ()
MarkupTextConverter ()
PermalinkConverter ()
PageIdConverter ()
PostIdConverter ()
TagMapIdConverter ()
ThemeAssetIdConverter ()
ThemeIdConverter ()
WebLogIdConverter ()
WebLogUserIdConverter ()
// Handles DUs with no associated data, as well as option fields
CompactUnionJsonConverter ()
}

281
src/MyWebLog.Data/Interfaces.fs Normal file
View File

@@ -0,0 +1,281 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open MyWebLog
open MyWebLog.ViewModels
/// Data functions to support manipulating categories
type ICategoryData =
/// Add a category
abstract member add : Category -> Task<unit>
/// Count all categories for the given web log
abstract member countAll : WebLogId -> Task<int>
/// Count all top-level categories for the given web log
abstract member countTopLevel : WebLogId -> Task<int>
/// Delete a category (also removes it from posts)
abstract member delete : CategoryId -> WebLogId -> Task<bool>
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy
abstract member findAllForView : WebLogId -> Task<DisplayCategory[]>
/// Find a category by its ID
abstract member findById : CategoryId -> WebLogId -> Task<Category option>
/// Find all categories for the given web log
abstract member findByWebLog : WebLogId -> Task<Category list>
/// Restore categories from a backup
abstract member restore : Category list -> Task<unit>
/// Update a category (slug, name, description, and parent ID)
abstract member update : Category -> Task<unit>
/// Data functions to support manipulating pages
type IPageData =
/// Add a page
abstract member add : Page -> Task<unit>
/// Get all pages for the web log (excluding meta items, text, revisions, and prior permalinks)
abstract member all : WebLogId -> Task<Page list>
/// Count all pages for the given web log
abstract member countAll : WebLogId -> Task<int>
/// Count pages marked as "show in page list" for the given web log
abstract member countListed : WebLogId -> Task<int>
/// Delete a page
abstract member delete : PageId -> WebLogId -> Task<bool>
/// Find a page by its ID (excluding revisions and prior permalinks)
abstract member findById : PageId -> WebLogId -> Task<Page option>
/// Find a page by its permalink (excluding revisions and prior permalinks)
abstract member findByPermalink : Permalink -> WebLogId -> Task<Page option>
/// Find the current permalink for a page from a list of prior permalinks
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
/// Find a page by its ID (including revisions and prior permalinks)
abstract member findFullById : PageId -> WebLogId -> Task<Page option>
/// Find all pages for the given web log (including revisions and prior permalinks)
abstract member findFullByWebLog : WebLogId -> Task<Page list>
/// Find pages marked as "show in page list" for the given web log (excluding text, revisions, and prior permalinks)
abstract member findListed : WebLogId -> Task<Page list>
/// Find a page of pages (displayed in admin section) (excluding meta items, revisions and prior permalinks)
abstract member findPageOfPages : WebLogId -> pageNbr : int -> Task<Page list>
/// Restore pages from a backup
abstract member restore : Page list -> Task<unit>
/// Update a page
abstract member update : Page -> Task<unit>
/// Update the prior permalinks for the given page
abstract member updatePriorPermalinks : PageId -> WebLogId -> Permalink list -> Task<bool>
/// Data functions to support manipulating posts
type IPostData =
/// Add a post
abstract member add : Post -> Task<unit>
/// Count posts by their status
abstract member countByStatus : PostStatus -> WebLogId -> Task<int>
/// Delete a post
abstract member delete : PostId -> WebLogId -> Task<bool>
/// Find a post by its permalink (excluding revisions and prior permalinks)
abstract member findByPermalink : Permalink -> WebLogId -> Task<Post option>
/// Find the current permalink for a post from a list of prior permalinks
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
/// Find a post by its ID (including revisions and prior permalinks)
abstract member findFullById : PostId -> WebLogId -> Task<Post option>
/// Find all posts for the given web log (including revisions and prior permalinks)
abstract member findFullByWebLog : WebLogId -> Task<Post list>
/// Find posts to be displayed on a category list page (excluding revisions and prior permalinks)
abstract member findPageOfCategorizedPosts :
WebLogId -> CategoryId list -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on an admin page (excluding revisions and prior permalinks)
abstract member findPageOfPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on a page (excluding revisions and prior permalinks)
abstract member findPageOfPublishedPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on a tag list page (excluding revisions and prior permalinks)
abstract member findPageOfTaggedPosts :
WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find the next older and newer post for the given published date/time (excluding revisions and prior permalinks)
abstract member findSurroundingPosts : WebLogId -> publishedOn : DateTime -> Task<Post option * Post option>
/// Restore posts from a backup
abstract member restore : Post list -> Task<unit>
/// Update a post
abstract member update : Post -> Task<unit>
/// Update the prior permalinks for a post
abstract member updatePriorPermalinks : PostId -> WebLogId -> Permalink list -> Task<bool>
/// Functions to manipulate tag mappings
type ITagMapData =
/// Delete a tag mapping
abstract member delete : TagMapId -> WebLogId -> Task<bool>
/// Find a tag mapping by its ID
abstract member findById : TagMapId -> WebLogId -> Task<TagMap option>
/// Find a tag mapping by its URL value
abstract member findByUrlValue : string -> WebLogId -> Task<TagMap option>
/// Retrieve all tag mappings for the given web log
abstract member findByWebLog : WebLogId -> Task<TagMap list>
/// Find tag mappings for the given tags
abstract member findMappingForTags : tags : string list -> WebLogId -> Task<TagMap list>
/// Restore tag mappings from a backup
abstract member restore : TagMap list -> Task<unit>
/// Save a tag mapping (insert or update)
abstract member save : TagMap -> Task<unit>
/// Functions to manipulate themes
type IThemeData =
/// Retrieve all themes (except "admin")
abstract member all : unit -> Task<Theme list>
/// Find a theme by its ID
abstract member findById : ThemeId -> Task<Theme option>
/// Find a theme by its ID (excluding the text of its templates)
abstract member findByIdWithoutText : ThemeId -> Task<Theme option>
/// Save a theme (insert or update)
abstract member save : Theme -> Task<unit>
/// Functions to manipulate theme assets
type IThemeAssetData =
/// Retrieve all theme assets (excluding data)
abstract member all : unit -> Task<ThemeAsset list>
/// Delete all theme assets for the given theme
abstract member deleteByTheme : ThemeId -> Task<unit>
/// Find a theme asset by its ID
abstract member findById : ThemeAssetId -> Task<ThemeAsset option>
/// Find all assets for the given theme (excludes data)
abstract member findByTheme : ThemeId -> Task<ThemeAsset list>
/// Find all assets for the given theme (includes data)
abstract member findByThemeWithData : ThemeId -> Task<ThemeAsset list>
/// Save a theme asset (insert or update)
abstract member save : ThemeAsset -> Task<unit>
/// Functions to manipulate web logs
type IWebLogData =
/// Add a web log
abstract member add : WebLog -> Task<unit>
/// Retrieve all web logs
abstract member all : unit -> Task<WebLog list>
/// Delete a web log, including categories, tag mappings, posts/comments, and pages
abstract member delete : WebLogId -> Task<unit>
/// Find a web log by its host (URL base)
abstract member findByHost : string -> Task<WebLog option>
/// Find a web log by its ID
abstract member findById : WebLogId -> Task<WebLog option>
/// Update RSS options for a web log
abstract member updateRssOptions : WebLog -> Task<unit>
/// Update web log settings (from the settings page)
abstract member updateSettings : WebLog -> Task<unit>
/// Functions to manipulate web log users
type IWebLogUserData =
/// Add a web log user
abstract member add : WebLogUser -> Task<unit>
/// Find a web log user by their e-mail address
abstract member findByEmail : email : string -> WebLogId -> Task<WebLogUser option>
/// Find a web log user by their ID
abstract member findById : WebLogUserId -> WebLogId -> Task<WebLogUser option>
/// Find all web log users for the given web log
abstract member findByWebLog : WebLogId -> Task<WebLogUser list>
/// Get a user ID -> name dictionary for the given user IDs
abstract member findNames : WebLogId -> WebLogUserId list -> Task<MetaItem list>
/// Restore users from a backup
abstract member restore : WebLogUser list -> Task<unit>
/// Update a web log user
abstract member update : WebLogUser -> Task<unit>
/// Data interface required for a myWebLog data implementation
type IData =
/// Category data functions
abstract member Category : ICategoryData
/// Page data functions
abstract member Page : IPageData
/// Post data functions
abstract member Post : IPostData
/// Tag map data functions
abstract member TagMap : ITagMapData
/// Theme data functions
abstract member Theme : IThemeData
/// Theme asset data functions
abstract member ThemeAsset : IThemeAssetData
/// Web log data functions
abstract member WebLog : IWebLogData
/// Web log user data functions
abstract member WebLogUser : IWebLogUserData
/// Do any required start up data checks
abstract member startUp : unit -> Task<unit>

30
src/MyWebLog.Data/MyWebLog.Data.fsproj Normal file
View File

@@ -0,0 +1,30 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net6.0</TargetFramework>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
</PropertyGroup>
<ItemGroup>
<ProjectReference Include="..\MyWebLog.Domain\MyWebLog.Domain.fsproj" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.6" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
<PackageReference Include="RethinkDb.Driver" Version="2.3.150" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-05" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
</ItemGroup>
<ItemGroup>
<Compile Include="Converters.fs" />
<Compile Include="Interfaces.fs" />
<Compile Include="Utils.fs" />
<Compile Include="RethinkDbData.fs" />
<Compile Include="SQLiteData.fs" />
</ItemGroup>
</Project>

885
src/MyWebLog.Data/RethinkDbData.fs Normal file
View File

@@ -0,0 +1,885 @@
namespace MyWebLog.Data
open System.Threading.Tasks
open MyWebLog
open RethinkDb.Driver
/// Functions to assist with retrieving data
[<AutoOpen>]
module private RethinkHelpers =
/// Table names
[<RequireQualifiedAccess>]
module Table =
/// The category table
let Category = "Category"
/// The comment table
let Comment = "Comment"
/// The page table
let Page = "Page"
/// The post table
let Post = "Post"
/// The tag map table
let TagMap = "TagMap"
/// The theme table
let Theme = "Theme"
/// The theme asset table
let ThemeAsset = "ThemeAsset"
/// The web log table
let WebLog = "WebLog"
/// The web log user table
let WebLogUser = "WebLogUser"
/// A list of all tables
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ]
/// A list of all tables with a webLogId field
let allForWebLog = [ Comment; Post; Category; TagMap; Page; WebLogUser ]
/// Shorthand for the ReQL starting point
let r = RethinkDB.R
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : Net.IConnection -> Task<'T option>) =
fun conn -> backgroundTask {
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
}
/// Get the first item from a list, or None if the list is empty
let tryFirst<'T> (f : Net.IConnection -> Task<'T list>) =
fun conn -> backgroundTask {
let! results = f conn
return results |> List.tryHead
}
/// Cast a strongly-typed list to an object list
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
open Microsoft.Extensions.Logging
open MyWebLog.ViewModels
open RethinkDb.Driver.FSharp
/// RethinkDB implementation of data functions for myWebLog
type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<RethinkDbData>) =
/// Match theme asset IDs by their prefix (the theme ID)
let matchAssetByThemeId themeId =
let keyPrefix = $"^{ThemeId.toString themeId}/"
fun (row : Ast.ReqlExpr) -> row["id"].Match keyPrefix :> obj
/// Ensure field indexes exist, as well as special indexes for selected tables
let ensureIndexes table fields = backgroundTask {
let! indexes = rethink<string list> { withTable table; indexList; result; withRetryOnce conn }
for field in fields do
if not (indexes |> List.contains field) then
log.LogInformation $"Creating index {table}.{field}..."
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
// Post and page need index by web log ID and permalink
if [ Table.Page; Table.Post ] |> List.contains table then
if not (indexes |> List.contains "permalink") then
log.LogInformation $"Creating index {table}.permalink..."
do! rethink {
withTable table
indexCreate "permalink" (fun row -> r.Array (row["webLogId"], row["permalink"].Downcase ()) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Prior permalinks are searched when a post or page permalink do not match the current URL
if not (indexes |> List.contains "priorPermalinks") then
log.LogInformation $"Creating index {table}.priorPermalinks..."
do! rethink {
withTable table
indexCreate "priorPermalinks" (fun row -> row["priorPermalinks"].Downcase () :> obj) [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Post needs indexes by category and tag (used for counting and retrieving posts)
if Table.Post = table then
for idx in [ "categoryIds"; "tags" ] do
if not (List.contains idx indexes) then
log.LogInformation $"Creating index {table}.{idx}..."
do! rethink {
withTable table
indexCreate idx [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Tag mapping needs an index by web log ID and both tag and URL values
if Table.TagMap = table then
if not (indexes |> List.contains "webLogAndTag") then
log.LogInformation $"Creating index {table}.webLogAndTag..."
do! rethink {
withTable table
indexCreate "webLogAndTag" (fun row -> r.Array (row["webLogId"], row["tag"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
if not (indexes |> List.contains "webLogAndUrl") then
log.LogInformation $"Creating index {table}.webLogAndUrl..."
do! rethink {
withTable table
indexCreate "webLogAndUrl" (fun row -> r.Array (row["webLogId"], row["urlValue"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Users log on with e-mail
if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then
log.LogInformation $"Creating index {table}.logOn..."
do! rethink {
withTable table
indexCreate "logOn" (fun row -> r.Array (row["webLogId"], row["userName"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
}
/// The batch size for restoration methods
let restoreBatchSize = 100
/// The connection for this instance
member _.Conn = conn
interface IData with
member _.Category = {
new ICategoryData with
member _.add cat = rethink {
withTable Table.Category
insert cat
write; withRetryDefault; ignoreResult conn
}
member _.countAll webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault conn
}
member _.countTopLevel webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
filter "parentId" None
count
result; withRetryDefault conn
}
member _.findAllForView webLogId = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
orderByFunc (fun it -> it["name"].Downcase () :> obj)
result; withRetryDefault conn
}
let ordered = Utils.orderByHierarchy cats None None []
let! counts =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catIds =
ordered
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|> Seq.map (fun cat -> cat.id :> obj)
|> Seq.append (Seq.singleton it.id)
|> List.ofSeq
let! count = rethink<int> {
withTable Table.Post
getAll catIds "categoryIds"
filter "status" Published
distinct
count
result; withRetryDefault conn
}
return it.id, count
})
|> Task.WhenAll
return
ordered
|> Seq.map (fun cat ->
{ cat with
postCount = counts
|> Array.tryFind (fun c -> fst c = cat.id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Array.ofSeq
}
member _.findById catId webLogId =
rethink<Category> {
withTable Table.Category
get catId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun c -> c.webLogId) <| conn
member _.findByWebLog webLogId = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
result; withRetryDefault conn
}
member this.delete catId webLogId = backgroundTask {
match! this.findById catId webLogId with
| Some _ ->
// Delete the category off all posts where it is assigned
do! rethink {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["categoryIds"].Contains catId :> obj)
update (fun row -> r.HashMap ("categoryIds", r.Array(row["categoryIds"]).Remove catId) :> obj)
write; withRetryDefault; ignoreResult conn
}
// Delete the category itself
do! rethink {
withTable Table.Category
get catId
delete
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
member _.restore cats = backgroundTask {
for batch in cats |> List.chunkBySize restoreBatchSize do
do! rethink {
withTable Table.Category
insert batch
write; withRetryOnce; ignoreResult conn
}
}
member _.update cat = rethink {
withTable Table.Category
get cat.id
update [ "name", cat.name :> obj
"slug", cat.slug
"description", cat.description
"parentId", cat.parentId
]
write; withRetryDefault; ignoreResult conn
}
}
member _.Page = {
new IPageData with
member _.add page = rethink {
withTable Table.Page
insert page
write; withRetryDefault; ignoreResult conn
}
member _.all webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "text"; "metadata"; "revisions"; "priorPermalinks" ]
orderByFunc (fun row -> row["title"].Downcase () :> obj)
result; withRetryDefault conn
}
member _.countAll webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault conn
}
member _.countListed webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter "showInPageList" true
count
result; withRetryDefault conn
}
member _.delete pageId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.Page
getAll [ pageId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findById pageId webLogId =
rethink<Page> {
withTable Table.Page
get pageId
without [ "priorPermalinks"; "revisions" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
member _.findByPermalink permalink webLogId =
rethink<Page list> {
withTable Table.Page
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Page list> {
withTable Table.Page
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun pg -> pg.permalink)
}
member _.findFullById pageId webLogId =
rethink<Page> {
withTable Table.Page
get pageId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
member _.findFullByWebLog webLogId = rethink<Page> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.findListed webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter [ "showInPageList", true :> obj ]
without [ "text"; "priorPermalinks"; "revisions" ]
orderBy "title"
result; withRetryDefault conn
}
member _.findPageOfPages webLogId pageNbr = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "metadata"; "priorPermalinks"; "revisions" ]
orderByFunc (fun row -> row["title"].Downcase ())
skip ((pageNbr - 1) * 25)
limit 25
result; withRetryDefault conn
}
member _.restore pages = backgroundTask {
for batch in pages |> List.chunkBySize restoreBatchSize do
do! rethink {
withTable Table.Page
insert batch
write; withRetryOnce; ignoreResult conn
}
}
member _.update page = rethink {
withTable Table.Page
get page.id
update [
"title", page.title :> obj
"permalink", page.permalink
"updatedOn", page.updatedOn
"showInPageList", page.showInPageList
"template", page.template
"text", page.text
"priorPermalinks", page.priorPermalinks
"metadata", page.metadata
"revisions", page.revisions
]
write; withRetryDefault; ignoreResult conn
}
member this.updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! this.findById pageId webLogId with
| Some _ ->
do! rethink {
withTable Table.Page
get pageId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
}
member _.Post = {
new IPostData with
member _.add post = rethink {
withTable Table.Post
insert post
write; withRetryDefault; ignoreResult conn
}
member _.countByStatus status webLogId = rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" status
count
result; withRetryDefault conn
}
member _.delete postId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.Post
getAll [ postId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findByPermalink permalink webLogId =
rethink<Post list> {
withTable Table.Post
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findFullById postId webLogId =
rethink<Post> {
withTable Table.Post
get postId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId) <| conn
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Post list> {
withTable Table.Post
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun post -> post.permalink)
}
member _.findFullByWebLog webLogId = rethink<Post> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll (objList categoryIds) "categoryIds"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
distinct
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
without [ "priorPermalinks"; "revisions" ]
orderByFuncDescending (fun row -> row["publishedOn"].Default_ "updatedOn" :> obj)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfPublishedPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfTaggedPosts webLogId tag pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ tag ] "tags"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findSurroundingPosts webLogId publishedOn = backgroundTask {
let! older =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Lt publishedOn :> obj)
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
let! newer =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Gt publishedOn :> obj)
without [ "priorPermalinks"; "revisions" ]
orderBy "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
return older, newer
}
member _.restore pages = backgroundTask {
for batch in pages |> List.chunkBySize restoreBatchSize do
do! rethink {
withTable Table.Post
insert batch
write; withRetryOnce; ignoreResult conn
}
}
member _.update post = rethink {
withTable Table.Post
get post.id
replace post
write; withRetryDefault; ignoreResult conn
}
member _.updatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! (
rethink<Post> {
withTable Table.Post
get postId
without [ "revisions"; "priorPermalinks" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId)) conn with
| Some _ ->
do! rethink {
withTable Table.Post
get postId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
}
member _.TagMap = {
new ITagMapData with
member _.delete tagMapId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.TagMap
getAll [ tagMapId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findById tagMapId webLogId =
rethink<TagMap> {
withTable Table.TagMap
get tagMapId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun tm -> tm.webLogId) <| conn
member _.findByUrlValue urlValue webLogId =
rethink<TagMap list> {
withTable Table.TagMap
getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findByWebLog webLogId = rethink<TagMap list> {
withTable Table.TagMap
between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) [ Index "webLogAndTag" ]
orderBy "tag"
result; withRetryDefault conn
}
member _.findMappingForTags tags webLogId = rethink<TagMap list> {
withTable Table.TagMap
getAll (tags |> List.map (fun tag -> r.Array (webLogId, tag) :> obj)) "webLogAndTag"
result; withRetryDefault conn
}
member _.restore tagMaps = backgroundTask {
for batch in tagMaps |> List.chunkBySize restoreBatchSize do
do! rethink {
withTable Table.TagMap
insert batch
write; withRetryOnce; ignoreResult conn
}
}
member _.save tagMap = rethink {
withTable Table.TagMap
get tagMap.id
replace tagMap
write; withRetryDefault; ignoreResult conn
}
}
member _.Theme = {
new IThemeData with
member _.all () = rethink<Theme list> {
withTable Table.Theme
filter (fun row -> row["id"].Ne "admin" :> obj)
without [ "templates" ]
orderBy "id"
result; withRetryDefault conn
}
member _.findById themeId = rethink<Theme> {
withTable Table.Theme
get themeId
resultOption; withRetryOptionDefault conn
}
member _.findByIdWithoutText themeId = rethink<Theme> {
withTable Table.Theme
get themeId
merge (fun row -> r.HashMap ("templates", row["templates"].Without [| "text" |]))
resultOption; withRetryOptionDefault conn
}
member _.save theme = rethink {
withTable Table.Theme
get theme.id
replace theme
write; withRetryDefault; ignoreResult conn
}
}
member _.ThemeAsset = {
new IThemeAssetData with
member _.all () = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
without [ "data" ]
result; withRetryDefault conn
}
member _.deleteByTheme themeId = rethink {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
delete
write; withRetryDefault; ignoreResult conn
}
member _.findById assetId = rethink<ThemeAsset> {
withTable Table.ThemeAsset
get assetId
resultOption; withRetryOptionDefault conn
}
member _.findByTheme themeId = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
without [ "data" ]
result; withRetryDefault conn
}
member _.findByThemeWithData themeId = rethink<ThemeAsset> {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.save asset = rethink {
withTable Table.ThemeAsset
get asset.id
replace asset
write; withRetryDefault; ignoreResult conn
}
}
member _.WebLog = {
new IWebLogData with
member _.add webLog = rethink {
withTable Table.WebLog
insert webLog
write; withRetryOnce; ignoreResult conn
}
member _.all () = rethink<WebLog list> {
withTable Table.WebLog
result; withRetryDefault conn
}
member _.delete webLogId = backgroundTask {
for table in Table.allForWebLog do
do! rethink {
withTable table
getAll [ webLogId ] (nameof webLogId)
delete
write; withRetryOnce; ignoreResult conn
}
do! rethink {
withTable Table.WebLog
get webLogId
delete
write; withRetryOnce; ignoreResult conn
}
}
member _.findByHost url =
rethink<WebLog list> {
withTable Table.WebLog
getAll [ url ] "urlBase"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findById webLogId = rethink<WebLog> {
withTable Table.WebLog
get webLogId
resultOption; withRetryOptionDefault conn
}
member _.updateRssOptions webLog = rethink {
withTable Table.WebLog
get webLog.id
update [ "rss", webLog.rss :> obj ]
write; withRetryDefault; ignoreResult conn
}
member _.updateSettings webLog = rethink {
withTable Table.WebLog
get webLog.id
update [
"name", webLog.name :> obj
"subtitle", webLog.subtitle
"defaultPage", webLog.defaultPage
"postsPerPage", webLog.postsPerPage
"timeZone", webLog.timeZone
"themePath", webLog.themePath
"autoHtmx", webLog.autoHtmx
]
write; withRetryDefault; ignoreResult conn
}
}
member _.WebLogUser = {
new IWebLogUserData with
member _.add user = rethink {
withTable Table.WebLogUser
insert user
write; withRetryDefault; ignoreResult conn
}
member _.findByEmail email webLogId =
rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ r.Array (webLogId, email) ] "logOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findById userId webLogId =
rethink<WebLogUser> {
withTable Table.WebLogUser
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.webLogId) <| conn
member _.findByWebLog webLogId = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ webLogId ] (nameof webLogId)
result; withRetryDefault conn
}
member _.findNames webLogId userIds = backgroundTask {
let! users = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll (objList userIds)
filter "webLogId" webLogId
result; withRetryDefault conn
}
return
users
|> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
}
member _.restore users = backgroundTask {
for batch in users |> List.chunkBySize restoreBatchSize do
do! rethink {
withTable Table.WebLogUser
insert batch
write; withRetryOnce; ignoreResult conn
}
}
member _.update user = rethink {
withTable Table.WebLogUser
get user.id
update [
"firstName", user.firstName :> obj
"lastName", user.lastName
"preferredName", user.preferredName
"passwordHash", user.passwordHash
"salt", user.salt
]
write; withRetryDefault; ignoreResult conn
}
}
member _.startUp () = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then
log.LogInformation $"Creating database {config.Database}..."
do! rethink { dbCreate config.Database; write; withRetryOnce; ignoreResult conn }
let! tables = rethink<string list> { tableList; result; withRetryOnce conn }
for tbl in Table.all do
if not (tables |> List.contains tbl) then
log.LogInformation $"Creating table {tbl}..."
do! rethink { tableCreate tbl; write; withRetryOnce; ignoreResult conn }
do! ensureIndexes Table.Category [ "webLogId" ]
do! ensureIndexes Table.Comment [ "postId" ]
do! ensureIndexes Table.Page [ "webLogId"; "authorId" ]
do! ensureIndexes Table.Post [ "webLogId"; "authorId" ]
do! ensureIndexes Table.TagMap []
do! ensureIndexes Table.WebLog [ "urlBase" ]
do! ensureIndexes Table.WebLogUser [ "webLogId" ]
}

2017
src/MyWebLog.Data/SQLiteData.fs Normal file
View File

File diff suppressed because it is too large Load Diff

22
src/MyWebLog.Data/Utils.fs Normal file
View File

@@ -0,0 +1,22 @@
/// Utility functions for manipulating data
[<RequireQualifiedAccess>]
module internal MyWebLog.Data.Utils
open MyWebLog
open MyWebLog.ViewModels
/// Create a category hierarchy from the given list of categories
let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.parentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.slug
{ id = CategoryId.toString cat.id
slug = fullSlug
name = cat.name
description = cat.description
parentNames = Array.ofList parentNames
// Post counts are filled on a second pass
postCount = 0
}
yield! orderByHierarchy cats (Some cat.id) (Some fullSlug) ([ cat.name ] |> List.append parentNames)
}

427
src/MyWebLog.Domain/DataTypes.fs Normal file
View File

@@ -0,0 +1,427 @@
namespace MyWebLog
open System
open MyWebLog
/// A category under which a post may be identified
[<CLIMutable; NoComparison; NoEquality>]
type Category =
{ /// The ID of the category
id : CategoryId
/// The ID of the web log to which the category belongs
webLogId : WebLogId
/// The displayed name
name : string
/// The slug (used in category URLs)
slug : string
/// A longer description of the category
description : string option
/// The parent ID of this category (if a subcategory)
parentId : CategoryId option
}
/// Functions to support categories
module Category =
/// An empty category
let empty =
{ id = CategoryId.empty
webLogId = WebLogId.empty
name = ""
slug = ""
description = None
parentId = None
}
/// A comment on a post
[<CLIMutable; NoComparison; NoEquality>]
type Comment =
{ /// The ID of the comment
id : CommentId
/// The ID of the post to which this comment applies
postId : PostId
/// The ID of the comment to which this comment is a reply
inReplyToId : CommentId option
/// The name of the commentor
name : string
/// The e-mail address of the commentor
email : string
/// The URL of the commentor's personal website
url : string option
/// The status of the comment
status : CommentStatus
/// When the comment was posted
postedOn : DateTime
/// The text of the comment
text : string
}
/// Functions to support comments
module Comment =
/// An empty comment
let empty =
{ id = CommentId.empty
postId = PostId.empty
inReplyToId = None
name = ""
email = ""
url = None
status = Pending
postedOn = DateTime.UtcNow
text = ""
}
/// A page (text not associated with a date/time)
[<CLIMutable; NoComparison; NoEquality>]
type Page =
{ /// The ID of this page
id : PageId
/// The ID of the web log to which this page belongs
webLogId : WebLogId
/// The ID of the author of this page
authorId : WebLogUserId
/// The title of the page
title : string
/// The link at which this page is displayed
permalink : Permalink
/// When this page was published
publishedOn : DateTime
/// When this page was last updated
updatedOn : DateTime
/// Whether this page shows as part of the web log's navigation
showInPageList : bool
/// The template to use when rendering this page
template : string option
/// The current text of the page
text : string
/// Metadata for this page
metadata : MetaItem list
/// Permalinks at which this page may have been previously served (useful for migrated content)
priorPermalinks : Permalink list
/// Revisions of this page
revisions : Revision list
}
/// Functions to support pages
module Page =
/// An empty page
let empty =
{ id = PageId.empty
webLogId = WebLogId.empty
authorId = WebLogUserId.empty
title = ""
permalink = Permalink.empty
publishedOn = DateTime.MinValue
updatedOn = DateTime.MinValue
showInPageList = false
template = None
text = ""
metadata = []
priorPermalinks = []
revisions = []
}
/// A web log post
[<CLIMutable; NoComparison; NoEquality>]
type Post =
{ /// The ID of this post
id : PostId
/// The ID of the web log to which this post belongs
webLogId : WebLogId
/// The ID of the author of this post
authorId : WebLogUserId
/// The status
status : PostStatus
/// The title
title : string
/// The link at which the post resides
permalink : Permalink
/// The instant on which the post was originally published
publishedOn : DateTime option
/// The instant on which the post was last updated
updatedOn : DateTime
/// The template to use in displaying the post
template : string option
/// The text of the post in HTML (ready to display) format
text : string
/// The Ids of the categories to which this is assigned
categoryIds : CategoryId list
/// The tags for the post
tags : string list
/// Metadata for the post
metadata : MetaItem list
/// Permalinks at which this post may have been previously served (useful for migrated content)
priorPermalinks : Permalink list
/// The revisions for this post
revisions : Revision list
}
/// Functions to support posts
module Post =
/// An empty post
let empty =
{ id = PostId.empty
webLogId = WebLogId.empty
authorId = WebLogUserId.empty
status = Draft
title = ""
permalink = Permalink.empty
publishedOn = None
updatedOn = DateTime.MinValue
text = ""
template = None
categoryIds = []
tags = []
metadata = []
priorPermalinks = []
revisions = []
}
/// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1")
type TagMap =
{ /// The ID of this tag mapping
id : TagMapId
/// The ID of the web log to which this tag mapping belongs
webLogId : WebLogId
/// The tag which should be mapped to a different value in links
tag : string
/// The value by which the tag should be linked
urlValue : string
}
/// Functions to support tag mappings
module TagMap =
/// An empty tag mapping
let empty =
{ id = TagMapId.empty
webLogId = WebLogId.empty
tag = ""
urlValue = ""
}
/// A theme
type Theme =
{ /// The ID / path of the theme
id : ThemeId
/// A long name of the theme
name : string
/// The version of the theme
version : string
/// The templates for this theme
templates: ThemeTemplate list
}
/// Functions to support themes
module Theme =
/// An empty theme
let empty =
{ id = ThemeId ""
name = ""
version = ""
templates = []
}
/// A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path])
type ThemeAsset =
{
/// The ID of the asset (consists of theme and path)
id : ThemeAssetId
/// The updated date (set from the file date from the ZIP archive)
updatedOn : DateTime
/// The data for the asset
data : byte[]
}
/// A web log
[<CLIMutable; NoComparison; NoEquality>]
type WebLog =
{ /// The ID of the web log
id : WebLogId
/// The name of the web log
name : string
/// A subtitle for the web log
subtitle : string option
/// The default page ("posts" or a page Id)
defaultPage : string
/// The number of posts to display on pages of posts
postsPerPage : int
/// The path of the theme (within /themes)
themePath : string
/// The URL base
urlBase : string
/// The time zone in which dates/times should be displayed
timeZone : string
/// The RSS options for this web log
rss : RssOptions
/// Whether to automatically load htmx
autoHtmx : bool
}
/// Functions to support web logs
module WebLog =
/// An empty web log
let empty =
{ id = WebLogId.empty
name = ""
subtitle = None
defaultPage = ""
postsPerPage = 10
themePath = "default"
urlBase = ""
timeZone = ""
rss = RssOptions.empty
autoHtmx = false
}
/// Get the host (including scheme) and extra path from the URL base
let hostAndPath webLog =
let scheme = webLog.urlBase.Split "://"
let host = scheme[1].Split "/"
$"{scheme[0]}://{host[0]}", if host.Length > 1 then $"""/{String.Join ("/", host |> Array.skip 1)}""" else ""
/// Generate an absolute URL for the given link
let absoluteUrl webLog permalink =
$"{webLog.urlBase}/{Permalink.toString permalink}"
/// Generate a relative URL for the given link
let relativeUrl webLog permalink =
let _, leadPath = hostAndPath webLog
$"{leadPath}/{Permalink.toString permalink}"
/// Convert a UTC date/time to the web log's local date/time
let localTime webLog (date : DateTime) =
TimeZoneInfo.ConvertTimeFromUtc
(DateTime (date.Ticks, DateTimeKind.Utc), TimeZoneInfo.FindSystemTimeZoneById webLog.timeZone)
/// Convert a date/time in the web log's local date/time to UTC
let utcTime webLog (date : DateTime) =
TimeZoneInfo.ConvertTimeToUtc
(DateTime (date.Ticks, DateTimeKind.Unspecified), TimeZoneInfo.FindSystemTimeZoneById webLog.timeZone)
/// A user of the web log
[<CLIMutable; NoComparison; NoEquality>]
type WebLogUser =
{ /// The ID of the user
id : WebLogUserId
/// The ID of the web log to which this user belongs
webLogId : WebLogId
/// The user name (e-mail address)
userName : string
/// The user's first name
firstName : string
/// The user's last name
lastName : string
/// The user's preferred name
preferredName : string
/// The hash of the user's password
passwordHash : string
/// Salt used to calculate the user's password hash
salt : Guid
/// The URL of the user's personal site
url : string option
/// The user's authorization level
authorizationLevel : AuthorizationLevel
}
/// Functions to support web log users
module WebLogUser =
/// An empty web log user
let empty =
{ id = WebLogUserId.empty
webLogId = WebLogId.empty
userName = ""
firstName = ""
lastName = ""
preferredName = ""
passwordHash = ""
salt = Guid.Empty
url = None
authorizationLevel = User
}
/// Get the user's displayed name
let displayName user =
let name =
seq { match user.preferredName with "" -> user.firstName | n -> n; " "; user.lastName }
|> Seq.reduce (+)
name.Trim ()

20
src/MyWebLog.Domain/MyWebLog.Domain.fsproj Normal file
View File

@@ -0,0 +1,20 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net6.0</TargetFramework>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
</PropertyGroup>
<ItemGroup>
<Compile Include="SupportTypes.fs" />
<Compile Include="DataTypes.fs" />
<Compile Include="ViewModels.fs" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="Markdig" Version="0.30.2" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
<PackageReference Include="Markdown.ColorCode" Version="1.0.1" />
</ItemGroup>
</Project>

483
src/MyWebLog.Domain/SupportTypes.fs Normal file
View File

@@ -0,0 +1,483 @@
namespace MyWebLog
open System
/// Support functions for domain definition
[<AutoOpen>]
module private Helpers =
/// Create a new ID (short GUID)
// https://www.madskristensen.net/blog/A-shorter-and-URL-friendly-GUID
let newId() =
Convert.ToBase64String(Guid.NewGuid().ToByteArray()).Replace('/', '_').Replace('+', '-').Substring (0, 22)
/// An identifier for a category
type CategoryId = CategoryId of string
/// Functions to support category IDs
module CategoryId =
/// An empty category ID
let empty = CategoryId ""
/// Convert a category ID to a string
let toString = function CategoryId ci -> ci
/// Create a new category ID
let create () = CategoryId (newId ())
/// An identifier for a comment
type CommentId = CommentId of string
/// Functions to support comment IDs
module CommentId =
/// An empty comment ID
let empty = CommentId ""
/// Convert a comment ID to a string
let toString = function CommentId ci -> ci
/// Create a new comment ID
let create () = CommentId (newId ())
/// Statuses for post comments
type CommentStatus =
/// The comment is approved
| Approved
/// The comment has yet to be approved
| Pending
/// The comment was unsolicited and unwelcome
| Spam
/// Functions to support post comment statuses
module CommentStatus =
/// Convert a comment status to a string
let toString = function Approved -> "Approved" | Pending -> "Pending" | Spam -> "Spam"
/// Parse a string into a comment status
let parse value =
match value with
| "Approved" -> Approved
| "Pending" -> Pending
| "Spam" -> Spam
| it -> invalidOp $"{it} is not a valid post status"
open Markdig
open Markdown.ColorCode
/// Types of markup text
type MarkupText =
/// Markdown text
| Markdown of string
/// HTML text
| Html of string
/// Functions to support markup text
module MarkupText =
/// Pipeline with most extensions enabled
let private _pipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build ()
/// Get the source type for the markup text
let sourceType = function Markdown _ -> "Markdown" | Html _ -> "HTML"
/// Get the raw text, regardless of type
let text = function Markdown text -> text | Html text -> text
/// Get the string representation of the markup text
let toString it = $"{sourceType it}: {text it}"
/// Get the HTML representation of the markup text
let toHtml = function Markdown text -> Markdown.ToHtml (text, _pipeline) | Html text -> text
/// Parse a string into a MarkupText instance
let parse (it : string) =
match it with
| text when text.StartsWith "Markdown: " -> Markdown (text.Substring 10)
| text when text.StartsWith "HTML: " -> Html (text.Substring 6)
| text -> invalidOp $"Cannot derive type of text ({text})"
/// An item of metadata
[<CLIMutable; NoComparison; NoEquality>]
type MetaItem =
{ /// The name of the metadata value
name : string
/// The metadata value
value : string
}
/// Functions to support metadata items
module MetaItem =
/// An empty metadata item
let empty =
{ name = ""; value = "" }
/// A revision of a page or post
[<CLIMutable; NoComparison; NoEquality>]
type Revision =
{ /// When this revision was saved
asOf : DateTime
/// The text of the revision
text : MarkupText
}
/// Functions to support revisions
module Revision =
/// An empty revision
let empty =
{ asOf = DateTime.UtcNow
text = Html ""
}
/// A permanent link
type Permalink = Permalink of string
/// Functions to support permalinks
module Permalink =
/// An empty permalink
let empty = Permalink ""
/// Convert a permalink to a string
let toString = function Permalink p -> p
/// An identifier for a page
type PageId = PageId of string
/// Functions to support page IDs
module PageId =
/// An empty page ID
let empty = PageId ""
/// Convert a page ID to a string
let toString = function PageId pi -> pi
/// Create a new page ID
let create () = PageId (newId ())
/// Statuses for posts
type PostStatus =
/// The post should not be publicly available
| Draft
/// The post is publicly viewable
| Published
/// Functions to support post statuses
module PostStatus =
/// Convert a post status to a string
let toString = function Draft -> "Draft" | Published -> "Published"
/// Parse a string into a post status
let parse value =
match value with
| "Draft" -> Draft
| "Published" -> Published
| it -> invalidOp $"{it} is not a valid post status"
/// An identifier for a post
type PostId = PostId of string
/// Functions to support post IDs
module PostId =
/// An empty post ID
let empty = PostId ""
/// Convert a post ID to a string
let toString = function PostId pi -> pi
/// Create a new post ID
let create () = PostId (newId ())
/// An identifier for a custom feed
type CustomFeedId = CustomFeedId of string
/// Functions to support custom feed IDs
module CustomFeedId =
/// An empty custom feed ID
let empty = CustomFeedId ""
/// Convert a custom feed ID to a string
let toString = function CustomFeedId pi -> pi
/// Create a new custom feed ID
let create () = CustomFeedId (newId ())
/// The source for a custom feed
type CustomFeedSource =
/// A feed based on a particular category
| Category of CategoryId
/// A feed based on a particular tag
| Tag of string
/// Functions to support feed sources
module CustomFeedSource =
/// Create a string version of a feed source
let toString : CustomFeedSource -> string =
function
| Category (CategoryId catId) -> $"category:{catId}"
| Tag tag -> $"tag:{tag}"
/// Parse a feed source from its string version
let parse : string -> CustomFeedSource =
let value (it : string) = it.Split(":").[1]
function
| source when source.StartsWith "category:" -> (value >> CategoryId >> Category) source
| source when source.StartsWith "tag:" -> (value >> Tag) source
| source -> invalidArg "feedSource" $"{source} is not a valid feed source"
/// Valid values for the iTunes explicit rating
type ExplicitRating =
| Yes
| No
| Clean
/// Functions to support iTunes explicit ratings
module ExplicitRating =
/// Convert an explicit rating to a string
let toString : ExplicitRating -> string =
function
| Yes -> "yes"
| No -> "no"
| Clean -> "clean"
/// Parse a string into an explicit rating
let parse : string -> ExplicitRating =
function
| "yes" -> Yes
| "no" -> No
| "clean" -> Clean
| x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating")
/// Options for a feed that describes a podcast
type PodcastOptions =
{ /// The title of the podcast
title : string
/// A subtitle for the podcast
subtitle : string option
/// The number of items in the podcast feed
itemsInFeed : int
/// A summary of the podcast (iTunes field)
summary : string
/// The display name of the podcast author (iTunes field)
displayedAuthor : string
/// The e-mail address of the user who registered the podcast at iTunes
email : string
/// The link to the image for the podcast
imageUrl : Permalink
/// The category from iTunes under which this podcast is categorized
iTunesCategory : string
/// A further refinement of the categorization of this podcast (iTunes field / values)
iTunesSubcategory : string option
/// The explictness rating (iTunes field)
explicit : ExplicitRating
/// The default media type for files in this podcast
defaultMediaType : string option
/// The base URL for relative URL media files for this podcast (optional; defaults to web log base)
mediaBaseUrl : string option
}
/// A custom feed
type CustomFeed =
{ /// The ID of the custom feed
id : CustomFeedId
/// The source for the custom feed
source : CustomFeedSource
/// The path for the custom feed
path : Permalink
/// Podcast options, if the feed defines a podcast
podcast : PodcastOptions option
}
/// Functions to support custom feeds
module CustomFeed =
/// An empty custom feed
let empty =
{ id = CustomFeedId ""
source = Category (CategoryId "")
path = Permalink ""
podcast = None
}
/// Really Simple Syndication (RSS) options for this web log
[<CLIMutable; NoComparison; NoEquality>]
type RssOptions =
{ /// Whether the site feed of posts is enabled
feedEnabled : bool
/// The name of the file generated for the site feed
feedName : string
/// Override the "posts per page" setting for the site feed
itemsInFeed : int option
/// Whether feeds are enabled for all categories
categoryEnabled : bool
/// Whether feeds are enabled for all tags
tagEnabled : bool
/// A copyright string to be placed in all feeds
copyright : string option
/// Custom feeds for this web log
customFeeds: CustomFeed list
}
/// Functions to support RSS options
module RssOptions =
/// An empty set of RSS options
let empty =
{ feedEnabled = true
feedName = "feed.xml"
itemsInFeed = None
categoryEnabled = true
tagEnabled = true
copyright = None
customFeeds = []
}
/// An identifier for a tag mapping
type TagMapId = TagMapId of string
/// Functions to support tag mapping IDs
module TagMapId =
/// An empty tag mapping ID
let empty = TagMapId ""
/// Convert a tag mapping ID to a string
let toString = function TagMapId tmi -> tmi
/// Create a new tag mapping ID
let create () = TagMapId (newId ())
/// An identifier for a theme (represents its path)
type ThemeId = ThemeId of string
/// Functions to support theme IDs
module ThemeId =
let toString = function ThemeId ti -> ti
/// An identifier for a theme asset
type ThemeAssetId = ThemeAssetId of ThemeId * string
/// Functions to support theme asset IDs
module ThemeAssetId =
/// Convert a theme asset ID into a path string
let toString = function ThemeAssetId (ThemeId theme, asset) -> $"{theme}/{asset}"
/// Convert a string into a theme asset ID
let ofString (it : string) =
let themeIdx = it.IndexOf "/"
ThemeAssetId (ThemeId it[..(themeIdx - 1)], it[(themeIdx + 1)..])
/// A template for a theme
type ThemeTemplate =
{ /// The name of the template
name : string
/// The text of the template
text : string
}
/// An identifier for a web log
type WebLogId = WebLogId of string
/// Functions to support web log IDs
module WebLogId =
/// An empty web log ID
let empty = WebLogId ""
/// Convert a web log ID to a string
let toString = function WebLogId wli -> wli
/// Create a new web log ID
let create () = WebLogId (newId ())
/// A level of authorization for a given web log
type AuthorizationLevel =
/// <summary>The user may administer all aspects of a web log</summary>
| Administrator
/// <summary>The user is a known user of a web log</summary>
| User
/// Functions to support authorization levels
module AuthorizationLevel =
/// Convert an authorization level to a string
let toString = function Administrator -> "Administrator" | User -> "User"
/// Parse a string into an authorization level
let parse value =
match value with
| "Administrator" -> Administrator
| "User" -> User
| it -> invalidOp $"{it} is not a valid authorization level"
/// An identifier for a web log user
type WebLogUserId = WebLogUserId of string
/// Functions to support web log user IDs
module WebLogUserId =
/// An empty web log user ID
let empty = WebLogUserId ""
/// Convert a web log user ID to a string
let toString = function WebLogUserId wli -> wli
/// Create a new web log user ID
let create () = WebLogUserId (newId ())

740
src/MyWebLog.Domain/ViewModels.fs Normal file
View File

@@ -0,0 +1,740 @@
namespace MyWebLog.ViewModels
open System
open MyWebLog
/// Helper functions for view models
[<AutoOpen>]
module private Helpers =
/// Create a string option if a string is blank
let noneIfBlank (it : string) =
match it.Trim () with "" -> None | trimmed -> Some trimmed
/// Details about a category, used to display category lists
[<NoComparison; NoEquality>]
type DisplayCategory =
{ /// The ID of the category
id : string
/// The slug for the category
slug : string
/// The name of the category
name : string
/// A description of the category
description : string option
/// The parent category names for this (sub)category
parentNames : string[]
/// The number of posts in this category
postCount : int
}
/// A display version of a custom feed definition
type DisplayCustomFeed =
{ /// The ID of the custom feed
id : string
/// The source of the custom feed
source : string
/// The relative path at which the custom feed is served
path : string
/// Whether this custom feed is for a podcast
isPodcast : bool
}
/// Create a display version from a custom feed
static member fromFeed (cats : DisplayCategory[]) (feed : CustomFeed) : DisplayCustomFeed =
let source =
match feed.source with
| Category (CategoryId catId) -> $"Category: {(cats |> Array.find (fun cat -> cat.id = catId)).name}"
| Tag tag -> $"Tag: {tag}"
{ id = CustomFeedId.toString feed.id
source = source
path = Permalink.toString feed.path
isPodcast = Option.isSome feed.podcast
}
/// Details about a page used to display page lists
[<NoComparison; NoEquality>]
type DisplayPage =
{ /// The ID of this page
id : string
/// The title of the page
title : string
/// The link at which this page is displayed
permalink : string
/// When this page was published
publishedOn : DateTime
/// When this page was last updated
updatedOn : DateTime
/// Whether this page shows as part of the web log's navigation
showInPageList : bool
/// Is this the default page?
isDefault : bool
/// The text of the page
text : string
/// The metadata for the page
metadata : MetaItem list
}
/// Create a minimal display page (no text or metadata) from a database page
static member fromPageMinimal webLog (page : Page) =
let pageId = PageId.toString page.id
{ id = pageId
title = page.title
permalink = Permalink.toString page.permalink
publishedOn = page.publishedOn
updatedOn = page.updatedOn
showInPageList = page.showInPageList
isDefault = pageId = webLog.defaultPage
text = ""
metadata = []
}
/// Create a display page from a database page
static member fromPage webLog (page : Page) =
let _, extra = WebLog.hostAndPath webLog
let pageId = PageId.toString page.id
{ id = pageId
title = page.title
permalink = Permalink.toString page.permalink
publishedOn = page.publishedOn
updatedOn = page.updatedOn
showInPageList = page.showInPageList
isDefault = pageId = webLog.defaultPage
text = if extra = "" then page.text else page.text.Replace ("href=\"/", $"href=\"{extra}/")
metadata = page.metadata
}
/// The model used to display the admin dashboard
[<NoComparison; NoEquality>]
type DashboardModel =
{ /// The number of published posts
posts : int
/// The number of post drafts
drafts : int
/// The number of pages
pages : int
/// The number of pages in the page list
listedPages : int
/// The number of categories
categories : int
/// The top-level categories
topLevelCategories : int
}
/// View model for editing categories
[<CLIMutable; NoComparison; NoEquality>]
type EditCategoryModel =
{ /// The ID of the category being edited
categoryId : string
/// The name of the category
name : string
/// The category's URL slug
slug : string
/// A description of the category (optional)
description : string
/// The ID of the category for which this is a subcategory (optional)
parentId : string
}
/// Create an edit model from an existing category
static member fromCategory (cat : Category) =
{ categoryId = CategoryId.toString cat.id
name = cat.name
slug = cat.slug
description = defaultArg cat.description ""
parentId = cat.parentId |> Option.map CategoryId.toString |> Option.defaultValue ""
}
/// View model to edit a custom RSS feed
[<CLIMutable; NoComparison; NoEquality>]
type EditCustomFeedModel =
{ /// The ID of the feed being editing
id : string
/// The type of source for this feed ("category" or "tag")
sourceType : string
/// The category ID or tag on which this feed is based
sourceValue : string
/// The relative path at which this feed is served
path : string
/// Whether this feed defines a podcast
isPodcast : bool
/// The title of the podcast
title : string
/// A subtitle for the podcast
subtitle : string
/// The number of items in the podcast feed
itemsInFeed : int
/// A summary of the podcast (iTunes field)
summary : string
/// The display name of the podcast author (iTunes field)
displayedAuthor : string
/// The e-mail address of the user who registered the podcast at iTunes
email : string
/// The link to the image for the podcast
imageUrl : string
/// The category from iTunes under which this podcast is categorized
itunesCategory : string
/// A further refinement of the categorization of this podcast (iTunes field / values)
itunesSubcategory : string
/// The explictness rating (iTunes field)
explicit : string
/// The default media type for files in this podcast
defaultMediaType : string
/// The base URL for relative URL media files for this podcast (optional; defaults to web log base)
mediaBaseUrl : string
}
/// An empty custom feed model
static member empty =
{ id = ""
sourceType = "category"
sourceValue = ""
path = ""
isPodcast = false
title = ""
subtitle = ""
itemsInFeed = 25
summary = ""
displayedAuthor = ""
email = ""
imageUrl = ""
itunesCategory = ""
itunesSubcategory = ""
explicit = "no"
defaultMediaType = "audio/mpeg"
mediaBaseUrl = ""
}
/// Create a model from a custom feed
static member fromFeed (feed : CustomFeed) =
let rss =
{ EditCustomFeedModel.empty with
id = CustomFeedId.toString feed.id
sourceType = match feed.source with Category _ -> "category" | Tag _ -> "tag"
sourceValue = match feed.source with Category (CategoryId catId) -> catId | Tag tag -> tag
path = Permalink.toString feed.path
}
match feed.podcast with
| Some p ->
{ rss with
isPodcast = true
title = p.title
subtitle = defaultArg p.subtitle ""
itemsInFeed = p.itemsInFeed
summary = p.summary
displayedAuthor = p.displayedAuthor
email = p.email
imageUrl = Permalink.toString p.imageUrl
itunesCategory = p.iTunesCategory
itunesSubcategory = defaultArg p.iTunesSubcategory ""
explicit = ExplicitRating.toString p.explicit
defaultMediaType = defaultArg p.defaultMediaType ""
mediaBaseUrl = defaultArg p.mediaBaseUrl ""
}
| None -> rss
/// Update a feed with values from this model
member this.updateFeed (feed : CustomFeed) =
{ feed with
source = if this.sourceType = "tag" then Tag this.sourceValue else Category (CategoryId this.sourceValue)
path = Permalink this.path
podcast =
if this.isPodcast then
Some {
title = this.title
subtitle = noneIfBlank this.subtitle
itemsInFeed = this.itemsInFeed
summary = this.summary
displayedAuthor = this.displayedAuthor
email = this.email
imageUrl = Permalink this.imageUrl
iTunesCategory = this.itunesCategory
iTunesSubcategory = noneIfBlank this.itunesSubcategory
explicit = ExplicitRating.parse this.explicit
defaultMediaType = noneIfBlank this.defaultMediaType
mediaBaseUrl = noneIfBlank this.mediaBaseUrl
}
else
None
}
/// View model to edit a page
[<CLIMutable; NoComparison; NoEquality>]
type EditPageModel =
{ /// The ID of the page being edited
pageId : string
/// The title of the page
title : string
/// The permalink for the page
permalink : string
/// The template to use to display the page
template : string
/// Whether this page is shown in the page list
isShownInPageList : bool
/// The source format for the text
source : string
/// The text of the page
text : string
/// Names of metadata items
metaNames : string[]
/// Values of metadata items
metaValues : string[]
}
/// Create an edit model from an existing page
static member fromPage (page : Page) =
let latest =
match page.revisions |> List.sortByDescending (fun r -> r.asOf) |> List.tryHead with
| Some rev -> rev
| None -> Revision.empty
let page = if page.metadata |> List.isEmpty then { page with metadata = [ MetaItem.empty ] } else page
{ pageId = PageId.toString page.id
title = page.title
permalink = Permalink.toString page.permalink
template = defaultArg page.template ""
isShownInPageList = page.showInPageList
source = MarkupText.sourceType latest.text
text = MarkupText.text latest.text
metaNames = page.metadata |> List.map (fun m -> m.name) |> Array.ofList
metaValues = page.metadata |> List.map (fun m -> m.value) |> Array.ofList
}
/// View model to edit a post
[<CLIMutable; NoComparison; NoEquality>]
type EditPostModel =
{ /// The ID of the post being edited
postId : string
/// The title of the post
title : string
/// The permalink for the post
permalink : string
/// The source format for the text
source : string
/// The text of the post
text : string
/// The tags for the post
tags : string
/// The template used to display the post
template : string
/// The category IDs for the post
categoryIds : string[]
/// The post status
status : string
/// Whether this post should be published
doPublish : bool
/// Names of metadata items
metaNames : string[]
/// Values of metadata items
metaValues : string[]
/// Whether to override the published date/time
setPublished : bool
/// The published date/time to override
pubOverride : Nullable<DateTime>
/// Whether all revisions should be purged and the override date set as the updated date as well
setUpdated : bool
}
/// Create an edit model from an existing past
static member fromPost webLog (post : Post) =
let latest =
match post.revisions |> List.sortByDescending (fun r -> r.asOf) |> List.tryHead with
| Some rev -> rev
| None -> Revision.empty
let post = if post.metadata |> List.isEmpty then { post with metadata = [ MetaItem.empty ] } else post
{ postId = PostId.toString post.id
title = post.title
permalink = Permalink.toString post.permalink
source = MarkupText.sourceType latest.text
text = MarkupText.text latest.text
tags = String.Join (", ", post.tags)
template = defaultArg post.template ""
categoryIds = post.categoryIds |> List.map CategoryId.toString |> Array.ofList
status = PostStatus.toString post.status
doPublish = false
metaNames = post.metadata |> List.map (fun m -> m.name) |> Array.ofList
metaValues = post.metadata |> List.map (fun m -> m.value) |> Array.ofList
setPublished = false
pubOverride = post.publishedOn |> Option.map (WebLog.localTime webLog) |> Option.toNullable
setUpdated = false
}
/// View model to edit RSS settings
[<CLIMutable; NoComparison; NoEquality>]
type EditRssModel =
{ /// Whether the site feed of posts is enabled
feedEnabled : bool
/// The name of the file generated for the site feed
feedName : string
/// Override the "posts per page" setting for the site feed
itemsInFeed : int
/// Whether feeds are enabled for all categories
categoryEnabled : bool
/// Whether feeds are enabled for all tags
tagEnabled : bool
/// A copyright string to be placed in all feeds
copyright : string
}
/// Create an edit model from a set of RSS options
static member fromRssOptions (rss : RssOptions) =
{ feedEnabled = rss.feedEnabled
feedName = rss.feedName
itemsInFeed = defaultArg rss.itemsInFeed 0
categoryEnabled = rss.categoryEnabled
tagEnabled = rss.tagEnabled
copyright = defaultArg rss.copyright ""
}
/// Update RSS options from values in this mode
member this.updateOptions (rss : RssOptions) =
{ rss with
feedEnabled = this.feedEnabled
feedName = this.feedName
itemsInFeed = if this.itemsInFeed = 0 then None else Some this.itemsInFeed
categoryEnabled = this.categoryEnabled
tagEnabled = this.tagEnabled
copyright = noneIfBlank this.copyright
}
/// View model to edit a tag mapping
[<CLIMutable; NoComparison; NoEquality>]
type EditTagMapModel =
{ /// The ID of the tag mapping being edited
id : string
/// The tag being mapped to a different link value
tag : string
/// The link value for the tag
urlValue : string
}
/// Whether this is a new tag mapping
member this.isNew = this.id = "new"
/// Create an edit model from the tag mapping
static member fromMapping (tagMap : TagMap) : EditTagMapModel =
{ id = TagMapId.toString tagMap.id
tag = tagMap.tag
urlValue = tagMap.urlValue
}
/// View model to edit a user
[<CLIMutable; NoComparison; NoEquality>]
type EditUserModel =
{ /// The user's first name
firstName : string
/// The user's last name
lastName : string
/// The user's preferred name
preferredName : string
/// A new password for the user
newPassword : string
/// A new password for the user, confirmed
newPasswordConfirm : string
}
/// Create an edit model from a user
static member fromUser (user : WebLogUser) =
{ firstName = user.firstName
lastName = user.lastName
preferredName = user.preferredName
newPassword = ""
newPasswordConfirm = ""
}
/// The model to use to allow a user to log on
[<CLIMutable; NoComparison; NoEquality>]
type LogOnModel =
{ /// The user's e-mail address
emailAddress : string
/// The user's password
password : string
/// Where the user should be redirected once they have logged on
returnTo : string option
}
/// An empty log on model
static member empty =
{ emailAddress = ""; password = ""; returnTo = None }
/// View model to manage permalinks
[<CLIMutable; NoComparison; NoEquality>]
type ManagePermalinksModel =
{ /// The ID for the entity being edited
id : string
/// The type of entity being edited ("page" or "post")
entity : string
/// The current title of the page or post
currentTitle : string
/// The current permalink of the page or post
currentPermalink : string
/// The prior permalinks for the page or post
prior : string[]
}
/// Create a permalink model from a page
static member fromPage (pg : Page) =
{ id = PageId.toString pg.id
entity = "page"
currentTitle = pg.title
currentPermalink = Permalink.toString pg.permalink
prior = pg.priorPermalinks |> List.map Permalink.toString |> Array.ofList
}
/// Create a permalink model from a post
static member fromPost (post : Post) =
{ id = PostId.toString post.id
entity = "post"
currentTitle = post.title
currentPermalink = Permalink.toString post.permalink
prior = post.priorPermalinks |> List.map Permalink.toString |> Array.ofList
}
/// View model for posts in a list
[<NoComparison; NoEquality>]
type PostListItem =
{ /// The ID of the post
id : string
/// The ID of the user who authored the post
authorId : string
/// The status of the post
status : string
/// The title of the post
title : string
/// The permalink for the post
permalink : string
/// When this post was published
publishedOn : Nullable<DateTime>
/// When this post was last updated
updatedOn : DateTime
/// The text of the post
text : string
/// The IDs of the categories for this post
categoryIds : string list
/// Tags for the post
tags : string list
/// Metadata for the post
metadata : MetaItem list
}
/// Create a post list item from a post
static member fromPost (webLog : WebLog) (post : Post) =
let _, extra = WebLog.hostAndPath webLog
let inTZ = WebLog.localTime webLog
{ id = PostId.toString post.id
authorId = WebLogUserId.toString post.authorId
status = PostStatus.toString post.status
title = post.title
permalink = Permalink.toString post.permalink
publishedOn = post.publishedOn |> Option.map inTZ |> Option.toNullable
updatedOn = inTZ post.updatedOn
text = if extra = "" then post.text else post.text.Replace ("href=\"/", $"href=\"{extra}/")
categoryIds = post.categoryIds |> List.map CategoryId.toString
tags = post.tags
metadata = post.metadata
}
/// View model for displaying posts
type PostDisplay =
{ /// The posts to be displayed
posts : PostListItem[]
/// Author ID -> name lookup
authors : MetaItem list
/// A subtitle for the page
subtitle : string option
/// The link to view newer (more recent) posts
newerLink : string option
/// The name of the next newer post (single-post only)
newerName : string option
/// The link to view older (less recent) posts
olderLink : string option
/// The name of the next older post (single-post only)
olderName : string option
}
/// View model for editing web log settings
[<CLIMutable; NoComparison; NoEquality>]
type SettingsModel =
{ /// The name of the web log
name : string
/// The subtitle of the web log
subtitle : string
/// The default page
defaultPage : string
/// How many posts should appear on index pages
postsPerPage : int
/// The time zone in which dates/times should be displayed
timeZone : string
/// The theme to use to display the web log
themePath : string
/// Whether to automatically load htmx
autoHtmx : bool
}
/// Create a settings model from a web log
static member fromWebLog (webLog : WebLog) =
{ name = webLog.name
subtitle = defaultArg webLog.subtitle ""
defaultPage = webLog.defaultPage
postsPerPage = webLog.postsPerPage
timeZone = webLog.timeZone
themePath = webLog.themePath
autoHtmx = webLog.autoHtmx
}
/// Update a web log with settings from the form
member this.update (webLog : WebLog) =
{ webLog with
name = this.name
subtitle = if this.subtitle = "" then None else Some this.subtitle
defaultPage = this.defaultPage
postsPerPage = this.postsPerPage
timeZone = this.timeZone
themePath = this.themePath
autoHtmx = this.autoHtmx
}
[<CLIMutable; NoComparison; NoEquality>]
type UserMessage =
{ /// The level of the message
level : string
/// The message
message : string
/// Further details about the message
detail : string option
}
/// Functions to support user messages
module UserMessage =
/// An empty user message (use one of the others for pre-filled level)
let empty = { level = ""; message = ""; detail = None }
/// A blank success message
let success = { empty with level = "success" }
/// A blank informational message
let info = { empty with level = "primary" }
/// A blank warning message
let warning = { empty with level = "warning" }
/// A blank error message
let error = { empty with level = "danger" }

178
src/MyWebLog.Migrate/Program.fs
View File

@@ -1,178 +0,0 @@
module Program
open MyWebLog
open MyWebLog.Data.RethinkDB
open MyWebLog.Entities
open Nancy.Cryptography
open Newtonsoft.Json
open Newtonsoft.Json.Linq
open NodaTime
open RethinkDb.Driver
open System
open System.Linq
let r = RethinkDB.R
let appCfg = try AppConfig.FromJson (System.IO.File.ReadAllText "config.json")
with ex -> raise <| Exception ("Bad config.json file", ex)
let cfg = appCfg.DataConfig
// DataConfig.Connect
// (JsonConvert.DeserializeObject<DataConfig>("""{ "hostname" : "data01", "authKey" : "1d9a76f8-2d85-4033-be15-1f4313a96bb2", "database" : "myWebLog" }"""))
let conn = cfg.Conn
let toTicks (dt : DateTime) = Instant.FromDateTimeUtc(dt.ToUniversalTime()).ToUnixTimeTicks ()
/// Hash the user's password
let pbkdf2 (pw : string) =
PassphraseKeyGenerator(pw, appCfg.PasswordSalt, 4096).GetBytes 512
|> Seq.fold (fun acc byt -> sprintf "%s%s" acc (byt.ToString "x2")) ""
let migr8 () =
SetUp.startUpCheck cfg
Console.WriteLine "Migrating web logs..."
r.Db("MyWebLog").Table(Table.WebLog)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.WebLog)
.Insert({ Id = string x.["id"]
Name = string x.["name"]
Subtitle = Some <| string x.["subtitle"]
DefaultPage = string x.["defaultPage"]
ThemePath = string x.["themePath"]
TimeZone = string x.["timeZone"]
UrlBase = string x.["urlBase"]
PageList = []
})
.RunResult(conn)
|> ignore)
Console.WriteLine "Migrating users..."
r.Db("MyWebLog").Table(Table.User)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.User)
.Insert({ Id = string x.["id"]
UserName = string x.["userName"]
FirstName = string x.["firstName"]
LastName = string x.["lastName"]
PreferredName = string x.["preferredName"]
PasswordHash = string x.["passwordHash"]
Url = Some <| string x.["url"]
Authorizations = x.["authorizations"] :?> JArray
|> Seq.map (fun y -> { WebLogId = string y.["webLogId"]
Level = string y.["level"] })
|> Seq.toList
})
.RunResult(conn)
|> ignore)
Console.WriteLine "Migrating categories..."
r.Db("MyWebLog").Table(Table.Category)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.Category)
.Insert({ Id = string x.["id"]
WebLogId = string x.["webLogId"]
Name = string x.["name"]
Slug = string x.["slug"]
Description = match String.IsNullOrEmpty(string x.["description"]) with
| true -> None
| _ -> Some <| string x.["description"]
ParentId = match String.IsNullOrEmpty(string x.["parentId"]) with
| true -> None
| _ -> Some <| string x.["parentId"]
Children = x.["children"] :?> JArray
|> Seq.map (fun y -> string y)
|> Seq.toList
})
.RunResult(conn)
|> ignore)
Console.WriteLine "Migrating comments..."
r.Db("MyWebLog").Table(Table.Comment)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.Comment)
.Insert({ Id = string x.["id"]
PostId = string x.["postId"]
InReplyToId = match String.IsNullOrEmpty(string x.["inReplyToId"]) with
| true -> None
| _ -> Some <| string x.["inReplyToId"]
Name = string x.["name"]
Email = string x.["email"]
Url = match String.IsNullOrEmpty(string x.["url"]) with
| true -> None
| _ -> Some <| string x.["url"]
Status = string x.["status"]
PostedOn = x.["postedDate"].ToObject<DateTime>() |> toTicks
Text = string x.["text"]
})
.RunResult(conn)
|> ignore)
Console.WriteLine "Migrating pages..."
r.Db("MyWebLog").Table(Table.Page)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.Page)
.Insert({ Id = string x.["id"]
WebLogId = string x.["webLogId"]
AuthorId = string x.["authorId"]
Title = string x.["title"]
Permalink = string x.["permalink"]
PublishedOn = x.["publishedDate"].ToObject<DateTime> () |> toTicks
UpdatedOn = x.["lastUpdatedDate"].ToObject<DateTime> () |> toTicks
ShowInPageList = x.["showInPageList"].ToObject<bool>()
Text = string x.["text"]
Revisions = [{ AsOf = x.["lastUpdatedDate"].ToObject<DateTime> () |> toTicks
SourceType = RevisionSource.HTML
Text = string x.["text"]
}]
})
.RunResult(conn)
|> ignore)
Console.WriteLine "Migrating posts..."
r.Db("MyWebLog").Table(Table.Post)
.RunCursor<JObject>(conn)
|> Seq.iter (fun x ->
r.Db("myWebLog").Table(Table.Post)
.Insert({ Id = string x.["id"]
WebLogId = string x.["webLogId"]
AuthorId = "9b491a0f-48df-4b7b-8c10-120b5cd02895"
Status = string x.["status"]
Title = string x.["title"]
Permalink = string x.["permalink"]
PublishedOn = match x.["publishedDate"] with
| null -> int64 0
| dt -> dt.ToObject<DateTime> () |> toTicks
UpdatedOn = x.["lastUpdatedDate"].ToObject<DateTime> () |> toTicks
Revisions = [{ AsOf = x.["lastUpdatedDate"].ToObject<DateTime> ()
|> toTicks
SourceType = RevisionSource.HTML
Text = string x.["text"]
}]
Text = string x.["text"]
Tags = x.["tag"] :?> JArray
|> Seq.map (fun y -> string y)
|> Seq.toList
CategoryIds = x.["category"] :?> JArray
|> Seq.map (fun y -> string y)
|> Seq.toList
PriorPermalinks = []
Categories = []
Comments = []
})
.RunResult(conn)
|> ignore)
[<EntryPoint>]
let main argv =
migr8 ()
0 // return an integer exit code

33
src/MyWebLog.Migrate/project.json
View File

@@ -1,33 +0,0 @@
{
"version": "1.0.0-*",
"buildOptions": {
"debugType": "portable",
"emitEntryPoint": true,
"compilerName": "fsc",
"compile": {
"includeFiles": [
"Program.fs"
]
}
},
"dependencies": {
"MyWebLog.App": "0.9.2",
"MyWebLog.Data.RethinkDB": "0.9.2",
"MyWebLog.Entities": "0.9.2",
"NodaTime": "2.0.0-alpha20160729"
},
"tools": {
"dotnet-compile-fsc":"1.0.0-preview2-*"
},
"frameworks": {
"netcoreapp1.0": {
"dependencies": {
"Microsoft.NETCore.App": {
"type": "platform",
"version": "1.0.1"
},
"Microsoft.FSharp.Core.netcore": "1.0.0-alpha-160629"
}
}
}
}

4
src/MyWebLog.Tests/MyWebLog.Tests.fs
View File

@@ -1,4 +0,0 @@
namespace MyWebLog.Web
type Web() =
member this.X = "F#"

70
src/MyWebLog.Tests/MyWebLog.Tests.fsproj
View File

@@ -1,70 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<Project ToolsVersion="12.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<Import Project="$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props" Condition="Exists('$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props')" />
<PropertyGroup>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<SchemaVersion>2.0</SchemaVersion>
<ProjectGuid>07e60874-6cf5-4d53-aee0-f17ef28228dd</ProjectGuid>
<OutputType>Library</OutputType>
<RootNamespace>MyWebLog.Tests</RootNamespace>
<AssemblyName>MyWebLog.Tests</AssemblyName>
<TargetFrameworkVersion>v4.5.2</TargetFrameworkVersion>
<TargetFSharpCoreVersion>4.4.0.0</TargetFSharpCoreVersion>
<Name>MyWebLog.Tests</Name>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
<DebugSymbols>true</DebugSymbols>
<DebugType>full</DebugType>
<Optimize>false</Optimize>
<Tailcalls>false</Tailcalls>
<OutputPath>bin\Debug\</OutputPath>
<DefineConstants>DEBUG;TRACE</DefineConstants>
<WarningLevel>3</WarningLevel>
<DocumentationFile>bin\Debug\MyWebLog.Tests.xml</DocumentationFile>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
<DebugType>pdbonly</DebugType>
<Optimize>true</Optimize>
<Tailcalls>true</Tailcalls>
<OutputPath>bin\Release\</OutputPath>
<DefineConstants>TRACE</DefineConstants>
<WarningLevel>3</WarningLevel>
<DocumentationFile>bin\Release\MyWebLog.Tests.xml</DocumentationFile>
</PropertyGroup>
<ItemGroup>
<Reference Include="mscorlib" />
<Reference Include="FSharp.Core, Version=$(TargetFSharpCoreVersion), Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
<Private>True</Private>
</Reference>
<Reference Include="System" />
<Reference Include="System.Core" />
<Reference Include="System.Numerics" />
</ItemGroup>
<ItemGroup>
<Compile Include="MyWebLog.Tests.fs" />
</ItemGroup>
<PropertyGroup>
<MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
</PropertyGroup>
<Choose>
<When Condition="'$(VisualStudioVersion)' == '11.0'">
<PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets')">
<FSharpTargetsPath>$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets</FSharpTargetsPath>
</PropertyGroup>
</When>
<Otherwise>
<PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets')">
<FSharpTargetsPath>$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets</FSharpTargetsPath>
</PropertyGroup>
</Otherwise>
</Choose>
<Import Project="$(FSharpTargetsPath)" Condition="Exists('$(FSharpTargetsPath)')" />
<!-- To modify your build process, add your task inside one of the targets below and uncomment it.
Other similar extension points exist, see Microsoft.Common.targets.
<Target Name="BeforeBuild">
</Target>
<Target Name="AfterBuild">
</Target>
-->
</Project>

37
src/MyWebLog.sln Normal file
View File

@@ -0,0 +1,37 @@

Microsoft Visual Studio Solution File, Format Version 12.00
# Visual Studio Version 17
VisualStudioVersion = 17.1.32210.238
MinimumVisualStudioVersion = 10.0.40219.1
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MyWebLog.Domain", "MyWebLog.Domain\MyWebLog.Domain.fsproj", "{8CA99122-888A-4524-8C1B-685F0A4B7B4B}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MyWebLog.Data", "MyWebLog.Data\MyWebLog.Data.fsproj", "{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "MyWebLog", "MyWebLog\MyWebLog.fsproj", "{5655B63D-429F-4CCD-A14C-FBD74D987ECB}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Any CPU = Debug|Any CPU
Release|Any CPU = Release|Any CPU
EndGlobalSection
GlobalSection(ProjectConfigurationPlatforms) = postSolution
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Debug|Any CPU.Build.0 = Debug|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Release|Any CPU.ActiveCfg = Release|Any CPU
{8CA99122-888A-4524-8C1B-685F0A4B7B4B}.Release|Any CPU.Build.0 = Release|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Debug|Any CPU.Build.0 = Debug|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Release|Any CPU.ActiveCfg = Release|Any CPU
{D284584D-2CB2-40C8-B605-6D0FD84D9D3D}.Release|Any CPU.Build.0 = Release|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Debug|Any CPU.Build.0 = Debug|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Release|Any CPU.ActiveCfg = Release|Any CPU
{5655B63D-429F-4CCD-A14C-FBD74D987ECB}.Release|Any CPU.Build.0 = Release|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {70EEF0F4-8709-44A8-AD9B-24D1EB84CFB4}
EndGlobalSection
EndGlobal

157
src/MyWebLog/Caches.fs Normal file
View File

@@ -0,0 +1,157 @@
namespace MyWebLog
open Microsoft.AspNetCore.Http
open MyWebLog.Data
/// Extension properties on HTTP context for web log
[<AutoOpen>]
module Extensions =
open Microsoft.Extensions.DependencyInjection
type HttpContext with
/// The web log for the current request
member this.WebLog = this.Items["webLog"] :?> WebLog
/// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> ()
open System.Collections.Concurrent
/// <summary>
/// In-memory cache of web log details
/// </summary>
/// <remarks>This is filled by the middleware via the first request for each host, and can be updated via the web log
/// settings update page</remarks>
module WebLogCache =
/// The cache of web log details
let mutable private _cache : WebLog list = []
/// Try to get the web log for the current request (longest matching URL base wins)
let tryGet (path : string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.urlBase)
|> List.sortByDescending (fun wl -> wl.urlBase.Length)
|> List.tryHead
/// Cache the web log for a particular host
let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id))
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
let! webLogs = data.WebLog.all ()
_cache <- webLogs
}
/// A cache of page information needed to display the page list in templates
module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
let private _cache = ConcurrentDictionary<string, DisplayPage[]> ()
/// Are there pages cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase
/// Get the pages for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase]
/// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask {
let webLog = ctx.WebLog
let! pages = ctx.Data.Page.findListed webLog.id
_cache[webLog.urlBase] <-
pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
|> Array.ofList
}
/// Cache of all categories, indexed by web log
module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
let private _cache = ConcurrentDictionary<string, DisplayCategory[]> ()
/// Are there categories cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase
/// Get the categories for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase]
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.findAllForView ctx.WebLog.id
_cache[ctx.WebLog.urlBase] <- cats
}
/// Cache for parsed templates
module TemplateCache =
open System
open System.Text.RegularExpressions
open DotLiquid
/// Cache of parsed templates
let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId : string) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> ()
| false ->
match! data.Theme.findById (ThemeId themeId) with
| Some theme ->
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
while hasInclude.IsMatch text do
let child = hasInclude.Match text
let childText = (theme.templates |> List.find (fun t -> t.name = child.Groups[1].Value)).text
text <- text.Replace (child.Value, childText)
_cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22)
| None -> ()
return _cache[templatePath]
}
/// Invalidate all template cache entries for the given theme ID
let invalidateTheme (themeId : string) =
_cache.Keys
|> Seq.filter (fun key -> key.StartsWith themeId)
|> List.ofSeq
|> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ())
/// A cache of asset names by themes
module ThemeAssetCache =
/// A list of asset names for each theme
let private _cache = ConcurrentDictionary<ThemeId, string list> ()
/// Retrieve the assets for the given theme ID
let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme
let refreshTheme themeId (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.findByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.id with ThemeAssetId (_, path) -> path)
}
/// Fill the theme asset cache
let fill (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.all ()
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []
_cache[themeId] <- path :: _cache[themeId]
}

237
src/MyWebLog/DotLiquidBespoke.fs Normal file
View File

@@ -0,0 +1,237 @@
/// Custom DotLiquid filters and tags
module MyWebLog.DotLiquidBespoke
open System
open System.IO
open System.Web
open DotLiquid
open Giraffe.ViewEngine
open MyWebLog.ViewModels
/// Get the current web log from the DotLiquid context
let webLog (ctx : Context) =
ctx.Environments[0].["web_log"] :?> WebLog
/// Does an asset exist for the current theme?
let assetExists fileName (webLog : WebLog) =
ThemeAssetCache.get (ThemeId webLog.themePath) |> List.exists (fun it -> it = fileName)
/// Obtain the link from known types
let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> string) =
match item with
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.permalink
| :? PostListItem as post -> Some post.permalink
| :? DropProxy as proxy -> Option.ofObj proxy["permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc (webLog ctx) (Permalink link)
| None -> $"alert('unknown item type {item.GetType().Name}')"
/// A filter to generate an absolute link
type AbsoluteLinkFilter () =
static member AbsoluteLink (ctx : Context, item : obj) =
permalink ctx item WebLog.absoluteUrl
/// A filter to generate a link with posts categorized under the given category
type CategoryLinkFilter () =
static member CategoryLink (ctx : Context, catObj : obj) =
match catObj with
| :? DisplayCategory as cat -> Some cat.slug
| :? DropProxy as proxy -> Option.ofObj proxy["slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> WebLog.relativeUrl (webLog ctx) (Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {catObj.GetType().Name}')"
/// A filter to generate a link that will edit a page
type EditPageLinkFilter () =
static member EditPageLink (ctx : Context, pageObj : obj) =
match pageObj with
| :? DisplayPage as page -> Some page.id
| :? DropProxy as proxy -> Option.ofObj proxy["id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some pageId -> WebLog.relativeUrl (webLog ctx) (Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {pageObj.GetType().Name}')"
/// A filter to generate a link that will edit a post
type EditPostLinkFilter () =
static member EditPostLink (ctx : Context, postObj : obj) =
match postObj with
| :? PostListItem as post -> Some post.id
| :? DropProxy as proxy -> Option.ofObj proxy["id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some postId -> WebLog.relativeUrl (webLog ctx) (Permalink $"admin/post/{postId}/edit")
| None -> $"alert('unknown post object type {postObj.GetType().Name}')"
/// A filter to generate nav links, highlighting the active link (exact match)
type NavLinkFilter () =
static member NavLink (ctx : Context, url : string, text : string) =
let webLog = webLog ctx
let _, path = WebLog.hostAndPath webLog
let path = if path = "" then path else $"{path.Substring 1}/"
seq {
"<li class=\"nav-item\"><a class=\"nav-link"
if (string ctx.Environments[0].["current_page"]).StartsWith $"{path}{url}" then " active"
"\" href=\""
WebLog.relativeUrl webLog (Permalink url)
"\">"
text
"</a></li>"
}
|> Seq.fold (+) ""
/// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
type ThemeAssetFilter () =
static member ThemeAsset (ctx : Context, asset : string) =
let webLog = webLog ctx
WebLog.relativeUrl webLog (Permalink $"themes/{webLog.themePath}/{asset}")
/// Create various items in the page header based on the state of the page being generated
type PageHeadTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
// spacer
let s = " "
let getBool name =
context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean |> Option.defaultValue false
result.WriteLine $"""<meta name="generator" content="{context.Environments[0].["generator"]}">"""
// Theme assets
if assetExists "style.css" webLog then
result.WriteLine $"""{s}<link rel="stylesheet" href="{ThemeAssetFilter.ThemeAsset (context, "style.css")}">"""
if assetExists "favicon.ico" webLog then
result.WriteLine $"""{s}<link rel="icon" href="{ThemeAssetFilter.ThemeAsset (context, "favicon.ico")}">"""
// RSS feeds and canonical URLs
let feedLink title url =
let escTitle = HttpUtility.HtmlAttributeEncode title
let relUrl = WebLog.relativeUrl webLog (Permalink url)
$"""{s}<link rel="alternate" type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
if webLog.rss.feedEnabled && getBool "is_home" then
result.WriteLine (feedLink webLog.name webLog.rss.feedName)
result.WriteLine $"""{s}<link rel="canonical" href="{WebLog.absoluteUrl webLog Permalink.empty}">"""
if webLog.rss.categoryEnabled && getBool "is_category_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine (feedLink webLog.name $"category/{slug}/{webLog.rss.feedName}")
if webLog.rss.tagEnabled && getBool "is_tag_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine (feedLink webLog.name $"tag/{slug}/{webLog.rss.feedName}")
if getBool "is_post" then
let post = context.Environments[0].["model"] :?> PostDisplay
let url = WebLog.absoluteUrl webLog (Permalink post.posts[0].permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
if getBool "is_page" then
let page = context.Environments[0].["page"] :?> DisplayPage
let url = WebLog.absoluteUrl webLog (Permalink page.permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
/// Create various items in the page header based on the state of the page being generated
type PageFootTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
// spacer
let s = " "
if webLog.autoHtmx then
result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset (context, "script.js")}"></script>"""
/// A filter to generate a relative link
type RelativeLinkFilter () =
static member RelativeLink (ctx : Context, item : obj) =
permalink ctx item WebLog.relativeUrl
/// A filter to generate a link with posts tagged with the given tag
type TagLinkFilter () =
static member TagLink (ctx : Context, tag : string) =
ctx.Environments[0].["tag_mappings"] :?> TagMap list
|> List.tryFind (fun it -> it.tag = tag)
|> function
| Some tagMap -> tagMap.urlValue
| None -> tag.Replace (" ", "+")
|> function tagUrl -> WebLog.relativeUrl (webLog ctx) (Permalink $"tag/{tagUrl}/")
/// Create links for a user to log on or off, and a dashboard link if they are logged off
type UserLinksTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
let link it = WebLog.relativeUrl webLog (Permalink it)
seq {
"""<ul class="navbar-nav flex-grow-1 justify-content-end">"""
match Convert.ToBoolean context.Environments[0].["logged_on"] with
| true ->
$"""<li class="nav-item"><a class="nav-link" href="{link "admin/dashboard"}">Dashboard</a></li>"""
$"""<li class="nav-item"><a class="nav-link" href="{link "user/log-off"}">Log Off</a></li>"""
| false ->
$"""<li class="nav-item"><a class="nav-link" href="{link "user/log-on"}">Log On</a></li>"""
"</ul>"
}
|> Seq.iter result.WriteLine
/// A filter to retrieve the value of a meta item from a list
// (shorter than `{% assign item = list | where: "name", [name] | first %}{{ item.value }}`)
type ValueFilter () =
static member Value (_ : Context, items : MetaItem list, name : string) =
match items |> List.tryFind (fun it -> it.name = name) with
| Some item -> item.value
| None -> $"-- {name} not found --"
open System.Collections.Generic
open Microsoft.AspNetCore.Antiforgery
/// Register custom filters/tags and safe types
let register () =
[ typeof<AbsoluteLinkFilter>; typeof<CategoryLinkFilter>; typeof<EditPageLinkFilter>; typeof<EditPostLinkFilter>
typeof<NavLinkFilter>; typeof<RelativeLinkFilter>; typeof<TagLinkFilter>; typeof<ThemeAssetFilter>
typeof<ValueFilter>
]
|> List.iter Template.RegisterFilter
Template.RegisterTag<PageHeadTag> "page_head"
Template.RegisterTag<PageFootTag> "page_foot"
Template.RegisterTag<UserLinksTag> "user_links"
[ // Domain types
typeof<CustomFeed>; typeof<MetaItem>; typeof<Page>; typeof<RssOptions>; typeof<TagMap>; typeof<WebLog>
// View models
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<EditCategoryModel>; typeof<EditCustomFeedModel>; typeof<EditPageModel>; typeof<EditPostModel>
typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>; typeof<LogOnModel>
typeof<ManagePermalinksModel>; typeof<PostDisplay>; typeof<PostListItem>; typeof<SettingsModel>
typeof<UserMessage>
// Framework types
typeof<AntiforgeryTokenSet>; typeof<int option>; typeof<KeyValuePair>; typeof<MetaItem list>
typeof<string list>; typeof<string option>; typeof<TagMap list>
]
|> List.iter (fun it -> Template.RegisterSafeType (it, [| "*" |]))

504
src/MyWebLog/Handlers/Admin.fs Normal file
View File

@@ -0,0 +1,504 @@
/// Handlers to manipulate admin functions
module MyWebLog.Handlers.Admin
open System.Threading.Tasks
open DotLiquid
open Giraffe
open MyWebLog
open MyWebLog.ViewModels
// GET /admin
let dashboard : HttpHandler = fun next ctx -> task {
let webLogId = ctx.WebLog.id
let data = ctx.Data
let getCount (f : WebLogId -> Task<int>) = f webLogId
let! posts = data.Post.countByStatus Published |> getCount
let! drafts = data.Post.countByStatus Draft |> getCount
let! pages = data.Page.countAll |> getCount
let! listed = data.Page.countListed |> getCount
let! cats = data.Category.countAll |> getCount
let! topCats = data.Category.countTopLevel |> getCount
return!
Hash.FromAnonymousObject {|
page_title = "Dashboard"
model =
{ posts = posts
drafts = drafts
pages = pages
listedPages = listed
categories = cats
topLevelCategories = topCats
}
|}
|> viewForTheme "admin" "dashboard" next ctx
}
// -- CATEGORIES --
// GET /admin/categories
let listCategories : HttpHandler = fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let hash = Hash.FromAnonymousObject {|
web_log = ctx.WebLog
categories = CategoryCache.get ctx
page_title = "Categories"
csrf = csrfToken ctx
|}
hash.Add ("category_list", catListTemplate.Render hash)
return! viewForTheme "admin" "category-list" next ctx hash
}
// GET /admin/categories/bare
let listCategoriesBare : HttpHandler = fun next ctx -> task {
return!
Hash.FromAnonymousObject {|
categories = CategoryCache.get ctx
csrf = csrfToken ctx
|}
|> bareForTheme "admin" "category-list-body" next ctx
}
// GET /admin/category/{id}/edit
let editCategory catId : HttpHandler = fun next ctx -> task {
let! result = task {
match catId with
| "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" })
| _ ->
match! ctx.Data.Category.findById (CategoryId catId) ctx.WebLog.id with
| Some cat -> return Some ("Edit Category", cat)
| None -> return None
}
match result with
| Some (title, cat) ->
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
model = EditCategoryModel.fromCategory cat
page_title = title
categories = CategoryCache.get ctx
|}
|> bareForTheme "admin" "category-edit" next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/save
let saveCategory : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let! category = task {
match model.categoryId with
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id }
| catId -> return! data.Category.findById (CategoryId catId) webLog.id
}
match category with
| Some cat ->
let cat =
{ cat with
name = model.name
slug = model.slug
description = if model.description = "" then None else Some model.description
parentId = if model.parentId = "" then None else Some (CategoryId model.parentId)
}
do! (match model.categoryId with "new" -> data.Category.add | _ -> data.Category.update) cat
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category saved successfully" }
return! listCategoriesBare next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = fun next ctx -> task {
match! ctx.Data.Category.delete (CategoryId catId) ctx.WebLog.id with
| true ->
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Category not found; cannot delete" }
return! listCategoriesBare next ctx
}
// -- PAGES --
// GET /admin/pages
// GET /admin/pages/page/{pageNbr}
let listPages pageNbr : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let! pages = ctx.Data.Page.findPageOfPages webLog.id pageNbr
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
pages = pages |> List.map (DisplayPage.fromPageMinimal webLog)
page_title = "Pages"
page_nbr = pageNbr
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
next_page = $"/page/{pageNbr + 1}"
|}
|> viewForTheme "admin" "page-list" next ctx
}
// GET /admin/page/{id}/edit
let editPage pgId : HttpHandler = fun next ctx -> task {
let! result = task {
match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" })
| _ ->
match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
| Some page -> return Some ("Edit Page", page)
| None -> return None
}
match result with
| Some (title, page) ->
let model = EditPageModel.fromPage page
let! templates = templatesForTheme ctx "page"
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
model = model
metadata = Array.zip model.metaNames model.metaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
page_title = title
templates = templates
|}
|> viewForTheme "admin" "page-edit" next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/page/{id}/permalinks
let editPagePermalinks pgId : HttpHandler = fun next ctx -> task {
match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
| Some pg ->
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
model = ManagePermalinksModel.fromPage pg
page_title = $"Manage Prior Permalinks"
|}
|> viewForTheme "admin" "permalinks" next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/permalinks
let savePagePermalinks : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links with
| true ->
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx
| false -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/delete
let deletePage pgId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
match! ctx.Data.Page.delete (PageId pgId) webLog.id with
| true ->
do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Page not found; nothing deleted" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/pages")) next ctx
}
open System
#nowarn "3511"
// POST /admin/page/save
let savePage : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let webLog = ctx.WebLog
let data = ctx.Data
let now = DateTime.UtcNow
let! pg = task {
match model.pageId with
| "new" ->
return Some
{ Page.empty with
id = PageId.create ()
webLogId = webLog.id
authorId = userId ctx
publishedOn = now
}
| pgId -> return! data.Page.findFullById (PageId pgId) webLog.id
}
match pg with
| Some page ->
let updateList = page.showInPageList <> model.isShownInPageList
let revision = { asOf = now; text = MarkupText.parse $"{model.source}: {model.text}" }
// Detect a permalink change, and add the prior one to the prior list
let page =
match Permalink.toString page.permalink with
| "" -> page
| link when link = model.permalink -> page
| _ -> { page with priorPermalinks = page.permalink :: page.priorPermalinks }
let page =
{ page with
title = model.title
permalink = Permalink model.permalink
updatedOn = now
showInPageList = model.isShownInPageList
template = match model.template with "" -> None | tmpl -> Some tmpl
text = MarkupText.toHtml revision.text
metadata = Seq.zip model.metaNames model.metaValues
|> Seq.filter (fun it -> fst it > "")
|> Seq.map (fun it -> { name = fst it; value = snd it })
|> Seq.sortBy (fun it -> $"{it.name.ToLower ()} {it.value.ToLower ()}")
|> List.ofSeq
revisions = match page.revisions |> List.tryHead with
| Some r when r.text = revision.text -> page.revisions
| _ -> revision :: page.revisions
}
do! (if model.pageId = "new" then data.Page.add else data.Page.update) page
if updateList then do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Page saved successfully" }
return!
redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{PageId.toString page.id}/edit")) next ctx
| None -> return! Error.notFound next ctx
}
// -- TAG MAPPINGS --
open Microsoft.AspNetCore.Http
/// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = ctx.Data.TagMap.findByWebLog ctx.WebLog.id
return Hash.FromAnonymousObject {|
web_log = ctx.WebLog
csrf = csrfToken ctx
mappings = mappings
mapping_ids = mappings |> List.map (fun it -> { name = it.tag; value = TagMapId.toString it.id })
|}
}
// GET /admin/settings/tag-mappings
let tagMappings : HttpHandler = fun next ctx -> task {
let! hash = tagMappingHash ctx
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
hash.Add ("tag_mapping_list", listTemplate.Render hash)
hash.Add ("page_title", "Tag Mappings")
return! viewForTheme "admin" "tag-mapping-list" next ctx hash
}
// GET /admin/settings/tag-mappings/bare
let tagMappingsBare : HttpHandler = fun next ctx -> task {
let! hash = tagMappingHash ctx
return! bareForTheme "admin" "tag-mapping-list-body" next ctx hash
}
// GET /admin/settings/tag-mapping/{id}/edit
let editMapping tagMapId : HttpHandler = fun next ctx -> task {
let isNew = tagMapId = "new"
let tagMap =
if isNew then
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
else
ctx.Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id
match! tagMap with
| Some tm ->
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
model = EditTagMapModel.fromMapping tm
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag"
|}
|> bareForTheme "admin" "tag-mapping-edit" next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/save
let saveMapping : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
if model.id = "new" then
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = ctx.WebLog.id })
else
data.TagMap.findById (TagMapId model.id) ctx.WebLog.id
match! tagMap with
| Some tm ->
do! data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () }
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
return! tagMappingsBare next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
match! ctx.Data.TagMap.delete (TagMapId tagMapId) ctx.WebLog.id with
| true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Tag mapping not found; nothing deleted" }
return! tagMappingsBare next ctx
}
// -- THEMES --
open System.IO
open System.IO.Compression
open System.Text.RegularExpressions
open MyWebLog.Data
// GET /admin/theme/update
let themeUpdatePage : HttpHandler = fun next ctx -> task {
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
page_title = "Upload Theme"
|}
|> viewForTheme "admin" "upload-theme" next ctx
}
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm"
match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with
| Some versionItem ->
use versionFile = new StreamReader(versionItem.Open ())
let! versionText = versionFile.ReadToEndAsync ()
let parts = versionText.Trim().Replace("\r", "").Split "\n"
let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.id
let version = if parts.Length > 1 && parts[1] > "" then parts[1] else now ()
return { theme with name = displayName; version = version }
| None ->
return { theme with name = ThemeId.toString theme.id; version = now () }
}
/// Delete all theme assets, and remove templates from theme
let private checkForCleanLoad (theme : Theme) cleanLoad (data : IData) = backgroundTask {
if cleanLoad then
do! data.ThemeAsset.deleteByTheme theme.id
return { theme with templates = [] }
else
return theme
}
/// Update the theme with all templates from the ZIP archive
let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask {
let tasks =
zip.Entries
|> Seq.filter (fun it -> it.Name.EndsWith ".liquid")
|> Seq.map (fun templateItem -> backgroundTask {
use templateFile = new StreamReader (templateItem.Open ())
let! template = templateFile.ReadToEndAsync ()
return { name = templateItem.Name.Replace (".liquid", ""); text = template }
})
let! templates = Task.WhenAll tasks
return
templates
|> Array.fold (fun t template ->
{ t with templates = template :: (t.templates |> List.filter (fun it -> it.name <> template.name)) })
theme
}
/// Update theme assets from the ZIP archive
let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
let assetName = asset.FullName.Replace ("wwwroot/", "")
if assetName <> "" && not (assetName.EndsWith "/") then
use stream = new MemoryStream ()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.save
{ id = ThemeAssetId (themeId, assetName)
updatedOn = asset.LastWriteTime.DateTime
data = stream.ToArray ()
}
}
/// Get the theme name from the file name given
let getThemeName (fileName : string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Ok themeName else Error $"Theme name {fileName} is invalid"
/// Load a theme from the given stream, which should contain a ZIP archive
let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
use zip = new ZipArchive (file, ZipArchiveMode.Read)
let themeId = ThemeId themeName
let! theme = backgroundTask {
match! data.Theme.findById themeId with
| Some t -> return t
| None -> return { Theme.empty with id = themeId }
}
let! theme = updateNameAndVersion theme zip
let! theme = checkForCleanLoad theme clean data
let! theme = updateTemplates theme zip
do! data.Theme.save theme
do! updateAssets themeId zip data
}
// POST /admin/theme/update
let updateTheme : HttpHandler = fun next ctx -> task {
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let themeFile = Seq.head ctx.Request.Form.Files
match getThemeName themeFile.FileName with
| Ok themeName when themeName <> "admin" ->
let data = ctx.Data
use stream = new MemoryStream ()
do! themeFile.CopyToAsync stream
do! loadThemeFromZip themeName stream true data
do! ThemeAssetCache.refreshTheme (ThemeId themeName) data
do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx
| Ok _ ->
do! addMessage ctx { UserMessage.error with message = "You may not replace the admin theme" }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
| Error message ->
do! addMessage ctx { UserMessage.error with message = message }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
else
return! RequestErrors.BAD_REQUEST "Bad request" next ctx
}
// -- WEB LOG SETTINGS --
open System.Collections.Generic
// GET /admin/settings
let settings : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let data = ctx.Data
let! allPages = data.Page.all webLog.id
let! themes = data.Theme.all ()
return!
Hash.FromAnonymousObject {|
csrf = csrfToken ctx
model = SettingsModel.fromWebLog webLog
pages =
seq {
KeyValuePair.Create ("posts", "- First Page of Posts -")
yield! allPages
|> List.sortBy (fun p -> p.title.ToLower ())
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title))
}
|> Array.ofSeq
themes = themes
|> Seq.ofList
|> Seq.map (fun it ->
KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})"))
|> Array.ofSeq
web_log = webLog
page_title = "Web Log Settings"
|}
|> viewForTheme "admin" "settings" next ctx
}
// POST /admin/settings
let saveSettings : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel> ()
match! data.WebLog.findById webLog.id with
| Some webLog ->
let webLog = model.update webLog
do! data.WebLog.updateSettings webLog
// Update cache
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with message = "Web log settings saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/settings")) next ctx
| None -> return! Error.notFound next ctx
}

22
src/MyWebLog/Handlers/Error.fs Normal file
View File

@@ -0,0 +1,22 @@
/// Handlers for error conditions
module MyWebLog.Handlers.Error
open System.Net
open System.Threading.Tasks
open Giraffe
open Microsoft.AspNetCore.Http
open MyWebLog
/// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
let notAuthorized : HttpHandler = fun next ctx -> task {
if ctx.Request.Method = "GET" then
let returnUrl = WebUtility.UrlEncode ctx.Request.Path
return!
redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink $"user/log-on?returnUrl={returnUrl}")) next ctx
else
return! (setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None) next ctx
}
/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there
let notFound : HttpHandler =
setStatusCode 404 >=> text "Not found"

459
src/MyWebLog/Handlers/Feed.fs Normal file
View File

@@ -0,0 +1,459 @@
/// Functions to support generating RSS feeds
module MyWebLog.Handlers.Feed
open System
open System.IO
open System.Net
open System.ServiceModel.Syndication
open System.Text.RegularExpressions
open System.Xml
open Giraffe
open Microsoft.AspNetCore.Http
open MyWebLog
open MyWebLog.ViewModels
// ~~ FEED GENERATION ~~
/// The type of feed to generate
type FeedType =
| StandardFeed of string
| CategoryFeed of CategoryId * string
| TagFeed of string * string
| Custom of CustomFeed * string
/// Derive the type of RSS feed requested
let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
let webLog = ctx.WebLog
let debug = debug "Feed" ctx
let name = $"/{webLog.rss.feedName}"
let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage
debug (fun () -> $"Considering potential feed for {feedPath} (configured feed name {name})")
// Standard feed
match webLog.rss.feedEnabled && feedPath = name with
| true ->
debug (fun () -> "Found standard feed")
Some (StandardFeed feedPath, postCount)
| false ->
// Category and tag feeds are handled by defined routes; check for custom feed
match webLog.rss.customFeeds
|> List.tryFind (fun it -> feedPath.EndsWith (Permalink.toString it.path)) with
| Some feed ->
debug (fun () -> "Found custom feed")
Some (Custom (feed, feedPath),
feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount)
| None ->
debug (fun () -> $"No matching feed found")
None
/// Determine the function to retrieve posts for the given feed
let private getFeedPosts ctx feedType =
let childIds catId =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId)
getCategoryIds cat.slug ctx
let data = ctx.Data
match feedType with
| StandardFeed _ -> data.Post.findPageOfPublishedPosts ctx.WebLog.id 1
| CategoryFeed (catId, _) -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| TagFeed (tag, _) -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1
| Custom (feed, _) ->
match feed.source with
| Category catId -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| Tag tag -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1
/// Strip HTML from a string
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "")
/// XML namespaces for building RSS feeds
[<RequireQualifiedAccess>]
module private Namespace =
/// Enables encoded (HTML) content
let content = "http://purl.org/rss/1.0/modules/content/"
/// The dc XML namespace
let dc = "http://purl.org/dc/elements/1.1/"
/// iTunes elements
let iTunes = "http://www.itunes.com/dtds/podcast-1.0.dtd"
/// Enables chapters
let psc = "http://podlove.org/simple-chapters/"
/// Enables another "subscribe" option
let rawVoice = "http://www.rawvoice.com/rawvoiceRssModule/"
/// Create a feed item from the given post
let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list)
(post : Post) =
let plainText =
let endingP = post.text.IndexOf "</p>"
stripHtml <| if endingP >= 0 then post.text[..(endingP - 1)] else post.text
let item = SyndicationItem (
Id = WebLog.absoluteUrl webLog post.permalink,
Title = TextSyndicationContent.CreateHtmlContent post.title,
PublishDate = DateTimeOffset post.publishedOn.Value,
LastUpdatedTime = DateTimeOffset post.updatedOn,
Content = TextSyndicationContent.CreatePlaintextContent plainText)
item.AddPermalink (Uri item.Id)
let xmlDoc = XmlDocument ()
let encoded =
let txt =
post.text
.Replace("src=\"/", $"src=\"{webLog.urlBase}/")
.Replace ("href=\"/", $"href=\"{webLog.urlBase}/")
let it = xmlDoc.CreateElement ("content", "encoded", Namespace.content)
let _ = it.AppendChild (xmlDoc.CreateCDataSection txt)
it
item.ElementExtensions.Add encoded
item.Authors.Add (SyndicationPerson (
Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value))
[ post.categoryIds
|> List.map (fun catId ->
let cat = cats |> Array.find (fun c -> c.id = CategoryId.toString catId)
SyndicationCategory (cat.name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.slug}/"), cat.name))
post.tags
|> List.map (fun tag ->
let urlTag =
match tagMaps |> List.tryFind (fun tm -> tm.tag = tag) with
| Some tm -> tm.urlValue
| None -> tag.Replace (" ", "+")
SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
]
|> List.concat
|> List.iter item.Categories.Add
item
/// Add episode information to a podcast feed item
let private addEpisode webLog (feed : CustomFeed) (post : Post) (item : SyndicationItem) =
let podcast = Option.get feed.podcast
let meta name = post.metadata |> List.tryFind (fun it -> it.name = name)
let value (item : MetaItem) = item.value
let epMediaUrl =
match (meta >> Option.get >> value) "episode_media_file" with
| link when link.StartsWith "http" -> link
| link when Option.isSome podcast.mediaBaseUrl -> $"{podcast.mediaBaseUrl.Value}{link}"
| link -> WebLog.absoluteUrl webLog (Permalink link)
let epMediaType =
match meta "episode_media_type", podcast.defaultMediaType with
| Some epType, _ -> Some epType.value
| None, Some defType -> Some defType
| _ -> None
let epImageUrl =
match defaultArg ((meta >> Option.map value) "episode_image") (Permalink.toString podcast.imageUrl) with
| link when link.StartsWith "http" -> link
| link -> WebLog.absoluteUrl webLog (Permalink link)
let epExplicit =
try
(meta >> Option.map (value >> ExplicitRating.parse)) "episode_explicit"
|> Option.defaultValue podcast.explicit
|> ExplicitRating.toString
with :? ArgumentException -> ExplicitRating.toString podcast.explicit
let xmlDoc = XmlDocument ()
let enclosure =
let it = xmlDoc.CreateElement "enclosure"
it.SetAttribute ("url", epMediaUrl)
meta "episode_media_length" |> Option.iter (fun len -> it.SetAttribute ("length", len.value))
epMediaType |> Option.iter (fun typ -> it.SetAttribute ("type", typ))
it
let image =
let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes)
it.SetAttribute ("href", epImageUrl)
it
item.ElementExtensions.Add enclosure
item.ElementExtensions.Add image
item.ElementExtensions.Add ("creator", Namespace.dc, podcast.displayedAuthor)
item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.displayedAuthor)
item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit)
meta "episode_subtitle"
|> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it.value))
meta "episode_duration"
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it.value))
if post.metadata |> List.exists (fun it -> it.name = "chapter") then
try
let chapters = xmlDoc.CreateElement ("psc", "chapters", Namespace.psc)
chapters.SetAttribute ("version", "1.2")
post.metadata
|> List.filter (fun it -> it.name = "chapter")
|> List.map (fun it ->
TimeSpan.Parse (it.value.Split(" ")[0]), it.value.Substring (it.value.IndexOf(" ") + 1))
|> List.sortBy fst
|> List.iter (fun chap ->
let chapter = xmlDoc.CreateElement ("psc", "chapter", Namespace.psc)
chapter.SetAttribute ("start", (fst chap).ToString "hh:mm:ss")
chapter.SetAttribute ("title", snd chap)
chapters.AppendChild chapter |> ignore)
item.ElementExtensions.Add chapters
with _ -> ()
item
/// Add a namespace to the feed
let private addNamespace (feed : SyndicationFeed) alias nsUrl =
feed.AttributeExtensions.Add (XmlQualifiedName (alias, "http://www.w3.org/2000/xmlns/"), nsUrl)
/// Add items to the top of the feed required for podcasts
let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
let addChild (doc : XmlDocument) ns prefix name value (elt : XmlElement) =
let child =
if ns = "" then doc.CreateElement name else doc.CreateElement (prefix, name, ns)
|> elt.AppendChild
child.InnerText <- value
elt
let podcast = Option.get feed.podcast
let feedUrl = WebLog.absoluteUrl webLog feed.path
let imageUrl =
match podcast.imageUrl with
| Permalink link when link.StartsWith "http" -> link
| Permalink _ -> WebLog.absoluteUrl webLog podcast.imageUrl
let xmlDoc = XmlDocument ()
[ "dc", Namespace.dc; "itunes", Namespace.iTunes; "psc", Namespace.psc; "rawvoice", Namespace.rawVoice ]
|> List.iter (fun (alias, nsUrl) -> addNamespace rssFeed alias nsUrl)
let categorization =
let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
it.SetAttribute ("text", podcast.iTunesCategory)
podcast.iTunesSubcategory
|> Option.iter (fun subCat ->
let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
subCatElt.SetAttribute ("text", subCat)
it.AppendChild subCatElt |> ignore)
it
let image =
[ "title", podcast.title
"url", imageUrl
"link", feedUrl
]
|> List.fold (fun elt (name, value) -> addChild xmlDoc "" "" name value elt) (xmlDoc.CreateElement "image")
let iTunesImage =
let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes)
it.SetAttribute ("href", imageUrl)
it
let owner =
[ "name", podcast.displayedAuthor
"email", podcast.email
]
|> List.fold (fun elt (name, value) -> addChild xmlDoc Namespace.iTunes "itunes" name value elt)
(xmlDoc.CreateElement ("itunes", "owner", Namespace.iTunes))
let rawVoice =
let it = xmlDoc.CreateElement ("rawvoice", "subscribe", Namespace.rawVoice)
it.SetAttribute ("feed", feedUrl)
it.SetAttribute ("itunes", "")
it
rssFeed.ElementExtensions.Add image
rssFeed.ElementExtensions.Add owner
rssFeed.ElementExtensions.Add categorization
rssFeed.ElementExtensions.Add iTunesImage
rssFeed.ElementExtensions.Add rawVoice
rssFeed.ElementExtensions.Add ("summary", Namespace.iTunes, podcast.summary)
rssFeed.ElementExtensions.Add ("author", Namespace.iTunes, podcast.displayedAuthor)
rssFeed.ElementExtensions.Add ("explicit", Namespace.iTunes, ExplicitRating.toString podcast.explicit)
podcast.subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", Namespace.iTunes, sub))
/// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType ctx =
let withoutFeed (it : string) = Permalink (it.Replace ($"/{webLog.rss.feedName}", ""))
match feedType with
| StandardFeed path
| CategoryFeed (_, path)
| TagFeed (_, path) -> Permalink path[1..], withoutFeed path
| Custom (feed, _) ->
match feed.source with
| Category (CategoryId catId) ->
feed.path, Permalink $"category/{(CategoryCache.get ctx |> Array.find (fun c -> c.id = catId)).slug}"
| Tag tag -> feed.path, Permalink $"""tag/{tag.Replace(" ", "+")}/"""
/// Set the title and description of the feed based on its source
let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCategory[]) (feed : SyndicationFeed) =
let cleanText opt def = TextSyndicationContent (stripHtml (defaultArg opt def))
match feedType with
| StandardFeed _ ->
feed.Title <- cleanText None webLog.name
feed.Description <- cleanText webLog.subtitle webLog.name
| CategoryFeed (CategoryId catId, _) ->
let cat = cats |> Array.find (fun it -> it.id = catId)
feed.Title <- cleanText None $"""{webLog.name} - "{stripHtml cat.name}" Category"""
feed.Description <- cleanText cat.description $"""Posts categorized under "{cat.name}" """
| TagFeed (tag, _) ->
feed.Title <- cleanText None $"""{webLog.name} - "{tag}" Tag"""
feed.Description <- cleanText None $"""Posts with the "{tag}" tag"""
| Custom (custom, _) ->
match custom.podcast with
| Some podcast ->
feed.Title <- cleanText None podcast.title
feed.Description <- cleanText podcast.subtitle podcast.title
| None ->
match custom.source with
| Category (CategoryId catId) ->
let cat = cats |> Array.find (fun it -> it.id = catId)
feed.Title <- cleanText None $"""{webLog.name} - "{stripHtml cat.name}" Category"""
feed.Description <- cleanText cat.description $"""Posts categorized under "{cat.name}" """
| Tag tag ->
feed.Title <- cleanText None $"""{webLog.name} - "{tag}" Tag"""
feed.Description <- cleanText None $"""Posts with the "{tag}" tag"""
/// Create a feed with a known non-zero-length list of posts
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
let webLog = ctx.WebLog
let data = ctx.Data
let! authors = getAuthors webLog posts data
let! tagMaps = getTagMappings webLog posts data
let cats = CategoryCache.get ctx
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None
let self, link = selfAndLink webLog feedType ctx
let toItem post =
let item = toFeedItem webLog authors cats tagMaps post
match podcast with
| Some feed when post.metadata |> List.exists (fun it -> it.name = "episode_media_file") ->
addEpisode webLog feed post item
| Some _ ->
warn "Feed" ctx $"[{webLog.name} {Permalink.toString self}] \"{stripHtml post.title}\" has no media"
item
| _ -> item
let feed = SyndicationFeed ()
addNamespace feed "content" Namespace.content
setTitleAndDescription feedType webLog cats feed
feed.LastUpdatedTime <- (List.head posts).updatedOn |> DateTimeOffset
feed.Generator <- generator ctx
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"
feed.Id <- WebLog.absoluteUrl webLog link
webLog.rss.copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy)
feed.Links.Add (SyndicationLink (Uri (WebLog.absoluteUrl webLog self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link)
podcast |> Option.iter (addPodcast webLog feed)
use mem = new MemoryStream</