v2 RC2 #33

Merged
danieljsummers merged 13 commits from add-pgsql into main 2022-08-21 22:56:18 +00:00
45 changed files with 3820 additions and 1306 deletions

View File

@ -5,6 +5,6 @@
<AssemblyVersion>2.0.0.0</AssemblyVersion>
<FileVersion>2.0.0.0</FileVersion>
<Version>2.0.0</Version>
<VersionSuffix>rc1</VersionSuffix>
<VersionSuffix>rc2</VersionSuffix>
</PropertyGroup>
</Project>

View File

@ -122,12 +122,13 @@ module Json =
(string >> WebLogUserId) reader.Value
open Microsoft.FSharpLu.Json
open NodaTime
open NodaTime.Serialization.JsonNet
/// All converters to use for data conversion
let all () : JsonConverter seq =
seq {
/// Configure a serializer to use these converters
let configure (ser : JsonSerializer) =
// Our converters
CategoryIdConverter ()
[ CategoryIdConverter () :> JsonConverter
CommentIdConverter ()
CustomFeedIdConverter ()
CustomFeedSourceConverter ()
@ -143,6 +144,35 @@ module Json =
UploadIdConverter ()
WebLogIdConverter ()
WebLogUserIdConverter ()
] |> List.iter ser.Converters.Add
// NodaTime
let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb
// Handles DUs with no associated data, as well as option fields
CompactUnionJsonConverter ()
}
ser.Converters.Add (CompactUnionJsonConverter ())
ser.NullValueHandling <- NullValueHandling.Ignore
ser.MissingMemberHandling <- MissingMemberHandling.Ignore
ser
/// Serializer settings extracted from a JsonSerializer (a property sure would be nice...)
let mutable private serializerSettings : JsonSerializerSettings option = None
/// Extract settings from the serializer to be used in JsonConvert calls
let settings (ser : JsonSerializer) =
if Option.isNone serializerSettings then
serializerSettings <- JsonSerializerSettings (
ConstructorHandling = ser.ConstructorHandling,
ContractResolver = ser.ContractResolver,
Converters = ser.Converters,
DefaultValueHandling = ser.DefaultValueHandling,
DateFormatHandling = ser.DateFormatHandling,
MetadataPropertyHandling = ser.MetadataPropertyHandling,
MissingMemberHandling = ser.MissingMemberHandling,
NullValueHandling = ser.NullValueHandling,
ObjectCreationHandling = ser.ObjectCreationHandling,
ReferenceLoopHandling = ser.ReferenceLoopHandling,
SerializationBinder = ser.SerializationBinder,
TraceWriter = ser.TraceWriter,
TypeNameAssemblyFormatHandling = ser.TypeNameAssemblyFormatHandling,
TypeNameHandling = ser.TypeNameHandling)
|> Some
serializerSettings.Value

View File

@ -1,9 +1,10 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open MyWebLog
open MyWebLog.ViewModels
open Newtonsoft.Json
open NodaTime
/// The result of a category deletion attempt
type CategoryDeleteResult =
@ -137,7 +138,7 @@ type IPostData =
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>
abstract member FindSurroundingPosts : WebLogId -> publishedOn : Instant -> Task<Post option * Post option>
/// Restore posts from a backup
abstract member Restore : Post list -> Task<unit>
@ -326,6 +327,9 @@ type IData =
/// Web log user data functions
abstract member WebLogUser : IWebLogUserData
/// A JSON serializer for use in persistence
abstract member Serializer : JsonSerializer
/// Do any required start up data checks
abstract member StartUp : unit -> Task<unit>

View File

@ -5,10 +5,16 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.7" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.8" />
<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="6.0.0" />
<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="NodaTime" Version="3.1.2" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.0.0" />
<PackageReference Include="Npgsql" Version="6.0.6" />
<PackageReference Include="Npgsql.FSharp" Version="5.3.0" />
<PackageReference Include="Npgsql.NodaTime" Version="6.0.6" />
<PackageReference Include="RethinkDb.Driver" Version="2.3.150" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
@ -29,6 +35,17 @@
<Compile Include="SQLite\SQLiteWebLogData.fs" />
<Compile Include="SQLite\SQLiteWebLogUserData.fs" />
<Compile Include="SQLiteData.fs" />
<Compile Include="Postgres\PostgresHelpers.fs" />
<Compile Include="Postgres\PostgresCache.fs" />
<Compile Include="Postgres\PostgresCategoryData.fs" />
<Compile Include="Postgres\PostgresPageData.fs" />
<Compile Include="Postgres\PostgresPostData.fs" />
<Compile Include="Postgres\PostgresTagMapData.fs" />
<Compile Include="Postgres\PostgresThemeData.fs" />
<Compile Include="Postgres\PostgresUploadData.fs" />
<Compile Include="Postgres\PostgresWebLogData.fs" />
<Compile Include="Postgres\PostgresWebLogUserData.fs" />
<Compile Include="PostgresData.fs" />
</ItemGroup>
</Project>

View File

@ -0,0 +1,210 @@
namespace MyWebLog.Data.Postgres
open System.Threading
open System.Threading.Tasks
open Microsoft.Extensions.Caching.Distributed
open NodaTime
open Npgsql.FSharp
/// Helper types and functions for the cache
[<AutoOpen>]
module private Helpers =
/// The cache entry
type Entry =
{ /// The ID of the cache entry
Id : string
/// The value to be cached
Payload : byte[]
/// When this entry will expire
ExpireAt : Instant
/// The duration by which the expiration should be pushed out when being refreshed
SlidingExpiration : Duration option
/// The must-expire-by date/time for the cache entry
AbsoluteExpiration : Instant option
}
/// Run a task synchronously
let sync<'T> (it : Task<'T>) = it |> (Async.AwaitTask >> Async.RunSynchronously)
/// Get the current instant
let getNow () = SystemClock.Instance.GetCurrentInstant ()
/// Create a parameter for the expire-at time
let expireParam =
typedParam "expireAt"
/// A distributed cache implementation in PostgreSQL used to handle sessions for myWebLog
type DistributedCache (connStr : string) =
// ~~~ INITIALIZATION ~~~
do
task {
let! exists =
Sql.connect connStr
|> Sql.query $"
SELECT EXISTS
(SELECT 1 FROM pg_tables WHERE schemaname = 'public' AND tablename = 'session')
AS {existsName}"
|> Sql.executeRowAsync Map.toExists
if not exists then
let! _ =
Sql.connect connStr
|> Sql.query
"CREATE TABLE session (
id TEXT NOT NULL PRIMARY KEY,
payload BYTEA NOT NULL,
expire_at TIMESTAMPTZ NOT NULL,
sliding_expiration INTERVAL,
absolute_expiration TIMESTAMPTZ);
CREATE INDEX idx_session_expiration ON session (expire_at)"
|> Sql.executeNonQueryAsync
()
} |> sync
// ~~~ SUPPORT FUNCTIONS ~~~
/// Get an entry, updating it for sliding expiration
let getEntry key = backgroundTask {
let idParam = "@id", Sql.string key
let! tryEntry =
Sql.connect connStr
|> Sql.query "SELECT * FROM session WHERE id = @id"
|> Sql.parameters [ idParam ]
|> Sql.executeAsync (fun row ->
{ Id = row.string "id"
Payload = row.bytea "payload"
ExpireAt = row.fieldValue<Instant> "expire_at"
SlidingExpiration = row.fieldValueOrNone<Duration> "sliding_expiration"
AbsoluteExpiration = row.fieldValueOrNone<Instant> "absolute_expiration" })
|> tryHead
match tryEntry with
| Some entry ->
let now = getNow ()
let slideExp = defaultArg entry.SlidingExpiration Duration.MinValue
let absExp = defaultArg entry.AbsoluteExpiration Instant.MinValue
let needsRefresh, item =
if entry.ExpireAt = absExp then false, entry
elif slideExp = Duration.MinValue && absExp = Instant.MinValue then false, entry
elif absExp > Instant.MinValue && entry.ExpireAt.Plus slideExp > absExp then
true, { entry with ExpireAt = absExp }
else true, { entry with ExpireAt = now.Plus slideExp }
if needsRefresh then
let! _ =
Sql.connect connStr
|> Sql.query "UPDATE session SET expire_at = @expireAt WHERE id = @id"
|> Sql.parameters [ expireParam item.ExpireAt; idParam ]
|> Sql.executeNonQueryAsync
()
return if item.ExpireAt > now then Some entry else None
| None -> return None
}
/// The last time expired entries were purged (runs every 30 minutes)
let mutable lastPurge = Instant.MinValue
/// Purge expired entries every 30 minutes
let purge () = backgroundTask {
let now = getNow ()
if lastPurge.Plus (Duration.FromMinutes 30L) < now then
let! _ =
Sql.connect connStr
|> Sql.query "DELETE FROM session WHERE expire_at < @expireAt"
|> Sql.parameters [ expireParam now ]
|> Sql.executeNonQueryAsync
lastPurge <- now
}
/// Remove a cache entry
let removeEntry key = backgroundTask {
let! _ =
Sql.connect connStr
|> Sql.query "DELETE FROM session WHERE id = @id"
|> Sql.parameters [ "@id", Sql.string key ]
|> Sql.executeNonQueryAsync
()
}
/// Save an entry
let saveEntry (opts : DistributedCacheEntryOptions) key payload = backgroundTask {
let now = getNow ()
let expireAt, slideExp, absExp =
if opts.SlidingExpiration.HasValue then
let slide = Duration.FromTimeSpan opts.SlidingExpiration.Value
now.Plus slide, Some slide, None
elif opts.AbsoluteExpiration.HasValue then
let exp = Instant.FromDateTimeOffset opts.AbsoluteExpiration.Value
exp, None, Some exp
elif opts.AbsoluteExpirationRelativeToNow.HasValue then
let exp = now.Plus (Duration.FromTimeSpan opts.AbsoluteExpirationRelativeToNow.Value)
exp, None, Some exp
else
// Default to 1 hour sliding expiration
let slide = Duration.FromHours 1
now.Plus slide, Some slide, None
let! _ =
Sql.connect connStr
|> Sql.query
"INSERT INTO session (
id, payload, expire_at, sliding_expiration, absolute_expiration
) VALUES (
@id, @payload, @expireAt, @slideExp, @absExp
) ON CONFLICT (id) DO UPDATE
SET payload = EXCLUDED.payload,
expire_at = EXCLUDED.expire_at,
sliding_expiration = EXCLUDED.sliding_expiration,
absolute_expiration = EXCLUDED.absolute_expiration"
|> Sql.parameters
[ "@id", Sql.string key
"@payload", Sql.bytea payload
expireParam expireAt
optParam "slideExp" slideExp
optParam "absExp" absExp ]
|> Sql.executeNonQueryAsync
()
}
// ~~~ IMPLEMENTATION FUNCTIONS ~~~
/// Retrieve the data for a cache entry
let get key (_ : CancellationToken) = backgroundTask {
match! getEntry key with
| Some entry ->
do! purge ()
return entry.Payload
| None -> return null
}
/// Refresh an entry
let refresh key (cancelToken : CancellationToken) = backgroundTask {
let! _ = get key cancelToken
()
}
/// Remove an entry
let remove key (_ : CancellationToken) = backgroundTask {
do! removeEntry key
do! purge ()
}
/// Set an entry
let set key value options (_ : CancellationToken) = backgroundTask {
do! saveEntry options key value
do! purge ()
}
interface IDistributedCache with
member this.Get key = get key CancellationToken.None |> sync
member this.GetAsync (key, token) = get key token
member this.Refresh key = refresh key CancellationToken.None |> sync
member this.RefreshAsync (key, token) = refresh key token
member this.Remove key = remove key CancellationToken.None |> sync
member this.RemoveAsync (key, token) = remove key token
member this.Set (key, value, options) = set key value options CancellationToken.None |> sync
member this.SetAsync (key, value, options, token) = set key value options token

View File

@ -0,0 +1,172 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog category data implementation
type PostgresCategoryData (conn : NpgsqlConnection) =
/// Count all categories for the given web log
let countAll webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT COUNT(id) AS {countName} FROM category WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toCount
/// Count all top-level categories for the given web log
let countTopLevel webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT COUNT(id) AS {countName} FROM category WHERE web_log_id = @webLogId AND parent_id IS NULL"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toCount
/// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask {
let! cats =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM category WHERE web_log_id = @webLogId ORDER BY LOWER(name)"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync Map.toCategory
let ordered = Utils.orderByHierarchy cats None None []
let counts =
ordered
|> Seq.map (fun it ->
// Parent category post counts include posts in subcategories
let catIdSql, catIdParams =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map (fun cat -> cat.Id)
|> Seq.append (Seq.singleton it.Id)
|> List.ofSeq
|> inClause "AND pc.category_id" "id" id
let postCount =
Sql.existingConnection conn
|> Sql.query $"
SELECT COUNT(DISTINCT p.id) AS {countName}
FROM post p
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = 'Published'
{catIdSql}"
|> Sql.parameters (webLogIdParam webLogId :: catIdParams)
|> Sql.executeRowAsync Map.toCount
|> Async.AwaitTask
|> Async.RunSynchronously
it.Id, postCount)
|> List.ofSeq
return
ordered
|> Seq.map (fun cat ->
{ cat with
PostCount = counts
|> List.tryFind (fun c -> fst c = cat.Id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Array.ofSeq
}
/// Find a category by its ID for the given web log
let findById catId webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM category WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters [ "@id", Sql.string (CategoryId.toString catId); webLogIdParam webLogId ]
|> Sql.executeAsync Map.toCategory
|> tryHead
/// Find all categories for the given web log
let findByWebLog webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM category WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync Map.toCategory
/// Delete a category
let delete catId webLogId = backgroundTask {
match! findById catId webLogId with
| Some cat ->
// Reassign any children to the category's parent category
let parentParam = "@parentId", Sql.string (CategoryId.toString catId)
let! hasChildren =
Sql.existingConnection conn
|> Sql.query $"SELECT EXISTS (SELECT 1 FROM category WHERE parent_id = @parentId) AS {existsName}"
|> Sql.parameters [ parentParam ]
|> Sql.executeRowAsync Map.toExists
if hasChildren then
let! _ =
Sql.existingConnection conn
|> Sql.query "UPDATE category SET parent_id = @newParentId WHERE parent_id = @parentId"
|> Sql.parameters
[ parentParam
"@newParentId", Sql.stringOrNone (cat.ParentId |> Option.map CategoryId.toString) ]
|> Sql.executeNonQueryAsync
()
// Delete the category off all posts where it is assigned, and the category itself
let! _ =
Sql.existingConnection conn
|> Sql.query
"DELETE FROM post_category
WHERE category_id = @id
AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId);
DELETE FROM category WHERE id = @id"
|> Sql.parameters [ "@id", Sql.string (CategoryId.toString catId); webLogIdParam webLogId ]
|> Sql.executeNonQueryAsync
return if hasChildren then ReassignedChildCategories else CategoryDeleted
| None -> return CategoryNotFound
}
/// The INSERT statement for a category
let catInsert =
"INSERT INTO category (
id, web_log_id, name, slug, description, parent_id
) VALUES (
@id, @webLogId, @name, @slug, @description, @parentId
)"
/// Create parameters for a category insert / update
let catParameters (cat : Category) = [
webLogIdParam cat.WebLogId
"@id", Sql.string (CategoryId.toString cat.Id)
"@name", Sql.string cat.Name
"@slug", Sql.string cat.Slug
"@description", Sql.stringOrNone cat.Description
"@parentId", Sql.stringOrNone (cat.ParentId |> Option.map CategoryId.toString)
]
/// Save a category
let save cat = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query $"
{catInsert} ON CONFLICT (id) DO UPDATE
SET name = EXCLUDED.name,
slug = EXCLUDED.slug,
description = EXCLUDED.description,
parent_id = EXCLUDED.parent_id"
|> Sql.parameters (catParameters cat)
|> Sql.executeNonQueryAsync
()
}
/// Restore categories from a backup
let restore cats = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
catInsert, cats |> List.map catParameters
]
()
}
interface ICategoryData with
member _.Add cat = save cat
member _.CountAll webLogId = countAll webLogId
member _.CountTopLevel webLogId = countTopLevel webLogId
member _.FindAllForView webLogId = findAllForView webLogId
member _.FindById catId webLogId = findById catId webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.Delete catId webLogId = delete catId webLogId
member _.Restore cats = restore cats
member _.Update cat = save cat

View File

@ -0,0 +1,240 @@
/// Helper functions for the PostgreSQL data implementation
[<AutoOpen>]
module MyWebLog.Data.Postgres.PostgresHelpers
open System
open System.Threading.Tasks
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open NodaTime
open Npgsql
open Npgsql.FSharp
/// Create a SQL parameter for the web log ID
let webLogIdParam webLogId =
"@webLogId", Sql.string (WebLogId.toString webLogId)
/// The name of the field to select to be able to use Map.toCount
let countName = "the_count"
/// The name of the field to select to be able to use Map.toExists
let existsName = "does_exist"
/// Create the SQL and parameters for an IN clause
let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items : 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", ($"@%s{paramName}{idx}", Sql.string (valueFunc it)) :: itemP)
(Seq.ofList items
|> Seq.map (fun it ->
$"%s{colNameAndPrefix} IN (@%s{paramName}0", [ $"@%s{paramName}0", Sql.string (valueFunc it) ])
|> Seq.head)
|> function sql, ps -> $"{sql})", ps
/// Create the SQL and parameters for the array equivalent of an IN clause
let arrayInClause<'T> name (valueFunc : 'T -> string) (items : 'T list) =
if List.isEmpty items then "TRUE = FALSE", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS} OR %s{name} && ARRAY[@{name}{idx}]",
($"@{name}{idx}", Sql.string (valueFunc it)) :: itemP)
(Seq.ofList items
|> Seq.map (fun it ->
$"{name} && ARRAY[@{name}0]", [ $"@{name}0", Sql.string (valueFunc it) ])
|> Seq.head)
/// Get the first result of the given query
let tryHead<'T> (query : Task<'T list>) = backgroundTask {
let! results = query
return List.tryHead results
}
/// Create a parameter for a non-standard type
let typedParam<'T> name (it : 'T) =
$"@%s{name}", Sql.parameter (NpgsqlParameter ($"@{name}", it))
/// Create a parameter for a possibly-missing non-standard type
let optParam<'T> name (it : 'T option) =
let p = NpgsqlParameter ($"@%s{name}", if Option.isSome it then box it.Value else DBNull.Value)
p.ParameterName, Sql.parameter p
/// Mapping functions for SQL queries
module Map =
/// Map an id field to a category ID
let toCategoryId (row : RowReader) =
CategoryId (row.string "id")
/// Create a category from the current row
let toCategory (row : RowReader) : Category =
{ Id = toCategoryId row
WebLogId = row.string "web_log_id" |> WebLogId
Name = row.string "name"
Slug = row.string "slug"
Description = row.stringOrNone "description"
ParentId = row.stringOrNone "parent_id" |> Option.map CategoryId
}
/// Get a count from a row
let toCount (row : RowReader) =
row.int countName
/// Create a custom feed from the current row
let toCustomFeed (ser : JsonSerializer) (row : RowReader) : CustomFeed =
{ Id = row.string "id" |> CustomFeedId
Source = row.string "source" |> CustomFeedSource.parse
Path = row.string "path" |> Permalink
Podcast = row.stringOrNone "podcast" |> Option.map (Utils.deserialize ser)
}
/// Get a true/false value as to whether an item exists
let toExists (row : RowReader) =
row.bool existsName
/// Create a meta item from the current row
let toMetaItem (row : RowReader) : MetaItem =
{ Name = row.string "name"
Value = row.string "value"
}
/// Create a permalink from the current row
let toPermalink (row : RowReader) =
Permalink (row.string "permalink")
/// Create a page from the current row
let toPage (ser : JsonSerializer) (row : RowReader) : Page =
{ Page.empty with
Id = row.string "id" |> PageId
WebLogId = row.string "web_log_id" |> WebLogId
AuthorId = row.string "author_id" |> WebLogUserId
Title = row.string "title"
Permalink = toPermalink row
PriorPermalinks = row.stringArray "prior_permalinks" |> Array.map Permalink |> List.ofArray
PublishedOn = row.fieldValue<Instant> "published_on"
UpdatedOn = row.fieldValue<Instant> "updated_on"
IsInPageList = row.bool "is_in_page_list"
Template = row.stringOrNone "template"
Text = row.string "page_text"
Metadata = row.stringOrNone "meta_items"
|> Option.map (Utils.deserialize ser)
|> Option.defaultValue []
}
/// Create a post from the current row
let toPost (ser : JsonSerializer) (row : RowReader) : Post =
{ Post.empty with
Id = row.string "id" |> PostId
WebLogId = row.string "web_log_id" |> WebLogId
AuthorId = row.string "author_id" |> WebLogUserId
Status = row.string "status" |> PostStatus.parse
Title = row.string "title"
Permalink = toPermalink row
PriorPermalinks = row.stringArray "prior_permalinks" |> Array.map Permalink |> List.ofArray
PublishedOn = row.fieldValueOrNone<Instant> "published_on"
UpdatedOn = row.fieldValue<Instant> "updated_on"
Template = row.stringOrNone "template"
Text = row.string "post_text"
Episode = row.stringOrNone "episode" |> Option.map (Utils.deserialize ser)
CategoryIds = row.stringArrayOrNone "category_ids"
|> Option.map (Array.map CategoryId >> List.ofArray)
|> Option.defaultValue []
Tags = row.stringArrayOrNone "tags"
|> Option.map List.ofArray
|> Option.defaultValue []
Metadata = row.stringOrNone "meta_items"
|> Option.map (Utils.deserialize ser)
|> Option.defaultValue []
}
/// Create a revision from the current row
let toRevision (row : RowReader) : Revision =
{ AsOf = row.fieldValue<Instant> "as_of"
Text = row.string "revision_text" |> MarkupText.parse
}
/// Create a tag mapping from the current row
let toTagMap (row : RowReader) : TagMap =
{ Id = row.string "id" |> TagMapId
WebLogId = row.string "web_log_id" |> WebLogId
Tag = row.string "tag"
UrlValue = row.string "url_value"
}
/// Create a theme from the current row (excludes templates)
let toTheme (row : RowReader) : Theme =
{ Theme.empty with
Id = row.string "id" |> ThemeId
Name = row.string "name"
Version = row.string "version"
}
/// Create a theme asset from the current row
let toThemeAsset includeData (row : RowReader) : ThemeAsset =
{ Id = ThemeAssetId (ThemeId (row.string "theme_id"), row.string "path")
UpdatedOn = row.fieldValue<Instant> "updated_on"
Data = if includeData then row.bytea "data" else [||]
}
/// Create a theme template from the current row
let toThemeTemplate includeText (row : RowReader) : ThemeTemplate =
{ Name = row.string "name"
Text = if includeText then row.string "template" else ""
}
/// Create an uploaded file from the current row
let toUpload includeData (row : RowReader) : Upload =
{ Id = row.string "id" |> UploadId
WebLogId = row.string "web_log_id" |> WebLogId
Path = row.string "path" |> Permalink
UpdatedOn = row.fieldValue<Instant> "updated_on"
Data = if includeData then row.bytea "data" else [||]
}
/// Create a web log from the current row
let toWebLog (row : RowReader) : WebLog =
{ Id = row.string "id" |> WebLogId
Name = row.string "name"
Slug = row.string "slug"
Subtitle = row.stringOrNone "subtitle"
DefaultPage = row.string "default_page"
PostsPerPage = row.int "posts_per_page"
ThemeId = row.string "theme_id" |> ThemeId
UrlBase = row.string "url_base"
TimeZone = row.string "time_zone"
AutoHtmx = row.bool "auto_htmx"
Uploads = row.string "uploads" |> UploadDestination.parse
Rss = {
IsFeedEnabled = row.bool "is_feed_enabled"
FeedName = row.string "feed_name"
ItemsInFeed = row.intOrNone "items_in_feed"
IsCategoryEnabled = row.bool "is_category_enabled"
IsTagEnabled = row.bool "is_tag_enabled"
Copyright = row.stringOrNone "copyright"
CustomFeeds = []
}
}
/// Create a web log user from the current row
let toWebLogUser (row : RowReader) : WebLogUser =
{ Id = row.string "id" |> WebLogUserId
WebLogId = row.string "web_log_id" |> WebLogId
Email = row.string "email"
FirstName = row.string "first_name"
LastName = row.string "last_name"
PreferredName = row.string "preferred_name"
PasswordHash = row.string "password_hash"
Url = row.stringOrNone "url"
AccessLevel = row.string "access_level" |> AccessLevel.parse
CreatedOn = row.fieldValue<Instant> "created_on"
LastSeenOn = row.fieldValueOrNone<Instant> "last_seen_on"
}

View File

@ -0,0 +1,281 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog page data implementation
type PostgresPageData (conn : NpgsqlConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
/// Append revisions and permalinks to a page
let appendPageRevisions (page : Page) = backgroundTask {
let! revisions =
Sql.existingConnection conn
|> Sql.query "SELECT as_of, revision_text FROM page_revision WHERE page_id = @pageId ORDER BY as_of DESC"
|> Sql.parameters [ "@pageId", Sql.string (PageId.toString page.Id) ]
|> Sql.executeAsync Map.toRevision
return { page with Revisions = revisions }
}
/// Shorthand to map to a page
let toPage = Map.toPage ser
/// Return a page with no text or revisions
let pageWithoutText row =
{ toPage row with Text = "" }
/// The INSERT statement for a page revision
let revInsert = "INSERT INTO page_revision VALUES (@pageId, @asOf, @text)"
/// Parameters for a revision INSERT statement
let revParams pageId rev = [
typedParam "asOf" rev.AsOf
"@pageId", Sql.string (PageId.toString pageId)
"@text", Sql.string (MarkupText.toString rev.Text)
]
/// Update a page's revisions
let updatePageRevisions pageId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
if not (List.isEmpty toDelete) then
"DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @asOf",
toDelete
|> List.map (fun it -> [
"@pageId", Sql.string (PageId.toString pageId)
typedParam "asOf" it.AsOf
])
if not (List.isEmpty toAdd) then
revInsert, toAdd |> List.map (revParams pageId)
]
()
}
/// Does the given page exist?
let pageExists pageId webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT EXISTS (SELECT 1 FROM page WHERE id = @id AND web_log_id = @webLogId) AS {existsName}"
|> Sql.parameters [ "@id", Sql.string (PageId.toString pageId); webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toExists
// IMPLEMENTATION FUNCTIONS
/// Get all pages for a web log (without text, revisions, prior permalinks, or metadata)
let all webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM page WHERE web_log_id = @webLogId ORDER BY LOWER(title)"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync pageWithoutText
/// Count all pages for the given web log
let countAll webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT COUNT(id) AS {countName} FROM page WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toCount
/// Count all pages shown in the page list for the given web log
let countListed webLogId =
Sql.existingConnection conn
|> Sql.query $"
SELECT COUNT(id) AS {countName}
FROM page
WHERE web_log_id = @webLogId
AND is_in_page_list = TRUE"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toCount
/// Find a page by its ID (without revisions)
let findById pageId webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM page WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters [ "@id", Sql.string (PageId.toString pageId); webLogIdParam webLogId ]
|> Sql.executeAsync toPage
|> tryHead
/// Find a complete page by its ID
let findFullById pageId webLogId = backgroundTask {
match! findById pageId webLogId with
| Some page ->
let! withMore = appendPageRevisions page
return Some withMore
| None -> return None
}
/// Delete a page by its ID
let delete pageId webLogId = backgroundTask {
match! pageExists pageId webLogId with
| true ->
let! _ =
Sql.existingConnection conn
|> Sql.query
"DELETE FROM page_revision WHERE page_id = @id;
DELETE FROM page WHERE id = @id"
|> Sql.parameters [ "@id", Sql.string (PageId.toString pageId) ]
|> Sql.executeNonQueryAsync
return true
| false -> return false
}
/// Find a page by its permalink for the given web log
let findByPermalink permalink webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM page WHERE web_log_id = @webLogId AND permalink = @link"
|> Sql.parameters [ webLogIdParam webLogId; "@link", Sql.string (Permalink.toString permalink) ]
|> Sql.executeAsync toPage
|> tryHead
/// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
if List.isEmpty permalinks then return None
else
let linkSql, linkParams = arrayInClause "prior_permalinks" Permalink.toString permalinks
return!
Sql.existingConnection conn
|> Sql.query $"SELECT permalink FROM page WHERE web_log_id = @webLogId AND ({linkSql})"
|> Sql.parameters (webLogIdParam webLogId :: linkParams)
|> Sql.executeAsync Map.toPermalink
|> tryHead
}
/// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask {
let! pages =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM page WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync toPage
let! revisions =
Sql.existingConnection conn
|> Sql.query
"SELECT *
FROM page_revision pr
INNER JOIN page p ON p.id = pr.page_id
WHERE p.web_log_id = @webLogId
ORDER BY pr.as_of DESC"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync (fun row -> PageId (row.string "page_id"), Map.toRevision row)
return
pages
|> List.map (fun it ->
{ it with Revisions = revisions |> List.filter (fun r -> fst r = it.Id) |> List.map snd })
}
/// Get all listed pages for the given web log (without revisions or text)
let findListed webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM page WHERE web_log_id = @webLogId AND is_in_page_list = TRUE ORDER BY LOWER(title)"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync pageWithoutText
/// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr =
Sql.existingConnection conn
|> Sql.query
"SELECT *
FROM page
WHERE web_log_id = @webLogId
ORDER BY LOWER(title)
LIMIT @pageSize OFFSET @toSkip"
|> Sql.parameters [ webLogIdParam webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ]
|> Sql.executeAsync toPage
/// The INSERT statement for a page
let pageInsert =
"INSERT INTO page (
id, web_log_id, author_id, title, permalink, prior_permalinks, published_on, updated_on, is_in_page_list,
template, page_text, meta_items
) VALUES (
@id, @webLogId, @authorId, @title, @permalink, @priorPermalinks, @publishedOn, @updatedOn, @isInPageList,
@template, @text, @metaItems
)"
/// The parameters for saving a page
let pageParams (page : Page) = [
webLogIdParam page.WebLogId
"@id", Sql.string (PageId.toString page.Id)
"@authorId", Sql.string (WebLogUserId.toString page.AuthorId)
"@title", Sql.string page.Title
"@permalink", Sql.string (Permalink.toString page.Permalink)
"@isInPageList", Sql.bool page.IsInPageList
"@template", Sql.stringOrNone page.Template
"@text", Sql.string page.Text
"@metaItems", Sql.jsonb (Utils.serialize ser page.Metadata)
"@priorPermalinks", Sql.stringArray (page.PriorPermalinks |> List.map Permalink.toString |> Array.ofList)
typedParam "publishedOn" page.PublishedOn
typedParam "updatedOn" page.UpdatedOn
]
/// Restore pages from a backup
let restore (pages : Page list) = backgroundTask {
let revisions = pages |> List.collect (fun p -> p.Revisions |> List.map (fun r -> p.Id, r))
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
pageInsert, pages |> List.map pageParams
revInsert, revisions |> List.map (fun (pageId, rev) -> revParams pageId rev)
]
()
}
/// Save a page
let save (page : Page) = backgroundTask {
let! oldPage = findFullById page.Id page.WebLogId
let! _ =
Sql.existingConnection conn
|> Sql.query $"
{pageInsert} ON CONFLICT (id) DO UPDATE
SET author_id = EXCLUDED.author_id,
title = EXCLUDED.title,
permalink = EXCLUDED.permalink,
prior_permalinks = EXCLUDED.prior_permalinks,
published_on = EXCLUDED.published_on,
updated_on = EXCLUDED.updated_on,
is_in_page_list = EXCLUDED.is_in_page_list,
template = EXCLUDED.template,
page_text = EXCLUDED.page_text,
meta_items = EXCLUDED.meta_items"
|> Sql.parameters (pageParams page)
|> Sql.executeNonQueryAsync
do! updatePageRevisions page.Id (match oldPage with Some p -> p.Revisions | None -> []) page.Revisions
()
}
/// Update a page's prior permalinks
let updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! pageExists pageId webLogId with
| true ->
let! _ =
Sql.existingConnection conn
|> Sql.query "UPDATE page SET prior_permalinks = @prior WHERE id = @id"
|> Sql.parameters
[ "@id", Sql.string (PageId.toString pageId)
"@prior", Sql.stringArray (permalinks |> List.map Permalink.toString |> Array.ofList) ]
|> Sql.executeNonQueryAsync
return true
| false -> return false
}
interface IPageData with
member _.Add page = save page
member _.All webLogId = all webLogId
member _.CountAll webLogId = countAll webLogId
member _.CountListed webLogId = countListed webLogId
member _.Delete pageId webLogId = delete pageId webLogId
member _.FindById pageId webLogId = findById pageId webLogId
member _.FindByPermalink permalink webLogId = findByPermalink permalink webLogId
member _.FindCurrentPermalink permalinks webLogId = findCurrentPermalink permalinks webLogId
member _.FindFullById pageId webLogId = findFullById pageId webLogId
member _.FindFullByWebLog webLogId = findFullByWebLog webLogId
member _.FindListed webLogId = findListed webLogId
member _.FindPageOfPages webLogId pageNbr = findPageOfPages webLogId pageNbr
member _.Restore pages = restore pages
member _.Update page = save page
member _.UpdatePriorPermalinks pageId webLogId permalinks = updatePriorPermalinks pageId webLogId permalinks

View File

@ -0,0 +1,378 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open NodaTime
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog post data implementation
type PostgresPostData (conn : NpgsqlConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
/// Append revisions to a post
let appendPostRevisions (post : Post) = backgroundTask {
let! revisions =
Sql.existingConnection conn
|> Sql.query "SELECT as_of, revision_text FROM post_revision WHERE post_id = @id ORDER BY as_of DESC"
|> Sql.parameters [ "@id", Sql.string (PostId.toString post.Id) ]
|> Sql.executeAsync Map.toRevision
return { post with Revisions = revisions }
}
/// The SELECT statement for a post that will include category IDs
let selectPost =
"SELECT *, ARRAY(SELECT cat.category_id FROM post_category cat WHERE cat.post_id = p.id) AS category_ids
FROM post p"
/// Shorthand for mapping to a post
let toPost = Map.toPost ser
/// Return a post with no revisions, prior permalinks, or text
let postWithoutText row =
{ toPost row with Text = "" }
/// The INSERT statement for a post/category cross-reference
let catInsert = "INSERT INTO post_category VALUES (@postId, @categoryId)"
/// Parameters for adding or updating a post/category cross-reference
let catParams postId cat = [
"@postId", Sql.string (PostId.toString postId)
"categoryId", Sql.string (CategoryId.toString cat)
]
/// Update a post's assigned categories
let updatePostCategories postId oldCats newCats = backgroundTask {
let toDelete, toAdd = Utils.diffLists oldCats newCats CategoryId.toString
if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
if not (List.isEmpty toDelete) then
"DELETE FROM post_category WHERE post_id = @postId AND category_id = @categoryId",
toDelete |> List.map (catParams postId)
if not (List.isEmpty toAdd) then
catInsert, toAdd |> List.map (catParams postId)
]
()
}
/// The INSERT statement for a post revision
let revInsert = "INSERT INTO post_revision VALUES (@postId, @asOf, @text)"
/// The parameters for adding a post revision
let revParams postId rev = [
typedParam "asOf" rev.AsOf
"@postId", Sql.string (PostId.toString postId)
"@text", Sql.string (MarkupText.toString rev.Text)
]
/// Update a post's revisions
let updatePostRevisions postId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
if not (List.isEmpty toDelete) || not (List.isEmpty toAdd) then
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
if not (List.isEmpty toDelete) then
"DELETE FROM post_revision WHERE post_id = @postId AND as_of = @asOf",
toDelete
|> List.map (fun it -> [
"@postId", Sql.string (PostId.toString postId)
typedParam "asOf" it.AsOf
])
if not (List.isEmpty toAdd) then
revInsert, toAdd |> List.map (revParams postId)
]
()
}
/// Does the given post exist?
let postExists postId webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT EXISTS (SELECT 1 FROM post WHERE id = @id AND web_log_id = @webLogId) AS {existsName}"
|> Sql.parameters [ "@id", Sql.string (PostId.toString postId); webLogIdParam webLogId ]
|> Sql.executeRowAsync Map.toExists
// IMPLEMENTATION FUNCTIONS
/// Count posts in a status for the given web log
let countByStatus status webLogId =
Sql.existingConnection conn
|> Sql.query $"SELECT COUNT(id) AS {countName} FROM post WHERE web_log_id = @webLogId AND status = @status"
|> Sql.parameters [ webLogIdParam webLogId; "@status", Sql.string (PostStatus.toString status) ]
|> Sql.executeRowAsync Map.toCount
/// Find a post by its ID for the given web log (excluding revisions)
let findById postId webLogId =
Sql.existingConnection conn
|> Sql.query $"{selectPost} WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters [ "@id", Sql.string (PostId.toString postId); webLogIdParam webLogId ]
|> Sql.executeAsync toPost
|> tryHead
/// Find a post by its permalink for the given web log (excluding revisions and prior permalinks)
let findByPermalink permalink webLogId =
Sql.existingConnection conn
|> Sql.query $"{selectPost} WHERE web_log_id = @webLogId AND permalink = @link"
|> Sql.parameters [ webLogIdParam webLogId; "@link", Sql.string (Permalink.toString permalink) ]
|> Sql.executeAsync toPost
|> tryHead
/// Find a complete post by its ID for the given web log
let findFullById postId webLogId = backgroundTask {
match! findById postId webLogId with
| Some post ->
let! withRevisions = appendPostRevisions post
return Some withRevisions
| None -> return None
}
/// Delete a post by its ID for the given web log
let delete postId webLogId = backgroundTask {
match! postExists postId webLogId with
| true ->
let! _ =
Sql.existingConnection conn
|> Sql.query
"DELETE FROM post_revision WHERE post_id = @id;
DELETE FROM post_category WHERE post_id = @id;
DELETE FROM post WHERE id = @id"
|> Sql.parameters [ "@id", Sql.string (PostId.toString postId) ]
|> Sql.executeNonQueryAsync
return true
| false -> return false
}
/// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
if List.isEmpty permalinks then return None
else
let linkSql, linkParams = arrayInClause "prior_permalinks" Permalink.toString permalinks
return!
Sql.existingConnection conn
|> Sql.query $"SELECT permalink FROM post WHERE web_log_id = @webLogId AND ({linkSql})"
|> Sql.parameters (webLogIdParam webLogId :: linkParams)
|> Sql.executeAsync Map.toPermalink
|> tryHead
}
/// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask {
let! posts =
Sql.existingConnection conn
|> Sql.query $"{selectPost} WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync toPost
let! revisions =
Sql.existingConnection conn
|> Sql.query
"SELECT *
FROM post_revision pr
INNER JOIN post p ON p.id = pr.post_id
WHERE p.web_log_id = @webLogId
ORDER BY as_of DESC"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync (fun row -> PostId (row.string "post_id"), Map.toRevision row)
return
posts
|> List.map (fun it ->
{ it with Revisions = revisions |> List.filter (fun r -> fst r = it.Id) |> List.map snd })
}
/// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage =
let catSql, catParams = inClause "AND pc.category_id" "catId" CategoryId.toString categoryIds
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = @status
{catSql}
ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
|> Sql.parameters
[ webLogIdParam webLogId
"@status", Sql.string (PostStatus.toString Published)
yield! catParams ]
|> Sql.executeAsync toPost
/// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage =
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
WHERE web_log_id = @webLogId
ORDER BY published_on DESC NULLS FIRST, updated_on
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync postWithoutText
/// Get a page of published posts for the given web log (excludes revisions)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
WHERE web_log_id = @webLogId
AND status = @status
ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
|> Sql.parameters [ webLogIdParam webLogId; "@status", Sql.string (PostStatus.toString Published) ]
|> Sql.executeAsync toPost
/// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage =
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
WHERE web_log_id = @webLogId
AND status = @status
AND tags && ARRAY[@tag]
ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
|> Sql.parameters
[ webLogIdParam webLogId
"@status", Sql.string (PostStatus.toString Published)
"@tag", Sql.string tag
]
|> Sql.executeAsync toPost
/// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask {
let queryParams () = Sql.parameters [
webLogIdParam webLogId
typedParam "publishedOn" publishedOn
"@status", Sql.string (PostStatus.toString Published)
]
let! older =
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
WHERE web_log_id = @webLogId
AND status = @status
AND published_on < @publishedOn
ORDER BY published_on DESC
LIMIT 1"
|> queryParams ()
|> Sql.executeAsync toPost
let! newer =
Sql.existingConnection conn
|> Sql.query $"
{selectPost}
WHERE web_log_id = @webLogId
AND status = @status
AND published_on > @publishedOn
ORDER BY published_on
LIMIT 1"
|> queryParams ()
|> Sql.executeAsync toPost
return List.tryHead older, List.tryHead newer
}
/// The INSERT statement for a post
let postInsert =
"INSERT INTO post (
id, web_log_id, author_id, status, title, permalink, prior_permalinks, published_on, updated_on,
template, post_text, tags, meta_items, episode
) VALUES (
@id, @webLogId, @authorId, @status, @title, @permalink, @priorPermalinks, @publishedOn, @updatedOn,
@template, @text, @tags, @metaItems, @episode
)"
/// The parameters for saving a post
let postParams (post : Post) = [
webLogIdParam post.WebLogId
"@id", Sql.string (PostId.toString post.Id)
"@authorId", Sql.string (WebLogUserId.toString post.AuthorId)
"@status", Sql.string (PostStatus.toString post.Status)
"@title", Sql.string post.Title
"@permalink", Sql.string (Permalink.toString post.Permalink)
"@template", Sql.stringOrNone post.Template
"@text", Sql.string post.Text
"@priorPermalinks", Sql.stringArray (post.PriorPermalinks |> List.map Permalink.toString |> Array.ofList)
"@episode", Sql.jsonbOrNone (post.Episode |> Option.map (Utils.serialize ser))
"@tags", Sql.stringArrayOrNone (if List.isEmpty post.Tags then None else Some (Array.ofList post.Tags))
"@metaItems",
if List.isEmpty post.Metadata then None else Some (Utils.serialize ser post.Metadata)
|> Sql.jsonbOrNone
optParam "publishedOn" post.PublishedOn
typedParam "updatedOn" post.UpdatedOn
]
/// Save a post
let save (post : Post) = backgroundTask {
let! oldPost = findFullById post.Id post.WebLogId
let! _ =
Sql.existingConnection conn
|> Sql.query $"
{postInsert} ON CONFLICT (id) DO UPDATE
SET author_id = EXCLUDED.author_id,
status = EXCLUDED.status,
title = EXCLUDED.title,
permalink = EXCLUDED.permalink,
prior_permalinks = EXCLUDED.prior_permalinks,
published_on = EXCLUDED.published_on,
updated_on = EXCLUDED.updated_on,
template = EXCLUDED.template,
post_text = EXCLUDED.post_text,
tags = EXCLUDED.tags,
meta_items = EXCLUDED.meta_items,
episode = EXCLUDED.episode"
|> Sql.parameters (postParams post)
|> Sql.executeNonQueryAsync
do! updatePostCategories post.Id (match oldPost with Some p -> p.CategoryIds | None -> []) post.CategoryIds
do! updatePostRevisions post.Id (match oldPost with Some p -> p.Revisions | None -> []) post.Revisions
}
/// Restore posts from a backup
let restore posts = backgroundTask {
let cats = posts |> List.collect (fun p -> p.CategoryIds |> List.map (fun c -> p.Id, c))
let revisions = posts |> List.collect (fun p -> p.Revisions |> List.map (fun r -> p.Id, r))
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
postInsert, posts |> List.map postParams
catInsert, cats |> List.map (fun (postId, catId) -> catParams postId catId)
revInsert, revisions |> List.map (fun (postId, rev) -> revParams postId rev)
]
()
}
/// Update prior permalinks for a post
let updatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! postExists postId webLogId with
| true ->
let! _ =
Sql.existingConnection conn
|> Sql.query "UPDATE post SET prior_permalinks = @prior WHERE id = @id"
|> Sql.parameters
[ "@id", Sql.string (PostId.toString postId)
"@prior", Sql.stringArray (permalinks |> List.map Permalink.toString |> Array.ofList) ]
|> Sql.executeNonQueryAsync
return true
| false -> return false
}
interface IPostData with
member _.Add post = save post
member _.CountByStatus status webLogId = countByStatus status webLogId
member _.Delete postId webLogId = delete postId webLogId
member _.FindById postId webLogId = findById postId webLogId
member _.FindByPermalink permalink webLogId = findByPermalink permalink webLogId
member _.FindCurrentPermalink permalinks webLogId = findCurrentPermalink permalinks webLogId
member _.FindFullById postId webLogId = findFullById postId webLogId
member _.FindFullByWebLog webLogId = findFullByWebLog webLogId
member _.FindPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage =
findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage
member _.FindPageOfPosts webLogId pageNbr postsPerPage = findPageOfPosts webLogId pageNbr postsPerPage
member _.FindPageOfPublishedPosts webLogId pageNbr postsPerPage =
findPageOfPublishedPosts webLogId pageNbr postsPerPage
member _.FindPageOfTaggedPosts webLogId tag pageNbr postsPerPage =
findPageOfTaggedPosts webLogId tag pageNbr postsPerPage
member _.FindSurroundingPosts webLogId publishedOn = findSurroundingPosts webLogId publishedOn
member _.Restore posts = restore posts
member _.Update post = save post
member _.UpdatePriorPermalinks postId webLogId permalinks = updatePriorPermalinks postId webLogId permalinks

View File

@ -0,0 +1,109 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog tag mapping data implementation
type PostgresTagMapData (conn : NpgsqlConnection) =
/// Find a tag mapping by its ID for the given web log
let findById tagMapId webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM tag_map WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters [ "@id", Sql.string (TagMapId.toString tagMapId); webLogIdParam webLogId ]
|> Sql.executeAsync Map.toTagMap
|> tryHead
/// Delete a tag mapping for the given web log
let delete tagMapId webLogId = backgroundTask {
let idParams = [ "@id", Sql.string (TagMapId.toString tagMapId) ]
let! exists =
Sql.existingConnection conn
|> Sql.query $"
SELECT EXISTS
(SELECT 1 FROM tag_map WHERE id = @id AND web_log_id = @webLogId)
AS {existsName}"
|> Sql.parameters (webLogIdParam webLogId :: idParams)
|> Sql.executeRowAsync Map.toExists
if exists then
let! _ =
Sql.existingConnection conn
|> Sql.query "DELETE FROM tag_map WHERE id = @id"
|> Sql.parameters idParams
|> Sql.executeNonQueryAsync
return true
else return false
}
/// Find a tag mapping by its URL value for the given web log
let findByUrlValue urlValue webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM tag_map WHERE web_log_id = @webLogId AND url_value = @urlValue"
|> Sql.parameters [ webLogIdParam webLogId; "@urlValue", Sql.string urlValue ]
|> Sql.executeAsync Map.toTagMap
|> tryHead
/// Get all tag mappings for the given web log
let findByWebLog webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM tag_map WHERE web_log_id = @webLogId ORDER BY tag"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync Map.toTagMap
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags tags webLogId =
let tagSql, tagParams = inClause "AND tag" "tag" id tags
Sql.existingConnection conn
|> Sql.query $"SELECT * FROM tag_map WHERE web_log_id = @webLogId {tagSql}"
|> Sql.parameters (webLogIdParam webLogId :: tagParams)
|> Sql.executeAsync Map.toTagMap
/// The INSERT statement for a tag mapping
let tagMapInsert =
"INSERT INTO tag_map (
id, web_log_id, tag, url_value
) VALUES (
@id, @webLogId, @tag, @urlValue
)"
/// The parameters for saving a tag mapping
let tagMapParams (tagMap : TagMap) = [
webLogIdParam tagMap.WebLogId
"@id", Sql.string (TagMapId.toString tagMap.Id)
"@tag", Sql.string tagMap.Tag
"@urlValue", Sql.string tagMap.UrlValue
]
/// Save a tag mapping
let save tagMap = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query $"
{tagMapInsert} ON CONFLICT (id) DO UPDATE
SET tag = EXCLUDED.tag,
url_value = EXCLUDED.url_value"
|> Sql.parameters (tagMapParams tagMap)
|> Sql.executeNonQueryAsync
()
}
/// Restore tag mappings from a backup
let restore tagMaps = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
tagMapInsert, tagMaps |> List.map tagMapParams
]
()
}
interface ITagMapData with
member _.Delete tagMapId webLogId = delete tagMapId webLogId
member _.FindById tagMapId webLogId = findById tagMapId webLogId
member _.FindByUrlValue urlValue webLogId = findByUrlValue urlValue webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindMappingForTags tags webLogId = findMappingForTags tags webLogId
member _.Save tagMap = save tagMap
member _.Restore tagMaps = restore tagMaps

View File

@ -0,0 +1,207 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Npgsql
open Npgsql.FSharp
/// PostreSQL myWebLog theme data implementation
type PostgresThemeData (conn : NpgsqlConnection) =
/// Retrieve all themes (except 'admin'; excludes template text)
let all () = backgroundTask {
let! themes =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM theme WHERE id <> 'admin' ORDER BY id"
|> Sql.executeAsync Map.toTheme
let! templates =
Sql.existingConnection conn
|> Sql.query "SELECT name, theme_id FROM theme_template WHERE theme_id <> 'admin' ORDER BY name"
|> Sql.executeAsync (fun row -> ThemeId (row.string "theme_id"), Map.toThemeTemplate false row)
return
themes
|> List.map (fun t ->
{ t with Templates = templates |> List.filter (fun tt -> fst tt = t.Id) |> List.map snd })
}
/// Does a given theme exist?
let exists themeId =
Sql.existingConnection conn
|> Sql.query "SELECT EXISTS (SELECT 1 FROM theme WHERE id = @id) AS does_exist"
|> Sql.parameters [ "@id", Sql.string (ThemeId.toString themeId) ]
|> Sql.executeRowAsync Map.toExists
/// Find a theme by its ID
let findById themeId = backgroundTask {
let themeIdParam = [ "@id", Sql.string (ThemeId.toString themeId) ]
let! theme =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM theme WHERE id = @id"
|> Sql.parameters themeIdParam
|> Sql.executeAsync Map.toTheme
|> tryHead
if Option.isSome theme then
let! templates =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM theme_template WHERE theme_id = @id"
|> Sql.parameters themeIdParam
|> Sql.executeAsync (Map.toThemeTemplate true)
return Some { theme.Value with Templates = templates }
else return None
}
/// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText themeId = backgroundTask {
match! findById themeId with
| Some theme ->
return Some {
theme with Templates = theme.Templates |> List.map (fun t -> { t with Text = "" })
}
| None -> return None
}
/// Delete a theme by its ID
let delete themeId = backgroundTask {
let idParams = [ "@id", Sql.string (ThemeId.toString themeId) ]
let! exists =
Sql.existingConnection conn
|> Sql.query $"SELECT EXISTS (SELECT 1 FROM theme WHERE id = @id) AS {existsName}"
|> Sql.parameters idParams
|> Sql.executeRowAsync Map.toExists
if exists then
let! _ =
Sql.existingConnection conn
|> Sql.query
"DELETE FROM theme_asset WHERE theme_id = @id;
DELETE FROM theme_template WHERE theme_id = @id;
DELETE FROM theme WHERE id = @id"
|> Sql.parameters idParams
|> Sql.executeNonQueryAsync
return true
else return false
}
/// Save a theme
let save (theme : Theme) = backgroundTask {
let! oldTheme = findById theme.Id
let themeIdParam = Sql.string (ThemeId.toString theme.Id)
let! _ =
Sql.existingConnection conn
|> Sql.query
"INSERT INTO theme VALUES (@id, @name, @version)
ON CONFLICT (id) DO UPDATE
SET name = EXCLUDED.name,
version = EXCLUDED.version"
|> Sql.parameters
[ "@id", themeIdParam
"@name", Sql.string theme.Name
"@version", Sql.string theme.Version ]
|> Sql.executeNonQueryAsync
let toDelete, _ =
Utils.diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue [])
theme.Templates (fun t -> t.Name)
let toAddOrUpdate =
theme.Templates
|> List.filter (fun t -> not (toDelete |> List.exists (fun d -> d.Name = t.Name)))
if not (List.isEmpty toDelete) || not (List.isEmpty toAddOrUpdate) then
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
if not (List.isEmpty toDelete) then
"DELETE FROM theme_template WHERE theme_id = @themeId AND name = @name",
toDelete |> List.map (fun tmpl -> [ "@themeId", themeIdParam; "@name", Sql.string tmpl.Name ])
if not (List.isEmpty toAddOrUpdate) then
"INSERT INTO theme_template VALUES (@themeId, @name, @template)
ON CONFLICT (theme_id, name) DO UPDATE
SET template = EXCLUDED.template",
toAddOrUpdate |> List.map (fun tmpl -> [
"@themeId", themeIdParam
"@name", Sql.string tmpl.Name
"@template", Sql.string tmpl.Text
])
]
()
}
interface IThemeData with
member _.All () = all ()
member _.Delete themeId = delete themeId
member _.Exists themeId = exists themeId
member _.FindById themeId = findById themeId
member _.FindByIdWithoutText themeId = findByIdWithoutText themeId
member _.Save theme = save theme
/// PostreSQL myWebLog theme data implementation
type PostgresThemeAssetData (conn : NpgsqlConnection) =
/// Get all theme assets (excludes data)
let all () =
Sql.existingConnection conn
|> Sql.query "SELECT theme_id, path, updated_on FROM theme_asset"
|> Sql.executeAsync (Map.toThemeAsset false)
/// Delete all assets for the given theme
let deleteByTheme themeId = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query "DELETE FROM theme_asset WHERE theme_id = @themeId"
|> Sql.parameters [ "@themeId", Sql.string (ThemeId.toString themeId) ]
|> Sql.executeNonQueryAsync
()
}
/// Find a theme asset by its ID
let findById assetId =
let (ThemeAssetId (ThemeId themeId, path)) = assetId
Sql.existingConnection conn
|> Sql.query "SELECT * FROM theme_asset WHERE theme_id = @themeId AND path = @path"
|> Sql.parameters [ "@themeId", Sql.string themeId; "@path", Sql.string path ]
|> Sql.executeAsync (Map.toThemeAsset true)
|> tryHead
/// Get theme assets for the given theme (excludes data)
let findByTheme themeId =
Sql.existingConnection conn
|> Sql.query "SELECT theme_id, path, updated_on FROM theme_asset WHERE theme_id = @themeId"
|> Sql.parameters [ "@themeId", Sql.string (ThemeId.toString themeId) ]
|> Sql.executeAsync (Map.toThemeAsset false)
/// Get theme assets for the given theme
let findByThemeWithData themeId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM theme_asset WHERE theme_id = @themeId"
|> Sql.parameters [ "@themeId", Sql.string (ThemeId.toString themeId) ]
|> Sql.executeAsync (Map.toThemeAsset true)
/// Save a theme asset
let save (asset : ThemeAsset) = backgroundTask {
let (ThemeAssetId (ThemeId themeId, path)) = asset.Id
let! _ =
Sql.existingConnection conn
|> Sql.query
"INSERT INTO theme_asset (
theme_id, path, updated_on, data
) VALUES (
@themeId, @path, @updatedOn, @data
) ON CONFLICT (theme_id, path) DO UPDATE
SET updated_on = EXCLUDED.updated_on,
data = EXCLUDED.data"
|> Sql.parameters
[ "@themeId", Sql.string themeId
"@path", Sql.string path
"@data", Sql.bytea asset.Data
typedParam "updatedOn" asset.UpdatedOn ]
|> Sql.executeNonQueryAsync
()
}
interface IThemeAssetData with
member _.All () = all ()
member _.DeleteByTheme themeId = deleteByTheme themeId
member _.FindById assetId = findById assetId
member _.FindByTheme themeId = findByTheme themeId
member _.FindByThemeWithData themeId = findByThemeWithData themeId
member _.Save asset = save asset

View File

@ -0,0 +1,97 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog uploaded file data implementation
type PostgresUploadData (conn : NpgsqlConnection) =
/// The INSERT statement for an uploaded file
let upInsert =
"INSERT INTO upload (
id, web_log_id, path, updated_on, data
) VALUES (
@id, @webLogId, @path, @updatedOn, @data
)"
/// Parameters for adding an uploaded file
let upParams (upload : Upload) = [
webLogIdParam upload.WebLogId
typedParam "updatedOn" upload.UpdatedOn
"@id", Sql.string (UploadId.toString upload.Id)
"@path", Sql.string (Permalink.toString upload.Path)
"@data", Sql.bytea upload.Data
]
/// Save an uploaded file
let add upload = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query upInsert
|> Sql.parameters (upParams upload)
|> Sql.executeNonQueryAsync
()
}
/// Delete an uploaded file by its ID
let delete uploadId webLogId = backgroundTask {
let theParams = [ "@id", Sql.string (UploadId.toString uploadId); webLogIdParam webLogId ]
let! path =
Sql.existingConnection conn
|> Sql.query "SELECT path FROM upload WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters theParams
|> Sql.executeAsync (fun row -> row.string "path")
|> tryHead
if Option.isSome path then
let! _ =
Sql.existingConnection conn
|> Sql.query "DELETE FROM upload WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters theParams
|> Sql.executeNonQueryAsync
return Ok path.Value
else return Error $"""Upload ID {UploadId.toString uploadId} not found"""
}
/// Find an uploaded file by its path for the given web log
let findByPath path webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM upload WHERE web_log_id = @webLogId AND path = @path"
|> Sql.parameters [ webLogIdParam webLogId; "@path", Sql.string path ]
|> Sql.executeAsync (Map.toUpload true)
|> tryHead
/// Find all uploaded files for the given web log (excludes data)
let findByWebLog webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT id, web_log_id, path, updated_on FROM upload WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync (Map.toUpload false)
/// Find all uploaded files for the given web log
let findByWebLogWithData webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM upload WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync (Map.toUpload true)
/// Restore uploads from a backup
let restore uploads = backgroundTask {
for batch in uploads |> List.chunkBySize 5 do
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
upInsert, batch |> List.map upParams
]
()
}
interface IUploadData with
member _.Add upload = add upload
member _.Delete uploadId webLogId = delete uploadId webLogId
member _.FindByPath path webLogId = findByPath path webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindByWebLogWithData webLogId = findByWebLogWithData webLogId
member _.Restore uploads = restore uploads

View File

@ -0,0 +1,238 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog web log data implementation
type PostgresWebLogData (conn : NpgsqlConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
/// The parameters for web log INSERT or web log/RSS options UPDATE statements
let rssParams (webLog : WebLog) = [
"@isFeedEnabled", Sql.bool webLog.Rss.IsFeedEnabled
"@feedName", Sql.string webLog.Rss.FeedName
"@itemsInFeed", Sql.intOrNone webLog.Rss.ItemsInFeed
"@isCategoryEnabled", Sql.bool webLog.Rss.IsCategoryEnabled
"@isTagEnabled", Sql.bool webLog.Rss.IsTagEnabled
"@copyright", Sql.stringOrNone webLog.Rss.Copyright
]
/// The parameters for web log INSERT or UPDATE statements
let webLogParams (webLog : WebLog) = [
"@id", Sql.string (WebLogId.toString webLog.Id)
"@name", Sql.string webLog.Name
"@slug", Sql.string webLog.Slug
"@subtitle", Sql.stringOrNone webLog.Subtitle
"@defaultPage", Sql.string webLog.DefaultPage
"@postsPerPage", Sql.int webLog.PostsPerPage
"@themeId", Sql.string (ThemeId.toString webLog.ThemeId)
"@urlBase", Sql.string webLog.UrlBase
"@timeZone", Sql.string webLog.TimeZone
"@autoHtmx", Sql.bool webLog.AutoHtmx
"@uploads", Sql.string (UploadDestination.toString webLog.Uploads)
yield! rssParams webLog
]
/// Shorthand to map a result to a custom feed
let toCustomFeed =
Map.toCustomFeed ser
/// Get the current custom feeds for a web log
let getCustomFeeds (webLog : WebLog) =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log_feed WHERE web_log_id = @webLogId"
|> Sql.parameters [ webLogIdParam webLog.Id ]
|> Sql.executeAsync toCustomFeed
/// Append custom feeds to a web log
let appendCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog
return { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
}
/// The parameters to save a custom feed
let feedParams webLogId (feed : CustomFeed) = [
webLogIdParam webLogId
"@id", Sql.string (CustomFeedId.toString feed.Id)
"@source", Sql.string (CustomFeedSource.toString feed.Source)
"@path", Sql.string (Permalink.toString feed.Path)
"@podcast", Sql.jsonbOrNone (feed.Podcast |> Option.map (Utils.serialize ser))
]
/// Update the custom feeds for a web log
let updateCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog
let toDelete, _ = Utils.diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}")
let toId (feed : CustomFeed) = feed.Id
let toAddOrUpdate =
webLog.Rss.CustomFeeds |> List.filter (fun f -> not (toDelete |> List.map toId |> List.contains f.Id))
if not (List.isEmpty toDelete) || not (List.isEmpty toAddOrUpdate) then
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
if not (List.isEmpty toDelete) then
"DELETE FROM web_log_feed WHERE id = @id",
toDelete |> List.map (fun it -> [ "@id", Sql.string (CustomFeedId.toString it.Id) ])
if not (List.isEmpty toAddOrUpdate) then
"INSERT INTO web_log_feed (
id, web_log_id, source, path, podcast
) VALUES (
@id, @webLogId, @source, @path, @podcast
) ON CONFLICT (id) DO UPDATE
SET source = EXCLUDED.source,
path = EXCLUDED.path,
podcast = EXCLUDED.podcast",
toAddOrUpdate |> List.map (feedParams webLog.Id)
]
()
}
// IMPLEMENTATION FUNCTIONS
/// Add a web log
let add webLog = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query
"INSERT INTO web_log (
id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx,
uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright
) VALUES (
@id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx,
@uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright
)"
|> Sql.parameters (webLogParams webLog)
|> Sql.executeNonQueryAsync
do! updateCustomFeeds webLog
}
/// Retrieve all web logs
let all () = backgroundTask {
let! webLogs =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log"
|> Sql.executeAsync Map.toWebLog
let! feeds =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log_feed"
|> Sql.executeAsync (fun row -> WebLogId (row.string "web_log_id"), toCustomFeed row)
return
webLogs
|> List.map (fun it ->
{ it with
Rss =
{ it.Rss with
CustomFeeds = feeds |> List.filter (fun (wlId, _) -> wlId = it.Id) |> List.map snd } })
}
/// Delete a web log by its ID
let delete webLogId = backgroundTask {
let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)"
let postSubQuery = subQuery "post"
let pageSubQuery = subQuery "page"
let! _ =
Sql.existingConnection conn
|> Sql.query $"
DELETE FROM post_comment WHERE post_id IN {postSubQuery};
DELETE FROM post_revision WHERE post_id IN {postSubQuery};
DELETE FROM post_category WHERE post_id IN {postSubQuery};
DELETE FROM post WHERE web_log_id = @webLogId;
DELETE FROM page_revision WHERE page_id IN {pageSubQuery};
DELETE FROM page WHERE web_log_id = @webLogId;
DELETE FROM category WHERE web_log_id = @webLogId;
DELETE FROM tag_map WHERE web_log_id = @webLogId;
DELETE FROM upload WHERE web_log_id = @webLogId;
DELETE FROM web_log_user WHERE web_log_id = @webLogId;
DELETE FROM web_log_feed WHERE web_log_id = @webLogId;
DELETE FROM web_log WHERE id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeNonQueryAsync
()
}
/// Find a web log by its host (URL base)
let findByHost url = backgroundTask {
let! webLog =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log WHERE url_base = @urlBase"
|> Sql.parameters [ "@urlBase", Sql.string url ]
|> Sql.executeAsync Map.toWebLog
|> tryHead
if Option.isSome webLog then
let! withFeeds = appendCustomFeeds webLog.Value
return Some withFeeds
else return None
}
/// Find a web log by its ID
let findById webLogId = backgroundTask {
let! webLog =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log WHERE id = @webLogId"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync Map.toWebLog
|> tryHead
if Option.isSome webLog then
let! withFeeds = appendCustomFeeds webLog.Value
return Some withFeeds
else return None
}
/// Update settings for a web log
let updateSettings webLog = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query
"UPDATE web_log
SET name = @name,
slug = @slug,
subtitle = @subtitle,
default_page = @defaultPage,
posts_per_page = @postsPerPage,
theme_id = @themeId,
url_base = @urlBase,
time_zone = @timeZone,
auto_htmx = @autoHtmx,
uploads = @uploads,
is_feed_enabled = @isFeedEnabled,
feed_name = @feedName,
items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @id"
|> Sql.parameters (webLogParams webLog)
|> Sql.executeNonQueryAsync
()
}
/// Update RSS options for a web log
let updateRssOptions (webLog : WebLog) = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query
"UPDATE web_log
SET is_feed_enabled = @isFeedEnabled,
feed_name = @feedName,
items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @webLogId"
|> Sql.parameters (webLogIdParam webLog.Id :: rssParams webLog)
|> Sql.executeNonQueryAsync
do! updateCustomFeeds webLog
}
interface IWebLogData with
member _.Add webLog = add webLog
member _.All () = all ()
member _.Delete webLogId = delete webLogId
member _.FindByHost url = findByHost url
member _.FindById webLogId = findById webLogId
member _.UpdateSettings webLog = updateSettings webLog
member _.UpdateRssOptions webLog = updateRssOptions webLog

View File

@ -0,0 +1,149 @@
namespace MyWebLog.Data.Postgres
open MyWebLog
open MyWebLog.Data
open Npgsql
open Npgsql.FSharp
/// PostgreSQL myWebLog user data implementation
type PostgresWebLogUserData (conn : NpgsqlConnection) =
/// The INSERT statement for a user
let userInsert =
"INSERT INTO web_log_user (
id, web_log_id, email, first_name, last_name, preferred_name, password_hash, url, access_level,
created_on, last_seen_on
) VALUES (
@id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @url, @accessLevel,
@createdOn, @lastSeenOn
)"
/// Parameters for saving web log users
let userParams (user : WebLogUser) = [
"@id", Sql.string (WebLogUserId.toString user.Id)
"@webLogId", Sql.string (WebLogId.toString user.WebLogId)
"@email", Sql.string user.Email
"@firstName", Sql.string user.FirstName
"@lastName", Sql.string user.LastName
"@preferredName", Sql.string user.PreferredName
"@passwordHash", Sql.string user.PasswordHash
"@url", Sql.stringOrNone user.Url
"@accessLevel", Sql.string (AccessLevel.toString user.AccessLevel)
typedParam "createdOn" user.CreatedOn
optParam "lastSeenOn" user.LastSeenOn
]
/// Find a user by their ID for the given web log
let findById userId webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log_user WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters [ "@id", Sql.string (WebLogUserId.toString userId); webLogIdParam webLogId ]
|> Sql.executeAsync Map.toWebLogUser
|> tryHead
/// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask {
match! findById userId webLogId with
| Some _ ->
let userParam = [ "@userId", Sql.string (WebLogUserId.toString userId) ]
let! isAuthor =
Sql.existingConnection conn
|> Sql.query
"SELECT ( EXISTS (SELECT 1 FROM page WHERE author_id = @userId
OR EXISTS (SELECT 1 FROM post WHERE author_id = @userId)) AS does_exist"
|> Sql.parameters userParam
|> Sql.executeRowAsync Map.toExists
if isAuthor then
return Error "User has pages or posts; cannot delete"
else
let! _ =
Sql.existingConnection conn
|> Sql.query "DELETE FROM web_log_user WHERE id = @userId"
|> Sql.parameters userParam
|> Sql.executeNonQueryAsync
return Ok true
| None -> return Error "User does not exist"
}
/// Find a user by their e-mail address for the given web log
let findByEmail email webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND email = @email"
|> Sql.parameters [ webLogIdParam webLogId; "@email", Sql.string email ]
|> Sql.executeAsync Map.toWebLogUser
|> tryHead
/// Get all users for the given web log
let findByWebLog webLogId =
Sql.existingConnection conn
|> Sql.query "SELECT * FROM web_log_user WHERE web_log_id = @webLogId ORDER BY LOWER(preferred_name)"
|> Sql.parameters [ webLogIdParam webLogId ]
|> Sql.executeAsync Map.toWebLogUser
/// Find the names of users by their IDs for the given web log
let findNames webLogId userIds = backgroundTask {
let idSql, idParams = inClause "AND id" "id" WebLogUserId.toString userIds
let! users =
Sql.existingConnection conn
|> Sql.query $"SELECT * FROM web_log_user WHERE web_log_id = @webLogId {idSql}"
|> Sql.parameters (webLogIdParam webLogId :: idParams)
|> Sql.executeAsync Map.toWebLogUser
return
users
|> List.map (fun u -> { Name = WebLogUserId.toString u.Id; Value = WebLogUser.displayName u })
}
/// Restore users from a backup
let restore users = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.executeTransactionAsync [
userInsert, users |> List.map userParams
]
()
}
/// Set a user's last seen date/time to now
let setLastSeen userId webLogId = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query "UPDATE web_log_user SET last_seen_on = @lastSeenOn WHERE id = @id AND web_log_id = @webLogId"
|> Sql.parameters
[ webLogIdParam webLogId
typedParam "lastSeenOn" (Noda.now ())
"@id", Sql.string (WebLogUserId.toString userId) ]
|> Sql.executeNonQueryAsync
()
}
/// Save a user
let save user = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query $"
{userInsert} ON CONFLICT (id) DO UPDATE
SET email = @email,
first_name = @firstName,
last_name = @lastName,
preferred_name = @preferredName,
password_hash = @passwordHash,
url = @url,
access_level = @accessLevel,
created_on = @createdOn,
last_seen_on = @lastSeenOn"
|> Sql.parameters (userParams user)
|> Sql.executeNonQueryAsync
()
}
interface IWebLogUserData with
member _.Add user = save user
member _.Delete userId webLogId = delete userId webLogId
member _.FindByEmail email webLogId = findByEmail email webLogId
member _.FindById userId webLogId = findById userId webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId
member _.FindNames webLogId userIds = findNames webLogId userIds
member _.Restore users = restore users
member _.SetLastSeen userId webLogId = setLastSeen userId webLogId
member _.Update user = save user

View File

@ -0,0 +1,260 @@
namespace MyWebLog.Data
open Microsoft.Extensions.Logging
open MyWebLog.Data.Postgres
open Newtonsoft.Json
open Npgsql
open Npgsql.FSharp
/// Data implementation for PostgreSQL
type PostgresData (conn : NpgsqlConnection, log : ILogger<PostgresData>, ser : JsonSerializer) =
/// Create any needed tables
let ensureTables () = backgroundTask {
let _ = NpgsqlConnection.GlobalTypeMapper.UseNodaTime ()
let! tables =
Sql.existingConnection conn
|> Sql.query "SELECT tablename FROM pg_tables WHERE schemaname = 'public'"
|> Sql.executeAsync (fun row -> row.string "tablename")
let needsTable table = not (List.contains table tables)
let mutable isNew = false
let sql = seq {
// Theme tables
if needsTable "theme" then
isNew <- true
"CREATE TABLE theme (
id TEXT NOT NULL PRIMARY KEY,
name TEXT NOT NULL,
version TEXT NOT NULL)"
if needsTable "theme_template" then
"CREATE TABLE theme_template (
theme_id TEXT NOT NULL REFERENCES theme (id),
name TEXT NOT NULL,
template TEXT NOT NULL,
PRIMARY KEY (theme_id, name))"
if needsTable "theme_asset" then
"CREATE TABLE theme_asset (
theme_id TEXT NOT NULL REFERENCES theme (id),
path TEXT NOT NULL,
updated_on TIMESTAMPTZ NOT NULL,
data BYTEA NOT NULL,
PRIMARY KEY (theme_id, path))"
// Web log tables
if needsTable "web_log" then
"CREATE TABLE web_log (
id TEXT NOT NULL PRIMARY KEY,
name TEXT NOT NULL,
slug TEXT NOT NULL,
subtitle TEXT,
default_page TEXT NOT NULL,
posts_per_page INTEGER NOT NULL,
theme_id TEXT NOT NULL REFERENCES theme (id),
url_base TEXT NOT NULL,
time_zone TEXT NOT NULL,
auto_htmx BOOLEAN NOT NULL DEFAULT FALSE,
uploads TEXT NOT NULL,
is_feed_enabled BOOLEAN NOT NULL DEFAULT FALSE,
feed_name TEXT NOT NULL,
items_in_feed INTEGER,
is_category_enabled BOOLEAN NOT NULL DEFAULT FALSE,
is_tag_enabled BOOLEAN NOT NULL DEFAULT FALSE,
copyright TEXT)"
"CREATE INDEX web_log_theme_idx ON web_log (theme_id)"
if needsTable "web_log_feed" then
"CREATE TABLE web_log_feed (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
source TEXT NOT NULL,
path TEXT NOT NULL,
podcast JSONB)"
"CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)"
// Category table
if needsTable "category" then
"CREATE TABLE category (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
name TEXT NOT NULL,
slug TEXT NOT NULL,
description TEXT,
parent_id TEXT)"
"CREATE INDEX category_web_log_idx ON category (web_log_id)"
// Web log user table
if needsTable "web_log_user" then
"CREATE TABLE web_log_user (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
email TEXT NOT NULL,
first_name TEXT NOT NULL,
last_name TEXT NOT NULL,
preferred_name TEXT NOT NULL,
password_hash TEXT NOT NULL,
url TEXT,
access_level TEXT NOT NULL,
created_on TIMESTAMPTZ NOT NULL,
last_seen_on TIMESTAMPTZ)"
"CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id)"
"CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)"
// Page tables
if needsTable "page" then
"CREATE TABLE page (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
title TEXT NOT NULL,
permalink TEXT NOT NULL,
prior_permalinks TEXT[] NOT NULL DEFAULT '{}',
published_on TIMESTAMPTZ NOT NULL,
updated_on TIMESTAMPTZ NOT NULL,
is_in_page_list BOOLEAN NOT NULL DEFAULT FALSE,
template TEXT,
page_text TEXT NOT NULL,
meta_items JSONB)"
"CREATE INDEX page_web_log_idx ON page (web_log_id)"
"CREATE INDEX page_author_idx ON page (author_id)"
"CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)"
if needsTable "page_revision" then
"CREATE TABLE page_revision (
page_id TEXT NOT NULL REFERENCES page (id),
as_of TIMESTAMPTZ NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"
// Post tables
if needsTable "post" then
"CREATE TABLE post (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
status TEXT NOT NULL,
title TEXT NOT NULL,
permalink TEXT NOT NULL,
prior_permalinks TEXT[] NOT NULL DEFAULT '{}',
published_on TIMESTAMPTZ,
updated_on TIMESTAMPTZ NOT NULL,
template TEXT,
post_text TEXT NOT NULL,
tags TEXT[],
meta_items JSONB,
episode JSONB)"
"CREATE INDEX post_web_log_idx ON post (web_log_id)"
"CREATE INDEX post_author_idx ON post (author_id)"
"CREATE INDEX post_status_idx ON post (web_log_id, status, updated_on)"
"CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)"
if needsTable "post_category" then
"CREATE TABLE post_category (
post_id TEXT NOT NULL REFERENCES post (id),
category_id TEXT NOT NULL REFERENCES category (id),
PRIMARY KEY (post_id, category_id))"
"CREATE INDEX post_category_category_idx ON post_category (category_id)"
if needsTable "post_revision" then
"CREATE TABLE post_revision (
post_id TEXT NOT NULL REFERENCES post (id),
as_of TIMESTAMPTZ NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"
if needsTable "post_comment" then
"CREATE TABLE post_comment (
id TEXT NOT NULL PRIMARY KEY,
post_id TEXT NOT NULL REFERENCES post(id),
in_reply_to_id TEXT,
name TEXT NOT NULL,
email TEXT NOT NULL,
url TEXT,
status TEXT NOT NULL,
posted_on TIMESTAMPTZ NOT NULL,
comment_text TEXT NOT NULL)"
"CREATE INDEX post_comment_post_idx ON post_comment (post_id)"
// Tag map table
if needsTable "tag_map" then
"CREATE TABLE tag_map (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
tag TEXT NOT NULL,
url_value TEXT NOT NULL)"
"CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)"
// Uploaded file table
if needsTable "upload" then
"CREATE TABLE upload (
id TEXT NOT NULL PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
path TEXT NOT NULL,
updated_on TIMESTAMPTZ NOT NULL,
data BYTEA NOT NULL)"
"CREATE INDEX upload_web_log_idx ON upload (web_log_id)"
"CREATE INDEX upload_path_idx ON upload (web_log_id, path)"
// Database version table
if needsTable "db_version" then
"CREATE TABLE db_version (id TEXT NOT NULL PRIMARY KEY)"
$"INSERT INTO db_version VALUES ('{Utils.currentDbVersion}')"
}
Sql.existingConnection conn
|> Sql.executeTransactionAsync
(sql
|> Seq.map (fun s ->
let parts = s.Split ' '
if parts[1].ToLowerInvariant () = "table" then
log.LogInformation $"Creating {parts[2]} table..."
s, [ [] ])
|> List.ofSeq)
|> Async.AwaitTask
|> Async.RunSynchronously
|> ignore
}
/// Set a specific database version
let setDbVersion version = backgroundTask {
let! _ =
Sql.existingConnection conn
|> Sql.query $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')"
|> Sql.executeNonQueryAsync
()
}
/// Do required data migration between versions
let migrate version = backgroundTask {
match version with
| Some "v2-rc2" -> ()
// Future versions will be inserted here
| Some _
| None ->
log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}"
do! setDbVersion Utils.currentDbVersion
}
interface IData with
member _.Category = PostgresCategoryData conn
member _.Page = PostgresPageData (conn, ser)
member _.Post = PostgresPostData (conn, ser)
member _.TagMap = PostgresTagMapData conn
member _.Theme = PostgresThemeData conn
member _.ThemeAsset = PostgresThemeAssetData conn
member _.Upload = PostgresUploadData conn
member _.WebLog = PostgresWebLogData (conn, ser)
member _.WebLogUser = PostgresWebLogUserData conn
member _.Serializer = ser
member _.StartUp () = backgroundTask {
do! ensureTables ()
let! version =
Sql.existingConnection conn
|> Sql.query "SELECT id FROM db_version"
|> Sql.executeAsync (fun row -> row.string "id")
|> tryHead
match version with
| Some v when v = Utils.currentDbVersion -> ()
| Some _
| None -> do! migrate version
}

View File

@ -18,6 +18,9 @@ module private RethinkHelpers =
/// The comment table
let Comment = "Comment"
/// The database version table
let DbVersion = "DbVersion"
/// The page table
let Page = "Page"
@ -43,7 +46,7 @@ module private RethinkHelpers =
let WebLogUser = "WebLogUser"
/// A list of all tables
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ]
let all = [ Category; Comment; DbVersion; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ]
/// Index names for indexes not on a data item's name
@ -188,6 +191,41 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
write; withRetryDefault; ignoreResult conn
}
/// Set a specific database version
let setDbVersion (version : string) = backgroundTask {
do! rethink {
withTable Table.DbVersion
delete
write; withRetryOnce; ignoreResult conn
}
do! rethink {
withTable Table.DbVersion
insert {| Id = version |}
write; withRetryOnce; ignoreResult conn
}
}
/// Migrate from v2-rc1 to v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2"
logStep "**IMPORTANT**"
logStep "See release notes about required backup/restoration for RethinkDB."
logStep "If there is an error immediately below this message, this is why."
logStep "Setting database version to v2-rc2"
do! setDbVersion "v2-rc2"
}
/// Migrate data between versions
let migrate version = backgroundTask {
match version with
| Some v when v = "v2-rc2" -> ()
| Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 ()
| Some _
| None ->
log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}"
do! setDbVersion Utils.currentDbVersion
}
/// The connection for this instance
member _.Conn = conn
@ -1079,7 +1117,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink {
withTable Table.WebLogUser
get userId
update [ nameof WebLogUser.empty.LastSeenOn, DateTime.UtcNow :> obj ]
update [ nameof WebLogUser.empty.LastSeenOn, Noda.now () :> obj ]
write; withRetryOnce; ignoreResult conn
}
| None -> ()
@ -1094,7 +1132,6 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
nameof user.LastName, user.LastName
nameof user.PreferredName, user.PreferredName
nameof user.PasswordHash, user.PasswordHash
nameof user.Salt, user.Salt
nameof user.Url, user.Url
nameof user.AccessLevel, user.AccessLevel
]
@ -1102,6 +1139,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
}
member _.Serializer =
Net.Converter.Serializer
member _.StartUp () = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then
@ -1114,6 +1154,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
log.LogInformation $"Creating table {tbl}..."
do! rethink { tableCreate tbl [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn }
if not (List.contains Table.DbVersion tables) then
// Version table added in v2-rc2; this will flag that migration to be run
do! rethink {
withTable Table.DbVersion
insert {| Id = "v2-rc1" |}
write; withRetryOnce; ignoreResult conn
}
do! ensureIndexes Table.Category [ nameof Category.empty.WebLogId ]
do! ensureIndexes Table.Comment [ nameof Comment.empty.PostId ]
do! ensureIndexes Table.Page [ nameof Page.empty.WebLogId; nameof Page.empty.AuthorId ]
@ -1122,4 +1170,13 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! ensureIndexes Table.Upload []
do! ensureIndexes Table.WebLog [ nameof WebLog.empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.empty.WebLogId ]
let! version = rethink<{| Id : string |} list> {
withTable Table.DbVersion
limit 1
result; withRetryOnce conn
}
match List.tryHead version with
| Some v when v.Id = "v2-rc2" -> ()
| it -> do! migrate (it |> Option.map (fun x -> x.Id))
}

View File

@ -5,6 +5,8 @@ module MyWebLog.Data.SQLite.Helpers
open System
open Microsoft.Data.Sqlite
open MyWebLog
open MyWebLog.Data
open NodaTime.Text
/// Run a command that returns a count
let count (cmd : SqliteCommand) = backgroundTask {
@ -12,23 +14,6 @@ let count (cmd : SqliteCommand) = backgroundTask {
return int (it :?> int64)
}
/// Get lists of items removed from and added to the given lists
let diffLists<'T, 'U when 'U : equality> oldItems newItems (f : 'T -> 'U) =
let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other))
List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems
/// Find meta items added and removed
let diffMetaItems (oldItems : MetaItem list) newItems =
diffLists oldItems newItems (fun item -> $"{item.Name}|{item.Value}")
/// Find the permalinks added and removed
let diffPermalinks oldLinks newLinks =
diffLists oldLinks newLinks Permalink.toString
/// Find the revisions added and removed
let diffRevisions oldRevs newRevs =
diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.Ticks}|{MarkupText.toString rev.Text}")
/// Create a list of items from the given data reader
let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) =
seq { while rdr.Read () do it rdr }
@ -47,6 +32,42 @@ let write (cmd : SqliteCommand) = backgroundTask {
()
}
/// Add a possibly-missing parameter, substituting null for None
let maybe<'T> (it : 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value
/// Create a value for a Duration
let durationParam =
DurationPattern.Roundtrip.Format
/// Create a value for an Instant
let instantParam =
InstantPattern.General.Format
/// Create an optional value for a Duration
let maybeDuration =
Option.map durationParam >> maybe
/// Create an optional value for an Instant
let maybeInstant =
Option.map instantParam >> maybe
/// Create the SQL and parameters for an IN clause
let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items : 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", (SqliteParameter ($"@%s{paramName}{idx}", valueFunc it) :: itemP))
(Seq.ofList items
|> Seq.map (fun it ->
$"%s{colNameAndPrefix} IN (@%s{paramName}0", [ SqliteParameter ($"@%s{paramName}0", valueFunc it) ])
|> Seq.head)
|> function sql, ps -> $"{sql})", ps
/// Functions to map domain items from a data reader
module Map =
@ -73,6 +94,26 @@ module Map =
/// Get a string value from a data reader
let getString col (rdr : SqliteDataReader) = rdr.GetString (rdr.GetOrdinal col)
/// Parse a Duration from the given value
let parseDuration value =
match DurationPattern.Roundtrip.Parse value with
| it when it.Success -> it.Value
| it -> raise it.Exception
/// Get a Duration value from a data reader
let getDuration col rdr =
getString col rdr |> parseDuration
/// Parse an Instant from the given value
let parseInstant value =
match InstantPattern.General.Parse value with
| it when it.Success -> it.Value
| it -> raise it.Exception
/// Get an Instant value from a data reader
let getInstant col rdr =
getString col rdr |> parseInstant
/// Get a timespan value from a data reader
let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col)
@ -96,6 +137,14 @@ module Map =
let tryString col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getString col rdr)
/// Get a possibly null Duration value from a data reader
let tryDuration col rdr =
tryString col rdr |> Option.map parseDuration
/// Get a possibly null Instant value from a data reader
let tryInstant col rdr =
tryString col rdr |> Option.map parseInstant
/// Get a possibly null timespan value from a data reader
let tryTimeSpan col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getTimeSpan col rdr)
@ -114,60 +163,36 @@ module Map =
}
/// Create a custom feed from the current row in the given data reader
let toCustomFeed rdr : CustomFeed =
let toCustomFeed ser rdr : CustomFeed =
{ Id = getString "id" rdr |> CustomFeedId
Source = getString "source" rdr |> CustomFeedSource.parse
Path = getString "path" rdr |> Permalink
Podcast =
if rdr.IsDBNull (rdr.GetOrdinal "title") then
None
else
Some {
Title = getString "title" rdr
Subtitle = tryString "subtitle" rdr
ItemsInFeed = getInt "items_in_feed" rdr
Summary = getString "summary" rdr
DisplayedAuthor = getString "displayed_author" rdr
Email = getString "email" rdr
ImageUrl = getString "image_url" rdr |> Permalink
AppleCategory = getString "apple_category" rdr
AppleSubcategory = tryString "apple_subcategory" rdr
Explicit = getString "explicit" rdr |> ExplicitRating.parse
DefaultMediaType = tryString "default_media_type" rdr
MediaBaseUrl = tryString "media_base_url" rdr
PodcastGuid = tryGuid "podcast_guid" rdr
FundingUrl = tryString "funding_url" rdr
FundingText = tryString "funding_text" rdr
Medium = tryString "medium" rdr |> Option.map PodcastMedium.parse
}
}
/// Create a meta item from the current row in the given data reader
let toMetaItem rdr : MetaItem =
{ Name = getString "name" rdr
Value = getString "value" rdr
Podcast = tryString "podcast" rdr |> Option.map (Utils.deserialize ser)
}
/// Create a permalink from the current row in the given data reader
let toPermalink rdr = getString "permalink" rdr |> Permalink
/// Create a page from the current row in the given data reader
let toPage rdr : Page =
let toPage ser rdr : Page =
{ Page.empty with
Id = getString "id" rdr |> PageId
WebLogId = getString "web_log_id" rdr |> WebLogId
AuthorId = getString "author_id" rdr |> WebLogUserId
Title = getString "title" rdr
Permalink = toPermalink rdr
PublishedOn = getDateTime "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr
PublishedOn = getInstant "published_on" rdr
UpdatedOn = getInstant "updated_on" rdr
IsInPageList = getBoolean "is_in_page_list" rdr
Template = tryString "template" rdr
Text = getString "page_text" rdr
Metadata = tryString "meta_items" rdr
|> Option.map (Utils.deserialize ser)
|> Option.defaultValue []
}
/// Create a post from the current row in the given data reader
let toPost rdr : Post =
let toPost ser rdr : Post =
{ Post.empty with
Id = getString "id" rdr |> PostId
WebLogId = getString "web_log_id" rdr |> WebLogId
@ -175,38 +200,19 @@ module Map =
Status = getString "status" rdr |> PostStatus.parse
Title = getString "title" rdr
Permalink = toPermalink rdr
PublishedOn = tryDateTime "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr
PublishedOn = tryInstant "published_on" rdr
UpdatedOn = getInstant "updated_on" rdr
Template = tryString "template" rdr
Text = getString "post_text" rdr
Episode =
match tryString "media" rdr with
| Some media ->
Some {
Media = media
Length = getLong "length" rdr
Duration = tryTimeSpan "duration" rdr
MediaType = tryString "media_type" rdr
ImageUrl = tryString "image_url" rdr
Subtitle = tryString "subtitle" rdr
Explicit = tryString "explicit" rdr |> Option.map ExplicitRating.parse
ChapterFile = tryString "chapter_file" rdr
ChapterType = tryString "chapter_type" rdr
TranscriptUrl = tryString "transcript_url" rdr
TranscriptType = tryString "transcript_type" rdr
TranscriptLang = tryString "transcript_lang" rdr
TranscriptCaptions = tryBoolean "transcript_captions" rdr
SeasonNumber = tryInt "season_number" rdr
SeasonDescription = tryString "season_description" rdr
EpisodeNumber = tryString "episode_number" rdr |> Option.map Double.Parse
EpisodeDescription = tryString "episode_description" rdr
}
| None -> None
Episode = tryString "episode" rdr |> Option.map (Utils.deserialize ser)
Metadata = tryString "meta_items" rdr
|> Option.map (Utils.deserialize ser)
|> Option.defaultValue []
}
/// Create a revision from the current row in the given data reader
let toRevision rdr : Revision =
{ AsOf = getDateTime "as_of" rdr
{ AsOf = getInstant "as_of" rdr
Text = getString "revision_text" rdr |> MarkupText.parse
}
@ -237,7 +243,7 @@ module Map =
else
[||]
{ Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr)
UpdatedOn = getDateTime "updated_on" rdr
UpdatedOn = getInstant "updated_on" rdr
Data = assetData
}
@ -260,7 +266,7 @@ module Map =
{ Id = getString "id" rdr |> UploadId
WebLogId = getString "web_log_id" rdr |> WebLogId
Path = getString "path" rdr |> Permalink
UpdatedOn = getDateTime "updated_on" rdr
UpdatedOn = getInstant "updated_on" rdr
Data = data
}
@ -297,16 +303,12 @@ module Map =
LastName = getString "last_name" rdr
PreferredName = getString "preferred_name" rdr
PasswordHash = getString "password_hash" rdr
Salt = getGuid "salt" rdr
Url = tryString "url" rdr
AccessLevel = getString "access_level" rdr |> AccessLevel.parse
CreatedOn = getDateTime "created_on" rdr
LastSeenOn = tryDateTime "last_seen_on" rdr
CreatedOn = getInstant "created_on" rdr
LastSeenOn = tryInstant "last_seen_on" rdr
}
/// Add a possibly-missing parameter, substituting null for None
let maybe<'T> (it : 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value
/// Add a web log ID parameter
let addWebLogId (cmd : SqliteCommand) webLogId =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore

View File

@ -21,12 +21,12 @@ type SQLiteCategoryData (conn : SqliteConnection) =
/// Add a category
let add cat = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO category (
cmd.CommandText <-
"INSERT INTO category (
id, web_log_id, name, slug, description, parent_id
) VALUES (
@id, @webLogId, @name, @slug, @description, @parentId
)"""
)"
addCategoryParameters cmd cat
let! _ = cmd.ExecuteNonQueryAsync ()
()
@ -68,24 +68,23 @@ type SQLiteCategoryData (conn : SqliteConnection) =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catSql, catParams =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map (fun cat -> cat.Id)
|> Seq.append (Seq.singleton it.Id)
|> List.ofSeq
|> inClause "AND pc.category_id" "catId" id
cmd.Parameters.Clear ()
addWebLogId cmd webLogId
cmd.CommandText <- """
cmd.Parameters.AddRange catParams
cmd.CommandText <- $"
SELECT COUNT(DISTINCT p.id)
FROM post p
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = 'Published'
AND pc.category_id IN ("""
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map (fun cat -> cat.Id)
|> Seq.append (Seq.singleton it.Id)
|> Seq.iteri (fun idx item ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@catId{idx}"
cmd.Parameters.AddWithValue ($"@catId{idx}", item) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
{catSql}"
let! postCount = count cmd
return it.Id, postCount
})
@ -133,19 +132,15 @@ type SQLiteCategoryData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map CategoryId.toString))
|> ignore
do! write cmd
// Delete the category off all posts where it is assigned
cmd.CommandText <- """
DELETE FROM post_category
// Delete the category off all posts where it is assigned, and the category itself
cmd.CommandText <-
"DELETE FROM post_category
WHERE category_id = @id
AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId)"""
AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId);
DELETE FROM category WHERE id = @id"
cmd.Parameters.Clear ()
let catIdParameter = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore
do! write cmd
// Delete the category itself
cmd.CommandText <- "DELETE FROM category WHERE id = @id"
cmd.Parameters.Clear ()
cmd.Parameters.Add catIdParameter |> ignore
let _ = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId)
addWebLogId cmd webLogId
do! write cmd
return if children = 0 then CategoryDeleted else ReassignedChildCategories
| None -> return CategoryNotFound
@ -160,14 +155,14 @@ type SQLiteCategoryData (conn : SqliteConnection) =
/// Update a category
let update cat = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE category
cmd.CommandText <-
"UPDATE category
SET name = @name,
slug = @slug,
description = @description,
parent_id = @parentId
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addCategoryParameters cmd cat
do! write cmd
}

View File

@ -4,9 +4,10 @@ open System.Threading.Tasks
open Microsoft.Data.Sqlite
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
/// SQLite myWebLog page data implementation
type SQLitePageData (conn : SqliteConnection) =
type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
@ -17,22 +18,15 @@ type SQLitePageData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString page.AuthorId)
cmd.Parameters.AddWithValue ("@title", page.Title)
cmd.Parameters.AddWithValue ("@permalink", Permalink.toString page.Permalink)
cmd.Parameters.AddWithValue ("@publishedOn", page.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", page.UpdatedOn)
cmd.Parameters.AddWithValue ("@publishedOn", instantParam page.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", instantParam page.UpdatedOn)
cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList)
cmd.Parameters.AddWithValue ("@template", maybe page.Template)
cmd.Parameters.AddWithValue ("@text", page.Text)
cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty page.Metadata then None
else Some (Utils.serialize ser page.Metadata)))
] |> ignore
/// Append meta items to a page
let appendPageMeta (page : Page) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT name, value FROM page_meta WHERE page_id = @id"
cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return { page with Metadata = toList Map.toMetaItem rdr }
}
/// Append revisions and permalinks to a page
let appendPageRevisionsAndPermalinks (page : Page) = backgroundTask {
use cmd = conn.CreateCommand ()
@ -48,41 +42,17 @@ type SQLitePageData (conn : SqliteConnection) =
return { page with Revisions = toList Map.toRevision rdr }
}
/// Return a page with no text (or meta items, prior permalinks, or revisions)
let pageWithoutTextOrMeta rdr =
{ Map.toPage rdr with Text = "" }
/// Shorthand for mapping a data reader to a page
let toPage =
Map.toPage ser
/// Update a page's metadata items
let updatePageMeta pageId oldItems newItems = backgroundTask {
let toDelete, toAdd = diffMetaItems oldItems newItems
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId)
cmd.Parameters.Add ("@name", SqliteType.Text)
cmd.Parameters.Add ("@value", SqliteType.Text)
] |> ignore
let runCmd (item : MetaItem) = backgroundTask {
cmd.Parameters["@name" ].Value <- item.Name
cmd.Parameters["@value"].Value <- item.Value
do! write cmd
}
cmd.CommandText <- "DELETE FROM page_meta WHERE page_id = @pageId AND name = @name AND value = @value"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO page_meta VALUES (@pageId, @name, @value)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Return a page with no text (or prior permalinks or revisions)
let pageWithoutText rdr =
{ toPage rdr with Text = "" }
/// Update a page's prior permalinks
let updatePagePermalinks pageId oldLinks newLinks = backgroundTask {
let toDelete, toAdd = diffPermalinks oldLinks newLinks
let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -108,7 +78,7 @@ type SQLitePageData (conn : SqliteConnection) =
/// Update a page's revisions
let updatePageRevisions pageId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = diffRevisions oldRevs newRevs
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -116,7 +86,7 @@ type SQLitePageData (conn : SqliteConnection) =
let runCmd withText rev = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId)
cmd.Parameters.AddWithValue ("@asOf", rev.AsOf)
cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf)
] |> ignore
if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore
do! write cmd
@ -139,17 +109,16 @@ type SQLitePageData (conn : SqliteConnection) =
let add page = backgroundTask {
use cmd = conn.CreateCommand ()
// The page itself
cmd.CommandText <- """
INSERT INTO page (
cmd.CommandText <-
"INSERT INTO page (
id, web_log_id, author_id, title, permalink, published_on, updated_on, is_in_page_list, template,
page_text
page_text, meta_items
) VALUES (
@id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @isInPageList, @template,
@text
)"""
@text, @metaItems
)"
addPageParameters cmd page
do! write cmd
do! updatePageMeta page.Id [] page.Metadata
do! updatePagePermalinks page.Id [] page.PriorPermalinks
do! updatePageRevisions page.Id [] page.Revisions
}
@ -160,7 +129,7 @@ type SQLitePageData (conn : SqliteConnection) =
cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId ORDER BY LOWER(title)"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList pageWithoutTextOrMeta rdr
return toList pageWithoutText rdr
}
/// Count all pages for the given web log
@ -174,11 +143,11 @@ type SQLitePageData (conn : SqliteConnection) =
/// Count all pages shown in the page list for the given web log
let countListed webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT COUNT(id)
cmd.CommandText <-
"SELECT COUNT(id)
FROM page
WHERE web_log_id = @webLogId
AND is_in_page_list = @isInPageList"""
AND is_in_page_list = @isInPageList"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore
return! count cmd
@ -190,11 +159,7 @@ type SQLitePageData (conn : SqliteConnection) =
cmd.CommandText <- "SELECT * FROM page WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
match Helpers.verifyWebLog<Page> webLogId (fun it -> it.WebLogId) Map.toPage rdr with
| Some page ->
let! page = appendPageMeta page
return Some page
| None -> return None
return Helpers.verifyWebLog<Page> webLogId (fun it -> it.WebLogId) (Map.toPage ser) rdr
}
/// Find a complete page by its ID
@ -211,11 +176,10 @@ type SQLitePageData (conn : SqliteConnection) =
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore
cmd.CommandText <- """
DELETE FROM page_revision WHERE page_id = @id;
cmd.CommandText <-
"DELETE FROM page_revision WHERE page_id = @id;
DELETE FROM page_permalink WHERE page_id = @id;
DELETE FROM page_meta WHERE page_id = @id;
DELETE FROM page WHERE id = @id"""
DELETE FROM page WHERE id = @id"
do! write cmd
return true
| None -> return false
@ -228,29 +192,21 @@ type SQLitePageData (conn : SqliteConnection) =
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! page = appendPageMeta (Map.toPage rdr)
return Some page
else
return None
return if rdr.Read () then Some (toPage rdr) else None
}
/// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks
cmd.CommandText <- $"
SELECT p.permalink
FROM page p
INNER JOIN page_permalink pp ON pp.page_id = p.id
WHERE p.web_log_id = @webLogId
AND pp.permalink IN ("""
permalinks
|> List.iteri (fun idx link ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@link{idx}"
cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
{linkSql}"
addWebLogId cmd webLogId
cmd.Parameters.AddRange linkParams
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toPermalink rdr) else None
}
@ -262,11 +218,8 @@ type SQLitePageData (conn : SqliteConnection) =
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! pages =
toList Map.toPage rdr
|> List.map (fun page -> backgroundTask {
let! page = appendPageMeta page
return! appendPageRevisionsAndPermalinks page
})
toList toPage rdr
|> List.map (fun page -> backgroundTask { return! appendPageRevisionsAndPermalinks page })
|> Task.WhenAll
return List.ofArray pages
}
@ -274,37 +227,33 @@ type SQLitePageData (conn : SqliteConnection) =
/// Get all listed pages for the given web log (without revisions, prior permalinks, or text)
let findListed webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT *
cmd.CommandText <-
"SELECT *
FROM page
WHERE web_log_id = @webLogId
AND is_in_page_list = @isInPageList
ORDER BY LOWER(title)"""
ORDER BY LOWER(title)"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! pages =
toList pageWithoutTextOrMeta rdr
|> List.map (fun page -> backgroundTask { return! appendPageMeta page })
|> Task.WhenAll
return List.ofArray pages
return toList pageWithoutText rdr
}
/// Get a page of pages for the given web log (without revisions, prior permalinks, or metadata)
let findPageOfPages webLogId pageNbr = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT *
cmd.CommandText <-
"SELECT *
FROM page
WHERE web_log_id = @webLogId
ORDER BY LOWER(title)
LIMIT @pageSize OFFSET @toSkip"""
LIMIT @pageSize OFFSET @toSkip"
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@pageSize", 26)
cmd.Parameters.AddWithValue ("@toSkip", (pageNbr - 1) * 25)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toPage rdr
return toList toPage rdr
}
/// Restore pages from a backup
@ -318,8 +267,8 @@ type SQLitePageData (conn : SqliteConnection) =
match! findFullById page.Id page.WebLogId with
| Some oldPage ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE page
cmd.CommandText <-
"UPDATE page
SET author_id = @authorId,
title = @title,
permalink = @permalink,
@ -327,12 +276,12 @@ type SQLitePageData (conn : SqliteConnection) =
updated_on = @updatedOn,
is_in_page_list = @isInPageList,
template = @template,
page_text = @text
page_text = @text,
meta_items = @metaItems
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addPageParameters cmd page
do! write cmd
do! updatePageMeta page.Id oldPage.Metadata page.Metadata
do! updatePagePermalinks page.Id oldPage.PriorPermalinks page.PriorPermalinks
do! updatePageRevisions page.Id oldPage.Revisions page.Revisions
return ()

View File

@ -1,13 +1,14 @@
namespace MyWebLog.Data.SQLite
open System
open System.Threading.Tasks
open Microsoft.Data.Sqlite
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
open NodaTime
/// SQLite myWebLog post data implementation
type SQLitePostData (conn : SqliteConnection) =
type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
@ -19,35 +20,19 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status)
cmd.Parameters.AddWithValue ("@title", post.Title)
cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink)
cmd.Parameters.AddWithValue ("@publishedOn", maybe post.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", post.UpdatedOn)
cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn)
cmd.Parameters.AddWithValue ("@template", maybe post.Template)
cmd.Parameters.AddWithValue ("@text", post.Text)
cmd.Parameters.AddWithValue ("@episode", maybe (if Option.isSome post.Episode then
Some (Utils.serialize ser post.Episode)
else None))
cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty post.Metadata then None
else Some (Utils.serialize ser post.Metadata)))
] |> ignore
/// Add parameters for episode INSERT or UPDATE statements
let addEpisodeParameters (cmd : SqliteCommand) (ep : Episode) =
[ cmd.Parameters.AddWithValue ("@media", ep.Media)
cmd.Parameters.AddWithValue ("@length", ep.Length)
cmd.Parameters.AddWithValue ("@duration", maybe ep.Duration)
cmd.Parameters.AddWithValue ("@mediaType", maybe ep.MediaType)
cmd.Parameters.AddWithValue ("@imageUrl", maybe ep.ImageUrl)
cmd.Parameters.AddWithValue ("@subtitle", maybe ep.Subtitle)
cmd.Parameters.AddWithValue ("@explicit", maybe (ep.Explicit |> Option.map ExplicitRating.toString))
cmd.Parameters.AddWithValue ("@chapterFile", maybe ep.ChapterFile)
cmd.Parameters.AddWithValue ("@chapterType", maybe ep.ChapterType)
cmd.Parameters.AddWithValue ("@transcriptUrl", maybe ep.TranscriptUrl)
cmd.Parameters.AddWithValue ("@transcriptType", maybe ep.TranscriptType)
cmd.Parameters.AddWithValue ("@transcriptLang", maybe ep.TranscriptLang)
cmd.Parameters.AddWithValue ("@transcriptCaptions", maybe ep.TranscriptCaptions)
cmd.Parameters.AddWithValue ("@seasonNumber", maybe ep.SeasonNumber)
cmd.Parameters.AddWithValue ("@seasonDescription", maybe ep.SeasonDescription)
cmd.Parameters.AddWithValue ("@episodeNumber", maybe (ep.EpisodeNumber |> Option.map string))
cmd.Parameters.AddWithValue ("@episodeDescription", maybe ep.EpisodeDescription)
] |> ignore
/// Append category IDs, tags, and meta items to a post
let appendPostCategoryTagAndMeta (post : Post) = backgroundTask {
/// Append category IDs and tags to a post
let appendPostCategoryAndTag (post : Post) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) |> ignore
@ -58,12 +43,7 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.CommandText <- "SELECT tag FROM post_tag WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync ()
let post = { post with Tags = toList (Map.getString "tag") rdr }
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT name, value FROM post_meta WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync ()
return { post with Metadata = toList Map.toMetaItem rdr }
return { post with Tags = toList (Map.getString "tag") rdr }
}
/// Append revisions and permalinks to a post
@ -82,7 +62,11 @@ type SQLitePostData (conn : SqliteConnection) =
}
/// The SELECT statement for a post that will include episode data, if it exists
let selectPost = "SELECT p.*, e.* FROM post p LEFT JOIN post_episode e ON e.post_id = p.id"
let selectPost = "SELECT p.* FROM post p"
/// Shorthand for mapping a data reader to a post
let toPost =
Map.toPost ser
/// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks)
let findPostById postId webLogId = backgroundTask {
@ -90,16 +74,16 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.CommandText <- $"{selectPost} WHERE p.id = @id"
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<Post> webLogId (fun p -> p.WebLogId) Map.toPost rdr
return Helpers.verifyWebLog<Post> webLogId (fun p -> p.WebLogId) toPost rdr
}
/// Return a post with no revisions, prior permalinks, or text
let postWithoutText rdr =
{ Map.toPost rdr with Text = "" }
{ toPost rdr with Text = "" }
/// Update a post's assigned categories
let updatePostCategories postId oldCats newCats = backgroundTask {
let toDelete, toAdd = diffLists oldCats newCats CategoryId.toString
let toDelete, toAdd = Utils.diffLists oldCats newCats CategoryId.toString
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -125,7 +109,7 @@ type SQLitePostData (conn : SqliteConnection) =
/// Update a post's assigned categories
let updatePostTags postId (oldTags : string list) newTags = backgroundTask {
let toDelete, toAdd = diffLists oldTags newTags id
let toDelete, toAdd = Utils.diffLists oldTags newTags id
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -149,89 +133,9 @@ type SQLitePostData (conn : SqliteConnection) =
|> ignore
}
/// Update an episode
let updatePostEpisode (post : Post) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(post_id) FROM post_episode WHERE post_id = @postId"
cmd.Parameters.AddWithValue ("@postId", PostId.toString post.Id) |> ignore
let! count = count cmd
if count = 1 then
match post.Episode with
| Some ep ->
cmd.CommandText <- """
UPDATE post_episode
SET media = @media,
length = @length,
duration = @duration,
media_type = @mediaType,
image_url = @imageUrl,
subtitle = @subtitle,
explicit = @explicit,
chapter_file = @chapterFile,
chapter_type = @chapterType,
transcript_url = @transcriptUrl,
transcript_type = @transcriptType,
transcript_lang = @transcriptLang,
transcript_captions = @transcriptCaptions,
season_number = @seasonNumber,
season_description = @seasonDescription,
episode_number = @episodeNumber,
episode_description = @episodeDescription
WHERE post_id = @postId"""
addEpisodeParameters cmd ep
do! write cmd
| None ->
cmd.CommandText <- "DELETE FROM post_episode WHERE post_id = @postId"
do! write cmd
else
match post.Episode with
| Some ep ->
cmd.CommandText <- """
INSERT INTO post_episode (
post_id, media, length, duration, media_type, image_url, subtitle, explicit, chapter_file,
chapter_type, transcript_url, transcript_type, transcript_lang, transcript_captions,
season_number, season_description, episode_number, episode_description
) VALUES (
@postId, @media, @length, @duration, @mediaType, @imageUrl, @subtitle, @explicit, @chapterFile,
@chapterType, @transcriptUrl, @transcriptType, @transcriptLang, @transcriptCaptions,
@seasonNumber, @seasonDescription, @episodeNumber, @episodeDescription
)"""
addEpisodeParameters cmd ep
do! write cmd
| None -> ()
}
/// Update a post's metadata items
let updatePostMeta postId oldItems newItems = backgroundTask {
let toDelete, toAdd = diffMetaItems oldItems newItems
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
use cmd = conn.CreateCommand ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.Add ("@name", SqliteType.Text)
cmd.Parameters.Add ("@value", SqliteType.Text)
] |> ignore
let runCmd (item : MetaItem) = backgroundTask {
cmd.Parameters["@name" ].Value <- item.Name
cmd.Parameters["@value"].Value <- item.Value
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_meta WHERE post_id = @postId AND name = @name AND value = @value"
toDelete
|> List.map runCmd
|> Task.WhenAll
|> ignore
cmd.CommandText <- "INSERT INTO post_meta VALUES (@postId, @name, @value)"
toAdd
|> List.map runCmd
|> Task.WhenAll
|> ignore
}
/// Update a post's prior permalinks
let updatePostPermalinks postId oldLinks newLinks = backgroundTask {
let toDelete, toAdd = diffPermalinks oldLinks newLinks
let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -257,7 +161,7 @@ type SQLitePostData (conn : SqliteConnection) =
/// Update a post's revisions
let updatePostRevisions postId oldRevs newRevs = backgroundTask {
let toDelete, toAdd = diffRevisions oldRevs newRevs
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
if List.isEmpty toDelete && List.isEmpty toAdd then
return ()
else
@ -265,7 +169,7 @@ type SQLitePostData (conn : SqliteConnection) =
let runCmd withText rev = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.AddWithValue ("@asOf", rev.AsOf)
cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf)
] |> ignore
if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore
do! write cmd
@ -287,18 +191,18 @@ type SQLitePostData (conn : SqliteConnection) =
/// Add a post
let add post = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO post (
id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text
cmd.CommandText <-
"INSERT INTO post (
id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text,
episode, meta_items
) VALUES (
@id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text
)"""
@id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text,
@episode, @metaItems
)"
addPostParameters cmd post
do! write cmd
do! updatePostCategories post.Id [] post.CategoryIds
do! updatePostTags post.Id [] post.Tags
do! updatePostEpisode post
do! updatePostMeta post.Id [] post.Metadata
do! updatePostPermalinks post.Id [] post.PriorPermalinks
do! updatePostRevisions post.Id [] post.Revisions
}
@ -316,7 +220,7 @@ type SQLitePostData (conn : SqliteConnection) =
let findById postId webLogId = backgroundTask {
match! findPostById postId webLogId with
| Some post ->
let! post = appendPostCategoryTagAndMeta post
let! post = appendPostCategoryAndTag post
return Some post
| None -> return None
}
@ -329,7 +233,7 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (Map.toPost rdr)
let! post = appendPostCategoryAndTag (toPost rdr)
return Some post
else
return None
@ -350,14 +254,13 @@ type SQLitePostData (conn : SqliteConnection) =
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
cmd.CommandText <- """
DELETE FROM post_revision WHERE post_id = @id;
cmd.CommandText <-
"DELETE FROM post_revision WHERE post_id = @id;
DELETE FROM post_permalink WHERE post_id = @id;
DELETE FROM post_meta WHERE post_id = @id;
DELETE FROM post_episode WHERE post_id = @id;
DELETE FROM post_tag WHERE post_id = @id;
DELETE FROM post_category WHERE post_id = @id;
DELETE FROM post WHERE id = @id"""
DELETE FROM post_comment WHERE post_id = @id;
DELETE FROM post WHERE id = @id"
do! write cmd
return true
| None -> return false
@ -366,19 +269,15 @@ type SQLitePostData (conn : SqliteConnection) =
/// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks
cmd.CommandText <- $"
SELECT p.permalink
FROM post p
INNER JOIN post_permalink pp ON pp.post_id = p.id
WHERE p.web_log_id = @webLogId
AND pp.permalink IN ("""
permalinks
|> List.iteri (fun idx link ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@link{idx}"
cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
{linkSql}"
addWebLogId cmd webLogId
cmd.Parameters.AddRange linkParams
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toPermalink rdr) else None
}
@ -390,9 +289,9 @@ type SQLitePostData (conn : SqliteConnection) =
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
toList toPost rdr
|> List.map (fun post -> backgroundTask {
let! post = appendPostCategoryTagAndMeta post
let! post = appendPostCategoryAndTag post
return! appendPostRevisionsAndPermalinks post
})
|> Task.WhenAll
@ -402,27 +301,22 @@ type SQLitePostData (conn : SqliteConnection) =
/// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks)
let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
let catSql, catParams = inClause "AND pc.category_id" "catId" CategoryId.toString categoryIds
cmd.CommandText <- $"
{selectPost}
INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND pc.category_id IN ("""
categoryIds
|> List.iteri (fun idx catId ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@catId{idx}"
cmd.Parameters.AddWithValue ($"@catId{idx}", CategoryId.toString catId) |> ignore)
cmd.CommandText <-
$"""{cmd.CommandText})
{catSql}
ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
cmd.Parameters.AddRange catParams
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll
return List.ofArray posts
}
@ -430,16 +324,16 @@ type SQLitePostData (conn : SqliteConnection) =
/// Get a page of posts for the given web log (excludes text, revisions, and prior permalinks)
let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
cmd.CommandText <- $"
{selectPost}
WHERE p.web_log_id = @webLogId
ORDER BY p.published_on DESC NULLS FIRST, p.updated_on
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList postWithoutText rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
|> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll
return List.ofArray posts
}
@ -447,18 +341,18 @@ type SQLitePostData (conn : SqliteConnection) =
/// Get a page of published posts for the given web log (excludes revisions and prior permalinks)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
cmd.CommandText <- $"
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll
return List.ofArray posts
}
@ -466,60 +360,60 @@ type SQLitePostData (conn : SqliteConnection) =
/// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
cmd.CommandText <- $"
{selectPost}
INNER JOIN post_tag pt ON pt.post_id = p.id
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND pt.tag = @tag
ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@tag", tag)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! posts =
toList Map.toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post })
toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll
return List.ofArray posts
}
/// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn : DateTime) = backgroundTask {
let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"""
cmd.CommandText <- $"
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND p.published_on < @publishedOn
ORDER BY p.published_on DESC
LIMIT 1"""
LIMIT 1"
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@publishedOn", publishedOn)
cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn)
] |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
let! older = backgroundTask {
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr)
let! post = appendPostCategoryAndTag (postWithoutText rdr)
return Some post
else
return None
}
do! rdr.CloseAsync ()
cmd.CommandText <- $"""
cmd.CommandText <- $"
{selectPost}
WHERE p.web_log_id = @webLogId
AND p.status = @status
AND p.published_on > @publishedOn
ORDER BY p.published_on
LIMIT 1"""
LIMIT 1"
use! rdr = cmd.ExecuteReaderAsync ()
let! newer = backgroundTask {
if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr)
let! post = appendPostCategoryAndTag (postWithoutText rdr)
return Some post
else
return None
@ -538,8 +432,8 @@ type SQLitePostData (conn : SqliteConnection) =
match! findFullById post.Id post.WebLogId with
| Some oldPost ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE post
cmd.CommandText <-
"UPDATE post
SET author_id = @authorId,
status = @status,
title = @title,
@ -547,15 +441,15 @@ type SQLitePostData (conn : SqliteConnection) =
published_on = @publishedOn,
updated_on = @updatedOn,
template = @template,
post_text = @text
post_text = @text,
episode = @episode,
meta_items = @metaItems
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addPostParameters cmd post
do! write cmd
do! updatePostCategories post.Id oldPost.CategoryIds post.CategoryIds
do! updatePostTags post.Id oldPost.Tags post.Tags
do! updatePostEpisode post
do! updatePostMeta post.Id oldPost.Metadata post.Metadata
do! updatePostPermalinks post.Id oldPost.PriorPermalinks post.PriorPermalinks
do! updatePostRevisions post.Id oldPost.Revisions post.Revisions
| None -> return ()

View File

@ -50,18 +50,14 @@ type SQLiteTagMapData (conn : SqliteConnection) =
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags (tags : string list) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
let mapSql, mapParams = inClause "AND tag" "tag" id tags
cmd.CommandText <- $"
SELECT *
FROM tag_map
WHERE web_log_id = @webLogId
AND tag IN ("""
tags
|> List.iteri (fun idx tag ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@tag{idx}"
cmd.Parameters.AddWithValue ($"@tag{idx}", tag) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
{mapSql}"
addWebLogId cmd webLogId
cmd.Parameters.AddRange mapParams
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toTagMap rdr
}
@ -71,19 +67,19 @@ type SQLiteTagMapData (conn : SqliteConnection) =
use cmd = conn.CreateCommand ()
match! findById tagMap.Id tagMap.WebLogId with
| Some _ ->
cmd.CommandText <- """
UPDATE tag_map
cmd.CommandText <-
"UPDATE tag_map
SET tag = @tag,
url_value = @urlValue
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
| None ->
cmd.CommandText <- """
INSERT INTO tag_map (
cmd.CommandText <-
"INSERT INTO tag_map (
id, web_log_id, tag, url_value
) VALUES (
@id, @webLogId, @tag, @urlValue
)"""
)"
addWebLogId cmd tagMap.WebLogId
[ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id)
cmd.Parameters.AddWithValue ("@tag", tagMap.Tag)

View File

@ -17,13 +17,13 @@ type SQLiteThemeData (conn : SqliteConnection) =
do! rdr.CloseAsync ()
cmd.CommandText <- "SELECT name, theme_id FROM theme_template WHERE theme_id <> 'admin' ORDER BY name"
use! rdr = cmd.ExecuteReaderAsync ()
let mutable templates = []
while rdr.Read () do
templates <- (ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr) :: templates
let templates =
seq { while rdr.Read () do ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr }
|> List.ofSeq
return
themes
|> List.map (fun t ->
{ t with Templates = templates |> List.filter (fun tt -> fst tt = t.Id) |> List.map snd })
{ t with Templates = templates |> List.filter (fun (themeId, _) -> themeId = t.Id) |> List.map snd })
}
/// Does a given theme exist?
@ -67,10 +67,10 @@ type SQLiteThemeData (conn : SqliteConnection) =
match! findByIdWithoutText themeId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
DELETE FROM theme_asset WHERE theme_id = @id;
cmd.CommandText <-
"DELETE FROM theme_asset WHERE theme_id = @id;
DELETE FROM theme_template WHERE theme_id = @id;
DELETE FROM theme WHERE id = @id"""
DELETE FROM theme WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore
do! write cmd
return true
@ -92,7 +92,7 @@ type SQLiteThemeData (conn : SqliteConnection) =
do! write cmd
let toDelete, toAdd =
diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue [])
Utils.diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue [])
theme.Templates (fun t -> t.Name)
let toUpdate =
theme.Templates
@ -208,20 +208,20 @@ type SQLiteThemeAssetData (conn : SqliteConnection) =
use cmd = conn.CreateCommand ()
cmd.CommandText <-
if exists = 1 then
"""UPDATE theme_asset
"UPDATE theme_asset
SET updated_on = @updatedOn,
data = ZEROBLOB(@dataLength)
WHERE theme_id = @themeId
AND path = @path"""
AND path = @path"
else
"""INSERT INTO theme_asset (
"INSERT INTO theme_asset (
theme_id, path, updated_on, data
) VALUES (
@themeId, @path, @updatedOn, ZEROBLOB(@dataLength)
)"""
)"
[ cmd.Parameters.AddWithValue ("@themeId", themeId)
cmd.Parameters.AddWithValue ("@path", path)
cmd.Parameters.AddWithValue ("@updatedOn", asset.UpdatedOn)
cmd.Parameters.AddWithValue ("@updatedOn", instantParam asset.UpdatedOn)
cmd.Parameters.AddWithValue ("@dataLength", asset.Data.Length)
] |> ignore
do! write cmd

View File

@ -13,19 +13,19 @@ type SQLiteUploadData (conn : SqliteConnection) =
[ cmd.Parameters.AddWithValue ("@id", UploadId.toString upload.Id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString upload.WebLogId)
cmd.Parameters.AddWithValue ("@path", Permalink.toString upload.Path)
cmd.Parameters.AddWithValue ("@updatedOn", upload.UpdatedOn)
cmd.Parameters.AddWithValue ("@updatedOn", instantParam upload.UpdatedOn)
cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length)
] |> ignore
/// Save an uploaded file
let add upload = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO upload (
cmd.CommandText <-
"INSERT INTO upload (
id, web_log_id, path, updated_on, data
) VALUES (
@id, @webLogId, @path, @updatedOn, ZEROBLOB(@dataLength)
)"""
)"
addUploadParameters cmd upload
do! write cmd
@ -40,11 +40,11 @@ type SQLiteUploadData (conn : SqliteConnection) =
/// Delete an uploaded file by its ID
let delete uploadId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT id, web_log_id, path, updated_on
cmd.CommandText <-
"SELECT id, web_log_id, path, updated_on
FROM upload
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@id", UploadId.toString uploadId) |> ignore
let! rdr = cmd.ExecuteReaderAsync ()

View File

@ -4,12 +4,13 @@ open System.Threading.Tasks
open Microsoft.Data.Sqlite
open MyWebLog
open MyWebLog.Data
open Newtonsoft.Json
// The web log podcast insert loop is not statically compilable; this is OK
#nowarn "3511"
/// SQLite myWebLog web log data implementation
type SQLiteWebLogData (conn : SqliteConnection) =
type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS
@ -45,40 +46,22 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId)
cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source)
cmd.Parameters.AddWithValue ("@path", Permalink.toString feed.Path)
cmd.Parameters.AddWithValue ("@podcast", maybe (if Option.isSome feed.Podcast then
Some (Utils.serialize ser feed.Podcast)
else None))
] |> ignore
/// Add parameters for podcast INSERT or UPDATE statements
let addPodcastParameters (cmd : SqliteCommand) feedId (podcast : PodcastOptions) =
[ cmd.Parameters.AddWithValue ("@feedId", CustomFeedId.toString feedId)
cmd.Parameters.AddWithValue ("@title", podcast.Title)
cmd.Parameters.AddWithValue ("@subtitle", maybe podcast.Subtitle)
cmd.Parameters.AddWithValue ("@itemsInFeed", podcast.ItemsInFeed)
cmd.Parameters.AddWithValue ("@summary", podcast.Summary)
cmd.Parameters.AddWithValue ("@displayedAuthor", podcast.DisplayedAuthor)
cmd.Parameters.AddWithValue ("@email", podcast.Email)
cmd.Parameters.AddWithValue ("@imageUrl", Permalink.toString podcast.ImageUrl)
cmd.Parameters.AddWithValue ("@appleCategory", podcast.AppleCategory)
cmd.Parameters.AddWithValue ("@appleSubcategory", maybe podcast.AppleSubcategory)
cmd.Parameters.AddWithValue ("@explicit", ExplicitRating.toString podcast.Explicit)
cmd.Parameters.AddWithValue ("@defaultMediaType", maybe podcast.DefaultMediaType)
cmd.Parameters.AddWithValue ("@mediaBaseUrl", maybe podcast.MediaBaseUrl)
cmd.Parameters.AddWithValue ("@podcastGuid", maybe podcast.PodcastGuid)
cmd.Parameters.AddWithValue ("@fundingUrl", maybe podcast.FundingUrl)
cmd.Parameters.AddWithValue ("@fundingText", maybe podcast.FundingText)
cmd.Parameters.AddWithValue ("@medium", maybe (podcast.Medium |> Option.map PodcastMedium.toString))
] |> ignore
/// Shorthand to map a data reader to a custom feed
let toCustomFeed =
Map.toCustomFeed ser
/// Get the current custom feeds for a web log
let getCustomFeeds (webLog : WebLog) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
SELECT f.*, p.*
FROM web_log_feed f
LEFT JOIN web_log_feed_podcast p ON p.feed_id = f.id
WHERE f.web_log_id = @webLogId"""
cmd.CommandText <- "SELECT * FROM web_log_feed WHERE web_log_id = @webLogId"
addWebLogId cmd webLog.Id
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toCustomFeed rdr
return toList toCustomFeed rdr
}
/// Append custom feeds to a web log
@ -87,27 +70,10 @@ type SQLiteWebLogData (conn : SqliteConnection) =
return { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
}
/// Add a podcast to a custom feed
let addPodcast feedId (podcast : PodcastOptions) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log_feed_podcast (
feed_id, title, subtitle, items_in_feed, summary, displayed_author, email, image_url,
apple_category, apple_subcategory, explicit, default_media_type, media_base_url, podcast_guid,
funding_url, funding_text, medium
) VALUES (
@feedId, @title, @subtitle, @itemsInFeed, @summary, @displayedAuthor, @email, @imageUrl,
@appleCategory, @appleSubcategory, @explicit, @defaultMediaType, @mediaBaseUrl, @podcastGuid,
@fundingUrl, @fundingText, @medium
)"""
addPodcastParameters cmd feedId podcast
do! write cmd
}
/// Update the custom feeds for a web log
let updateCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog
let toDelete, toAdd = diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}")
let toDelete, toAdd = Utils.diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}")
let toId (feed : CustomFeed) = feed.Id
let toUpdate =
webLog.Rss.CustomFeeds
@ -117,9 +83,7 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.Add ("@id", SqliteType.Text) |> ignore
toDelete
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
DELETE FROM web_log_feed_podcast WHERE feed_id = @id;
DELETE FROM web_log_feed WHERE id = @id"""
cmd.CommandText <- "DELETE FROM web_log_feed WHERE id = @id"
cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id
do! write cmd
})
@ -128,68 +92,30 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.Clear ()
toAdd
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
INSERT INTO web_log_feed (
id, web_log_id, source, path
cmd.CommandText <-
"INSERT INTO web_log_feed (
id, web_log_id, source, path, podcast
) VALUES (
@id, @webLogId, @source, @path
)"""
@id, @webLogId, @source, @path, @podcast
)"
cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it
do! write cmd
match it.Podcast with
| Some podcast -> do! addPodcast it.Id podcast
| None -> ()
})
|> Task.WhenAll
|> ignore
toUpdate
|> List.map (fun it -> backgroundTask {
cmd.CommandText <- """
UPDATE web_log_feed
cmd.CommandText <-
"UPDATE web_log_feed
SET source = @source,
path = @path
path = @path,
podcast = @podcast
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it
do! write cmd
let hadPodcast = Option.isSome (feeds |> List.find (fun f -> f.Id = it.Id)).Podcast
match it.Podcast with
| Some podcast ->
if hadPodcast then
cmd.CommandText <- """
UPDATE web_log_feed_podcast
SET title = @title,
subtitle = @subtitle,
items_in_feed = @itemsInFeed,
summary = @summary,
displayed_author = @displayedAuthor,
email = @email,
image_url = @imageUrl,
apple_category = @appleCategory,
apple_subcategory = @appleSubcategory,
explicit = @explicit,
default_media_type = @defaultMediaType,
media_base_url = @mediaBaseUrl,
podcast_guid = @podcastGuid,
funding_url = @fundingUrl,
funding_text = @fundingText,
medium = @medium
WHERE feed_id = @feedId"""
cmd.Parameters.Clear ()
addPodcastParameters cmd it.Id podcast
do! write cmd
else
do! addPodcast it.Id podcast
| None ->
if hadPodcast then
cmd.CommandText <- "DELETE FROM web_log_feed_podcast WHERE feed_id = @id"
cmd.Parameters.Clear ()
cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString it.Id) |> ignore
do! write cmd
else
()
})
|> Task.WhenAll
|> ignore
@ -200,14 +126,14 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Add a web log
let add webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log (
cmd.CommandText <-
"INSERT INTO web_log (
id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx,
uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright
) VALUES (
@id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx,
@uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright
)"""
)"
addWebLogParameters cmd webLog
do! write cmd
do! updateCustomFeeds webLog
@ -232,26 +158,22 @@ type SQLiteWebLogData (conn : SqliteConnection) =
let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)"
let postSubQuery = subQuery "post"
let pageSubQuery = subQuery "page"
cmd.CommandText <- $"""
cmd.CommandText <- $"
DELETE FROM post_comment WHERE post_id IN {postSubQuery};
DELETE FROM post_revision WHERE post_id IN {postSubQuery};
DELETE FROM post_permalink WHERE post_id IN {postSubQuery};
DELETE FROM post_episode WHERE post_id IN {postSubQuery};
DELETE FROM post_tag WHERE post_id IN {postSubQuery};
DELETE FROM post_category WHERE post_id IN {postSubQuery};
DELETE FROM post_meta WHERE post_id IN {postSubQuery};
DELETE FROM post WHERE web_log_id = @webLogId;
DELETE FROM page_revision WHERE page_id IN {pageSubQuery};
DELETE FROM page_permalink WHERE page_id IN {pageSubQuery};
DELETE FROM page_meta WHERE page_id IN {pageSubQuery};
DELETE FROM page WHERE web_log_id = @webLogId;
DELETE FROM category WHERE web_log_id = @webLogId;
DELETE FROM tag_map WHERE web_log_id = @webLogId;
DELETE FROM upload WHERE web_log_id = @webLogId;
DELETE FROM web_log_user WHERE web_log_id = @webLogId;
DELETE FROM web_log_feed_podcast WHERE feed_id IN {subQuery "web_log_feed"};
DELETE FROM web_log_feed WHERE web_log_id = @webLogId;
DELETE FROM web_log WHERE id = @webLogId"""
DELETE FROM web_log WHERE id = @webLogId"
do! write cmd
}
@ -284,8 +206,8 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Update settings for a web log
let updateSettings webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log
cmd.CommandText <-
"UPDATE web_log
SET name = @name,
slug = @slug,
subtitle = @subtitle,
@ -302,7 +224,7 @@ type SQLiteWebLogData (conn : SqliteConnection) =
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @id"""
WHERE id = @id"
addWebLogParameters cmd webLog
do! write cmd
}
@ -310,15 +232,15 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Update RSS options for a web log
let updateRssOptions webLog = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log
cmd.CommandText <-
"UPDATE web_log
SET is_feed_enabled = @isFeedEnabled,
feed_name = @feedName,
items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled,
copyright = @copyright
WHERE id = @id"""
WHERE id = @id"
addWebLogRssParameters cmd webLog
cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore
do! write cmd

View File

@ -1,6 +1,5 @@
namespace MyWebLog.Data.SQLite
open System
open Microsoft.Data.Sqlite
open MyWebLog
open MyWebLog.Data
@ -19,11 +18,10 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@lastName", user.LastName)
cmd.Parameters.AddWithValue ("@preferredName", user.PreferredName)
cmd.Parameters.AddWithValue ("@passwordHash", user.PasswordHash)
cmd.Parameters.AddWithValue ("@salt", user.Salt)
cmd.Parameters.AddWithValue ("@url", maybe user.Url)
cmd.Parameters.AddWithValue ("@accessLevel", AccessLevel.toString user.AccessLevel)
cmd.Parameters.AddWithValue ("@createdOn", user.CreatedOn)
cmd.Parameters.AddWithValue ("@lastSeenOn", maybe user.LastSeenOn)
cmd.Parameters.AddWithValue ("@createdOn", instantParam user.CreatedOn)
cmd.Parameters.AddWithValue ("@lastSeenOn", maybeInstant user.LastSeenOn)
] |> ignore
// IMPLEMENTATION FUNCTIONS
@ -31,14 +29,14 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
/// Add a user
let add user = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
INSERT INTO web_log_user (
id, web_log_id, email, first_name, last_name, preferred_name, password_hash, salt, url, access_level,
cmd.CommandText <-
"INSERT INTO web_log_user (
id, web_log_id, email, first_name, last_name, preferred_name, password_hash, url, access_level,
created_on, last_seen_on
) VALUES (
@id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @salt, @url, @accessLevel,
@id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @url, @accessLevel,
@createdOn, @lastSeenOn
)"""
)"
addWebLogUserParameters cmd user
do! write cmd
}
@ -93,14 +91,10 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
/// Find the names of users by their IDs for the given web log
let findNames webLogId userIds = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND id IN ("
userIds
|> List.iteri (fun idx userId ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@id{idx}"
cmd.Parameters.AddWithValue ($"@id{idx}", WebLogUserId.toString userId) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
let nameSql, nameParams = inClause "AND id" "id" WebLogUserId.toString userIds
cmd.CommandText <- $"SELECT * FROM web_log_user WHERE web_log_id = @webLogId {nameSql}"
addWebLogId cmd webLogId
cmd.Parameters.AddRange nameParams
use! rdr = cmd.ExecuteReaderAsync ()
return
toList Map.toWebLogUser rdr
@ -116,14 +110,14 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
/// Set a user's last seen date/time to now
let setLastSeen userId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log_user
cmd.CommandText <-
"UPDATE web_log_user
SET last_seen_on = @lastSeenOn
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId)
cmd.Parameters.AddWithValue ("@lastSeenOn", DateTime.UtcNow)
cmd.Parameters.AddWithValue ("@lastSeenOn", instantParam (Noda.now ()))
] |> ignore
let! _ = cmd.ExecuteNonQueryAsync ()
()
@ -132,20 +126,19 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
/// Update a user
let update user = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- """
UPDATE web_log_user
cmd.CommandText <-
"UPDATE web_log_user
SET email = @email,
first_name = @firstName,
last_name = @lastName,
preferred_name = @preferredName,
password_hash = @passwordHash,
salt = @salt,
url = @url,
access_level = @accessLevel,
created_on = @createdOn,
last_seen_on = @lastSeenOn
WHERE id = @id
AND web_log_id = @webLogId"""
AND web_log_id = @webLogId"
addWebLogUserParameters cmd user
do! write cmd
}

View File

@ -2,90 +2,53 @@ namespace MyWebLog.Data
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data.SQLite
open Newtonsoft.Json
open NodaTime
/// SQLite myWebLog data implementation
type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>, ser : JsonSerializer) =
let ensureTables () = backgroundTask {
/// Determine if the given table exists
let tableExists (table : string) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table"
cmd.Parameters.AddWithValue ("@table", table) |> ignore
let! count = count cmd
return count = 1
let! tables = backgroundTask {
cmd.CommandText <- "SELECT name FROM sqlite_master WHERE type = 'table'"
let! rdr = cmd.ExecuteReaderAsync ()
let mutable tableList = []
while rdr.Read() do
tableList <- Map.getString "name" rdr :: tableList
do! rdr.CloseAsync ()
return tableList
}
/// The connection for this instance
member _.Conn = conn
/// Make a SQLite connection ready to execute commends
static member setUpConnection (conn : SqliteConnection) = backgroundTask {
do! conn.OpenAsync ()
use cmd = conn.CreateCommand ()
cmd.CommandText <- "PRAGMA foreign_keys = TRUE"
let! _ = cmd.ExecuteNonQueryAsync ()
()
}
interface IData with
member _.Category = SQLiteCategoryData conn
member _.Page = SQLitePageData conn
member _.Post = SQLitePostData conn
member _.TagMap = SQLiteTagMapData conn
member _.Theme = SQLiteThemeData conn
member _.ThemeAsset = SQLiteThemeAssetData conn
member _.Upload = SQLiteUploadData conn
member _.WebLog = SQLiteWebLogData conn
member _.WebLogUser = SQLiteWebLogUserData conn
member _.StartUp () = backgroundTask {
use cmd = conn.CreateCommand ()
let needsTable table =
not (List.contains table tables)
seq {
// Theme tables
match! tableExists "theme" with
| true -> ()
| false ->
log.LogInformation "Creating theme table..."
cmd.CommandText <- """
CREATE TABLE theme (
if needsTable "theme" then
"CREATE TABLE theme (
id TEXT PRIMARY KEY,
name TEXT NOT NULL,
version TEXT NOT NULL)"""
do! write cmd
match! tableExists "theme_template" with
| true -> ()
| false ->
log.LogInformation "Creating theme_template table..."
cmd.CommandText <- """
CREATE TABLE theme_template (
version TEXT NOT NULL)"
if needsTable "theme_template" then
"CREATE TABLE theme_template (
theme_id TEXT NOT NULL REFERENCES theme (id),
name TEXT NOT NULL,
template TEXT NOT NULL,
PRIMARY KEY (theme_id, name))"""
do! write cmd
match! tableExists "theme_asset" with
| true -> ()
| false ->
log.LogInformation "Creating theme_asset table..."
cmd.CommandText <- """
CREATE TABLE theme_asset (
PRIMARY KEY (theme_id, name))"
if needsTable "theme_asset" then
"CREATE TABLE theme_asset (
theme_id TEXT NOT NULL REFERENCES theme (id),
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))"""
do! write cmd
PRIMARY KEY (theme_id, path))"
// Web log tables
match! tableExists "web_log" with
| true -> ()
| false ->
log.LogInformation "Creating web_log table..."
cmd.CommandText <- """
CREATE TABLE web_log (
if needsTable "web_log" then
"CREATE TABLE web_log (
id TEXT PRIMARY KEY,
name TEXT NOT NULL,
slug TEXT NOT NULL,
@ -103,68 +66,30 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
is_category_enabled INTEGER NOT NULL DEFAULT 0,
is_tag_enabled INTEGER NOT NULL DEFAULT 0,
copyright TEXT);
CREATE INDEX web_log_theme_idx ON web_log (theme_id)"""
do! write cmd
match! tableExists "web_log_feed" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_feed table..."
cmd.CommandText <- """
CREATE TABLE web_log_feed (
CREATE INDEX web_log_theme_idx ON web_log (theme_id)"
if needsTable "web_log_feed" then
"CREATE TABLE web_log_feed (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
source TEXT NOT NULL,
path TEXT NOT NULL);
CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)"""
do! write cmd
match! tableExists "web_log_feed_podcast" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_feed_podcast table..."
cmd.CommandText <- """
CREATE TABLE web_log_feed_podcast (
feed_id TEXT PRIMARY KEY REFERENCES web_log_feed (id),
title TEXT NOT NULL,
subtitle TEXT,
items_in_feed INTEGER NOT NULL,
summary TEXT NOT NULL,
displayed_author TEXT NOT NULL,
email TEXT NOT NULL,
image_url TEXT NOT NULL,
apple_category TEXT NOT NULL,
apple_subcategory TEXT,
explicit TEXT NOT NULL,
default_media_type TEXT,
media_base_url TEXT,
podcast_guid TEXT,
funding_url TEXT,
funding_text TEXT,
medium TEXT)"""
do! write cmd
path TEXT NOT NULL,
podcast TEXT);
CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)"
// Category table
match! tableExists "category" with
| true -> ()
| false ->
log.LogInformation "Creating category table..."
cmd.CommandText <- """
CREATE TABLE category (
if needsTable "category" then
"CREATE TABLE category (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
name TEXT NOT NULL,
slug TEXT NOT NULL,
description TEXT,
parent_id TEXT);
CREATE INDEX category_web_log_idx ON category (web_log_id)"""
do! write cmd
CREATE INDEX category_web_log_idx ON category (web_log_id)"
// Web log user table
match! tableExists "web_log_user" with
| true -> ()
| false ->
log.LogInformation "Creating web_log_user table..."
cmd.CommandText <- """
CREATE TABLE web_log_user (
if needsTable "web_log_user" then
"CREATE TABLE web_log_user (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
email TEXT NOT NULL,
@ -172,22 +97,16 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
last_name TEXT NOT NULL,
preferred_name TEXT NOT NULL,
password_hash TEXT NOT NULL,
salt TEXT NOT NULL,
url TEXT,
access_level TEXT NOT NULL,
created_on TEXT NOT NULL,
last_seen_on TEXT);
CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id);
CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)"""
do! write cmd
CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)"
// Page tables
match! tableExists "page" with
| true -> ()
| false ->
log.LogInformation "Creating page table..."
cmd.CommandText <- """
CREATE TABLE page (
if needsTable "page" then
"CREATE TABLE page (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
@ -197,51 +116,26 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
updated_on TEXT NOT NULL,
is_in_page_list INTEGER NOT NULL DEFAULT 0,
template TEXT,
page_text TEXT NOT NULL);
page_text TEXT NOT NULL,
meta_items TEXT);
CREATE INDEX page_web_log_idx ON page (web_log_id);
CREATE INDEX page_author_idx ON page (author_id);
CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)"""
do! write cmd
match! tableExists "page_meta" with
| true -> ()
| false ->
log.LogInformation "Creating page_meta table..."
cmd.CommandText <- """
CREATE TABLE page_meta (
page_id TEXT NOT NULL REFERENCES page (id),
name TEXT NOT NULL,
value TEXT NOT NULL,
PRIMARY KEY (page_id, name, value))"""
do! write cmd
match! tableExists "page_permalink" with
| true -> ()
| false ->
log.LogInformation "Creating page_permalink table..."
cmd.CommandText <- """
CREATE TABLE page_permalink (
CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)"
if needsTable "page_permalink" then
"CREATE TABLE page_permalink (
page_id TEXT NOT NULL REFERENCES page (id),
permalink TEXT NOT NULL,
PRIMARY KEY (page_id, permalink))"""
do! write cmd
match! tableExists "page_revision" with
| true -> ()
| false ->
log.LogInformation "Creating page_revision table..."
cmd.CommandText <- """
CREATE TABLE page_revision (
PRIMARY KEY (page_id, permalink))"
if needsTable "page_revision" then
"CREATE TABLE page_revision (
page_id TEXT NOT NULL REFERENCES page (id),
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"""
do! write cmd
PRIMARY KEY (page_id, as_of))"
// Post tables
match! tableExists "post" with
| true -> ()
| false ->
log.LogInformation "Creating post table..."
cmd.CommandText <- """
CREATE TABLE post (
if needsTable "post" then
"CREATE TABLE post (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (id),
@ -251,96 +145,37 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
published_on TEXT,
updated_on TEXT NOT NULL,
template TEXT,
post_text TEXT NOT NULL);
post_text TEXT NOT NULL,
meta_items TEXT,
episode TEXT);
CREATE INDEX post_web_log_idx ON post (web_log_id);
CREATE INDEX post_author_idx ON post (author_id);
CREATE INDEX post_status_idx ON post (web_log_id, status, updated_on);
CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)"""
do! write cmd
match! tableExists "post_category" with
| true -> ()
| false ->
log.LogInformation "Creating post_category table..."
cmd.CommandText <- """
CREATE TABLE post_category (
CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)"
if needsTable "post_category" then
"CREATE TABLE post_category (
post_id TEXT NOT NULL REFERENCES post (id),
category_id TEXT NOT NULL REFERENCES category (id),
PRIMARY KEY (post_id, category_id));
CREATE INDEX post_category_category_idx ON post_category (category_id)"""
do! write cmd
match! tableExists "post_episode" with
| true -> ()
| false ->
log.LogInformation "Creating post_episode table..."
cmd.CommandText <- """
CREATE TABLE post_episode (
post_id TEXT PRIMARY KEY REFERENCES post(id),
media TEXT NOT NULL,
length INTEGER NOT NULL,
duration TEXT,
media_type TEXT,
image_url TEXT,
subtitle TEXT,
explicit TEXT,
chapter_file TEXT,
chapter_type TEXT,
transcript_url TEXT,
transcript_type TEXT,
transcript_lang TEXT,
transcript_captions INTEGER,
season_number INTEGER,
season_description TEXT,
episode_number TEXT,
episode_description TEXT)"""
do! write cmd
match! tableExists "post_tag" with
| true -> ()
| false ->
log.LogInformation "Creating post_tag table..."
cmd.CommandText <- """
CREATE TABLE post_tag (
CREATE INDEX post_category_category_idx ON post_category (category_id)"
if needsTable "post_tag" then
"CREATE TABLE post_tag (
post_id TEXT NOT NULL REFERENCES post (id),
tag TEXT NOT NULL,
PRIMARY KEY (post_id, tag))"""
do! write cmd
match! tableExists "post_meta" with
| true -> ()
| false ->
log.LogInformation "Creating post_meta table..."
cmd.CommandText <- """
CREATE TABLE post_meta (
post_id TEXT NOT NULL REFERENCES post (id),
name TEXT NOT NULL,
value TEXT NOT NULL,
PRIMARY KEY (post_id, name, value))"""
do! write cmd
match! tableExists "post_permalink" with
| true -> ()
| false ->
log.LogInformation "Creating post_permalink table..."
cmd.CommandText <- """
CREATE TABLE post_permalink (
PRIMARY KEY (post_id, tag))"
if needsTable "post_permalink" then
"CREATE TABLE post_permalink (
post_id TEXT NOT NULL REFERENCES post (id),
permalink TEXT NOT NULL,
PRIMARY KEY (post_id, permalink))"""
do! write cmd
match! tableExists "post_revision" with
| true -> ()
| false ->
log.LogInformation "Creating post_revision table..."
cmd.CommandText <- """
CREATE TABLE post_revision (
PRIMARY KEY (post_id, permalink))"
if needsTable "post_revision" then
"CREATE TABLE post_revision (
post_id TEXT NOT NULL REFERENCES post (id),
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"""
do! write cmd
match! tableExists "post_comment" with
| true -> ()
| false ->
log.LogInformation "Creating post_comment table..."
cmd.CommandText <- """
CREATE TABLE post_comment (
PRIMARY KEY (post_id, as_of))"
if needsTable "post_comment" then
"CREATE TABLE post_comment (
id TEXT PRIMARY KEY,
post_id TEXT NOT NULL REFERENCES post(id),
in_reply_to_id TEXT,
@ -350,36 +185,397 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
status TEXT NOT NULL,
posted_on TEXT NOT NULL,
comment_text TEXT NOT NULL);
CREATE INDEX post_comment_post_idx ON post_comment (post_id)"""
do! write cmd
CREATE INDEX post_comment_post_idx ON post_comment (post_id)"
// Tag map table
match! tableExists "tag_map" with
| true -> ()
| false ->
log.LogInformation "Creating tag_map table..."
cmd.CommandText <- """
CREATE TABLE tag_map (
if needsTable "tag_map" then
"CREATE TABLE tag_map (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
tag TEXT NOT NULL,
url_value TEXT NOT NULL);
CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)"""
do! write cmd
CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)"
// Uploaded file table
match! tableExists "upload" with
| true -> ()
| false ->
log.LogInformation "Creating upload table..."
cmd.CommandText <- """
CREATE TABLE upload (
if needsTable "upload" then
"CREATE TABLE upload (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id),
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL);
CREATE INDEX upload_web_log_idx ON upload (web_log_id);
CREATE INDEX upload_path_idx ON upload (web_log_id, path)"""
CREATE INDEX upload_path_idx ON upload (web_log_id, path)"
// Database version table
if needsTable "db_version" then
"CREATE TABLE db_version (id TEXT PRIMARY KEY);
INSERT INTO db_version VALUES ('v2-rc1')"
}
|> Seq.map (fun sql ->
log.LogInformation $"Creating {(sql.Split ' ')[2]} table..."
cmd.CommandText <- sql
write cmd |> Async.AwaitTask |> Async.RunSynchronously)
|> List.ofSeq
|> ignore
}
/// Set the database version to the specified version
let setDbVersion version = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')"
do! write cmd
}
/// Implement the changes between v2-rc1 and v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2"
// Move meta items, podcast settings, and episode details to JSON-encoded text fields
use cmd = conn.CreateCommand ()
logStep "Adding new columns"
cmd.CommandText <-
"ALTER TABLE web_log_feed ADD COLUMN podcast TEXT;
ALTER TABLE page ADD COLUMN meta_items TEXT;
ALTER TABLE post ADD COLUMN meta_items TEXT;
ALTER TABLE post ADD COLUMN episode TEXT"
do! write cmd
logStep "Migrating meta items"
let migrateMeta entity = backgroundTask {
cmd.CommandText <- $"SELECT * FROM %s{entity}_meta"
use! metaRdr = cmd.ExecuteReaderAsync ()
let allMetas =
seq {
while metaRdr.Read () do
Map.getString $"{entity}_id" metaRdr,
{ Name = Map.getString "name" metaRdr; Value = Map.getString "value" metaRdr }
} |> List.ofSeq
metaRdr.Close ()
let metas =
allMetas
|> List.map fst
|> List.distinct
|> List.map (fun it -> it, allMetas |> List.filter (fun meta -> fst meta = it))
metas
|> List.iter (fun (entityId, items) ->
cmd.CommandText <-
"UPDATE post
SET meta_items = @metaItems
WHERE id = @postId"
[ cmd.Parameters.AddWithValue ("@metaItems", Utils.serialize ser items)
cmd.Parameters.AddWithValue ("@id", entityId) ] |> ignore
let _ = cmd.ExecuteNonQuery ()
cmd.Parameters.Clear ())
}
do! migrateMeta "page"
do! migrateMeta "post"
logStep "Migrating podcasts and episodes"
cmd.CommandText <- "SELECT * FROM web_log_feed_podcast"
use! podcastRdr = cmd.ExecuteReaderAsync ()
let podcasts =
seq {
while podcastRdr.Read () do
CustomFeedId (Map.getString "feed_id" podcastRdr),
{ Title = Map.getString "title" podcastRdr
Subtitle = Map.tryString "subtitle" podcastRdr
ItemsInFeed = Map.getInt "items_in_feed" podcastRdr
Summary = Map.getString "summary" podcastRdr
DisplayedAuthor = Map.getString "displayed_author" podcastRdr
Email = Map.getString "email" podcastRdr
ImageUrl = Map.getString "image_url" podcastRdr |> Permalink
AppleCategory = Map.getString "apple_category" podcastRdr
AppleSubcategory = Map.tryString "apple_subcategory" podcastRdr
Explicit = Map.getString "explicit" podcastRdr |> ExplicitRating.parse
DefaultMediaType = Map.tryString "default_media_type" podcastRdr
MediaBaseUrl = Map.tryString "media_base_url" podcastRdr
PodcastGuid = Map.tryGuid "podcast_guid" podcastRdr
FundingUrl = Map.tryString "funding_url" podcastRdr
FundingText = Map.tryString "funding_text" podcastRdr
Medium = Map.tryString "medium" podcastRdr
|> Option.map PodcastMedium.parse
}
} |> List.ofSeq
podcastRdr.Close ()
podcasts
|> List.iter (fun (feedId, podcast) ->
cmd.CommandText <- "UPDATE web_log_feed SET podcast = @podcast WHERE id = @id"
[ cmd.Parameters.AddWithValue ("@podcast", Utils.serialize ser podcast)
cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString feedId) ] |> ignore
let _ = cmd.ExecuteNonQuery ()
cmd.Parameters.Clear ())
cmd.CommandText <- "SELECT * FROM post_episode"
use! epRdr = cmd.ExecuteReaderAsync ()
let episodes =
seq {
while epRdr.Read () do
PostId (Map.getString "post_id" epRdr),
{ Media = Map.getString "media" epRdr
Length = Map.getLong "length" epRdr
Duration = Map.tryTimeSpan "duration" epRdr
|> Option.map Duration.FromTimeSpan
MediaType = Map.tryString "media_type" epRdr
ImageUrl = Map.tryString "image_url" epRdr
Subtitle = Map.tryString "subtitle" epRdr
Explicit = Map.tryString "explicit" epRdr
|> Option.map ExplicitRating.parse
ChapterFile = Map.tryString "chapter_file" epRdr
ChapterType = Map.tryString "chapter_type" epRdr
TranscriptUrl = Map.tryString "transcript_url" epRdr
TranscriptType = Map.tryString "transcript_type" epRdr
TranscriptLang = Map.tryString "transcript_lang" epRdr
TranscriptCaptions = Map.tryBoolean "transcript_captions" epRdr
SeasonNumber = Map.tryInt "season_number" epRdr
SeasonDescription = Map.tryString "season_description" epRdr
EpisodeNumber = Map.tryString "episode_number" epRdr
|> Option.map System.Double.Parse
EpisodeDescription = Map.tryString "episode_description" epRdr
}
} |> List.ofSeq
epRdr.Close ()
episodes
|> List.iter (fun (postId, episode) ->
cmd.CommandText <- "UPDATE post SET episode = @episode WHERE id = @id"
[ cmd.Parameters.AddWithValue ("@episode", Utils.serialize ser episode)
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) ] |> ignore
let _ = cmd.ExecuteNonQuery ()
cmd.Parameters.Clear ())
logStep "Migrating dates/times"
let inst (dt : System.DateTime) =
System.DateTime (dt.Ticks, System.DateTimeKind.Utc)
|> (Instant.FromDateTimeUtc >> Noda.toSecondsPrecision)
// page.updated_on, page.published_on
cmd.CommandText <- "SELECT id, updated_on, published_on FROM page"
use! pageRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while pageRdr.Read () do
Map.getString "id" pageRdr,
inst (Map.getDateTime "updated_on" pageRdr),
inst (Map.getDateTime "published_on" pageRdr)
} |> List.ofSeq
pageRdr.Close ()
cmd.CommandText <- "UPDATE page SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id"
[ cmd.Parameters.Add ("@id", SqliteType.Text)
cmd.Parameters.Add ("@updatedOn", SqliteType.Text)
cmd.Parameters.Add ("@publishedOn", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (pageId, updatedOn, publishedOn) ->
cmd.Parameters["@id" ].Value <- pageId
cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn
cmd.Parameters["@publishedOn"].Value <- instantParam publishedOn
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// page_revision.as_of
cmd.CommandText <- "SELECT * FROM page_revision"
use! pageRevRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while pageRevRdr.Read () do
let asOf = Map.getDateTime "as_of" pageRevRdr
Map.getString "page_id" pageRevRdr, asOf, inst asOf, Map.getString "revision_text" pageRevRdr
} |> List.ofSeq
pageRevRdr.Close ()
cmd.CommandText <-
"DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @oldAsOf;
INSERT INTO page_revision (page_id, as_of, revision_text) VALUES (@pageId, @asOf, @text)"
[ cmd.Parameters.Add ("@pageId", SqliteType.Text)
cmd.Parameters.Add ("@oldAsOf", SqliteType.Text)
cmd.Parameters.Add ("@asOf", SqliteType.Text)
cmd.Parameters.Add ("@text", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (pageId, oldAsOf, asOf, text) ->
cmd.Parameters["@pageId" ].Value <- pageId
cmd.Parameters["@oldAsOf"].Value <- oldAsOf
cmd.Parameters["@asOf" ].Value <- instantParam asOf
cmd.Parameters["@text" ].Value <- text
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// post.updated_on, post.published_on (opt)
cmd.CommandText <- "SELECT id, updated_on, published_on FROM post"
use! postRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while postRdr.Read () do
Map.getString "id" postRdr,
inst (Map.getDateTime "updated_on" postRdr),
(Map.tryDateTime "published_on" postRdr |> Option.map inst)
} |> List.ofSeq
postRdr.Close ()
cmd.CommandText <- "UPDATE post SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id"
[ cmd.Parameters.Add ("@id", SqliteType.Text)
cmd.Parameters.Add ("@updatedOn", SqliteType.Text)
cmd.Parameters.Add ("@publishedOn", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (postId, updatedOn, publishedOn) ->
cmd.Parameters["@id" ].Value <- postId
cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn
cmd.Parameters["@publishedOn"].Value <- maybeInstant publishedOn
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// post_revision.as_of
cmd.CommandText <- "SELECT * FROM post_revision"
use! postRevRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while postRevRdr.Read () do
let asOf = Map.getDateTime "as_of" postRevRdr
Map.getString "post_id" postRevRdr, asOf, inst asOf, Map.getString "revision_text" postRevRdr
} |> List.ofSeq
postRevRdr.Close ()
cmd.CommandText <-
"DELETE FROM post_revision WHERE post_id = @postId AND as_of = @oldAsOf;
INSERT INTO post_revision (post_id, as_of, revision_text) VALUES (@postId, @asOf, @text)"
[ cmd.Parameters.Add ("@postId", SqliteType.Text)
cmd.Parameters.Add ("@oldAsOf", SqliteType.Text)
cmd.Parameters.Add ("@asOf", SqliteType.Text)
cmd.Parameters.Add ("@text", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (postId, oldAsOf, asOf, text) ->
cmd.Parameters["@postId" ].Value <- postId
cmd.Parameters["@oldAsOf"].Value <- oldAsOf
cmd.Parameters["@asOf" ].Value <- instantParam asOf
cmd.Parameters["@text" ].Value <- text
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// theme_asset.updated_on
cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset"
use! assetRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while assetRdr.Read () do
Map.getString "theme_id" assetRdr, Map.getString "path" assetRdr,
inst (Map.getDateTime "updated_on" assetRdr)
} |> List.ofSeq
assetRdr.Close ()
cmd.CommandText <- "UPDATE theme_asset SET updated_on = @updatedOn WHERE theme_id = @themeId AND path = @path"
[ cmd.Parameters.Add ("@updatedOn", SqliteType.Text)
cmd.Parameters.Add ("@themeId", SqliteType.Text)
cmd.Parameters.Add ("@path", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (themeId, path, updatedOn) ->
cmd.Parameters["@themeId" ].Value <- themeId
cmd.Parameters["@path" ].Value <- path
cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// upload.updated_on
cmd.CommandText <- "SELECT id, updated_on FROM upload"
use! upRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while upRdr.Read () do
Map.getString "id" upRdr, inst (Map.getDateTime "updated_on" upRdr)
} |> List.ofSeq
upRdr.Close ()
cmd.CommandText <- "UPDATE upload SET updated_on = @updatedOn WHERE id = @id"
[ cmd.Parameters.Add ("@updatedOn", SqliteType.Text)
cmd.Parameters.Add ("@id", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (upId, updatedOn) ->
cmd.Parameters["@id" ].Value <- upId
cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
// web_log_user.created_on, web_log_user.last_seen_on (opt)
cmd.CommandText <- "SELECT id, created_on, last_seen_on FROM web_log_user"
use! userRdr = cmd.ExecuteReaderAsync ()
let toUpdate =
seq {
while userRdr.Read () do
Map.getString "id" userRdr,
inst (Map.getDateTime "created_on" userRdr),
(Map.tryDateTime "last_seen_on" userRdr |> Option.map inst)
} |> List.ofSeq
userRdr.Close ()
cmd.CommandText <- "UPDATE web_log_user SET created_on = @createdOn, last_seen_on = @lastSeenOn WHERE id = @id"
[ cmd.Parameters.Add ("@id", SqliteType.Text)
cmd.Parameters.Add ("@createdOn", SqliteType.Text)
cmd.Parameters.Add ("@lastSeenOn", SqliteType.Text)
] |> ignore
toUpdate
|> List.iter (fun (userId, createdOn, lastSeenOn) ->
cmd.Parameters["@id" ].Value <- userId
cmd.Parameters["@createdOn" ].Value <- instantParam createdOn
cmd.Parameters["@lastSeenOn"].Value <- maybeInstant lastSeenOn
let _ = cmd.ExecuteNonQuery ()
())
cmd.Parameters.Clear ()
conn.Close ()
conn.Open ()
logStep "Dropping old tables and columns"
cmd.CommandText <-
"ALTER TABLE web_log_user DROP COLUMN salt;
DROP TABLE post_episode;
DROP TABLE post_meta;
DROP TABLE page_meta;
DROP TABLE web_log_feed_podcast"
do! write cmd
logStep "Setting database version to v2-rc2"
do! setDbVersion "v2-rc2"
}
/// Migrate data among versions (up only)
let migrate version = backgroundTask {
match version with
| Some v when v = "v2-rc2" -> ()
| Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 ()
| Some _
| None ->
log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}"
do! setDbVersion Utils.currentDbVersion
}
/// The connection for this instance
member _.Conn = conn
/// Make a SQLite connection ready to execute commends
static member setUpConnection (conn : SqliteConnection) = backgroundTask {
do! conn.OpenAsync ()
use cmd = conn.CreateCommand ()
cmd.CommandText <- "PRAGMA foreign_keys = TRUE"
let! _ = cmd.ExecuteNonQueryAsync ()
()
}
interface IData with
member _.Category = SQLiteCategoryData conn
member _.Page = SQLitePageData (conn, ser)
member _.Post = SQLitePostData (conn, ser)
member _.TagMap = SQLiteTagMapData conn
member _.Theme = SQLiteThemeData conn
member _.ThemeAsset = SQLiteThemeAssetData conn
member _.Upload = SQLiteUploadData conn
member _.WebLog = SQLiteWebLogData (conn, ser)
member _.WebLogUser = SQLiteWebLogUserData conn
member _.Serializer = ser
member _.StartUp () = backgroundTask {
do! ensureTables ()
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT id FROM db_version"
use! rdr = cmd.ExecuteReaderAsync ()
let version = if rdr.Read () then Some (Map.getString "id" rdr) else None
match version with
| Some v when v = "v2-rc2" -> ()
| Some _
| None -> do! migrate version
}

View File

@ -5,6 +5,9 @@ module internal MyWebLog.Data.Utils
open MyWebLog
open MyWebLog.ViewModels
/// The current database version
let currentDbVersion = "v2-rc2"
/// 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
@ -20,3 +23,36 @@ let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames =
yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames)
}
/// Get lists of items removed from and added to the given lists
let diffLists<'T, 'U when 'U : equality> oldItems newItems (f : 'T -> 'U) =
let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other))
List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems
/// Find meta items added and removed
let diffMetaItems (oldItems : MetaItem list) newItems =
diffLists oldItems newItems (fun item -> $"{item.Name}|{item.Value}")
/// Find the permalinks added and removed
let diffPermalinks oldLinks newLinks =
diffLists oldLinks newLinks Permalink.toString
/// Find the revisions added and removed
let diffRevisions oldRevs newRevs =
diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.ToUnixTimeTicks ()}|{MarkupText.toString rev.Text}")
open MyWebLog.Converters
open Newtonsoft.Json
/// Serialize an object to JSON
let serialize<'T> ser (item : 'T) =
JsonConvert.SerializeObject (item, Json.settings ser)
/// Deserialize a JSON string
let deserialize<'T> (ser : JsonSerializer) value =
JsonConvert.DeserializeObject<'T> (value, Json.settings ser)
open Microsoft.Extensions.Logging
/// Log a migration step
let logMigrationStep<'T> (log : ILogger<'T>) migration message =
log.LogInformation $"Migrating %s{migration}: %s{message}"

View File

@ -2,6 +2,7 @@
open System
open MyWebLog
open NodaTime
/// A category under which a post may be identified
[<CLIMutable; NoComparison; NoEquality>]
@ -64,7 +65,7 @@ type Comment =
Status : CommentStatus
/// When the comment was posted
PostedOn : DateTime
PostedOn : Instant
/// The text of the comment
Text : string
@ -82,7 +83,7 @@ module Comment =
Email = ""
Url = None
Status = Pending
PostedOn = DateTime.UtcNow
PostedOn = Noda.epoch
Text = ""
}
@ -106,10 +107,10 @@ type Page =
Permalink : Permalink
/// When this page was published
PublishedOn : DateTime
PublishedOn : Instant
/// When this page was last updated
UpdatedOn : DateTime
UpdatedOn : Instant
/// Whether this page shows as part of the web log's navigation
IsInPageList : bool
@ -140,8 +141,8 @@ module Page =
AuthorId = WebLogUserId.empty
Title = ""
Permalink = Permalink.empty
PublishedOn = DateTime.MinValue
UpdatedOn = DateTime.MinValue
PublishedOn = Noda.epoch
UpdatedOn = Noda.epoch
IsInPageList = false
Template = None
Text = ""
@ -173,10 +174,10 @@ type Post =
Permalink : Permalink
/// The instant on which the post was originally published
PublishedOn : DateTime option
PublishedOn : Instant option
/// The instant on which the post was last updated
UpdatedOn : DateTime
UpdatedOn : Instant
/// The template to use in displaying the post
Template : string option
@ -215,7 +216,7 @@ module Post =
Title = ""
Permalink = Permalink.empty
PublishedOn = None
UpdatedOn = DateTime.MinValue
UpdatedOn = Noda.epoch
Text = ""
Template = None
CategoryIds = []
@ -288,7 +289,7 @@ type ThemeAsset =
Id : ThemeAssetId
/// The updated date (set from the file date from the ZIP archive)
UpdatedOn : DateTime
UpdatedOn : Instant
/// The data for the asset
Data : byte[]
@ -300,7 +301,7 @@ module ThemeAsset =
/// An empty theme asset
let empty =
{ Id = ThemeAssetId (ThemeId "", "")
UpdatedOn = DateTime.MinValue
UpdatedOn = Noda.epoch
Data = [||]
}
@ -317,7 +318,7 @@ type Upload =
Path : Permalink
/// The updated date/time for this upload
UpdatedOn : DateTime
UpdatedOn : Instant
/// The data for the upload
Data : byte[]
@ -331,7 +332,7 @@ module Upload =
{ Id = UploadId.empty
WebLogId = WebLogId.empty
Path = Permalink.empty
UpdatedOn = DateTime.MinValue
UpdatedOn = Noda.epoch
Data = [||]
}
@ -410,10 +411,11 @@ module WebLog =
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 an Instant (UTC reference) to the web log's local date/time
let localTime webLog (date : Instant) =
match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with
| null -> date.ToDateTimeUtc ()
| tz -> date.InZone(tz).ToDateTimeUnspecified ()
/// A user of the web log
@ -440,9 +442,6 @@ type WebLogUser =
/// 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
@ -450,10 +449,10 @@ type WebLogUser =
AccessLevel : AccessLevel
/// When the user was created
CreatedOn : DateTime
CreatedOn : Instant
/// When the user last logged on
LastSeenOn : DateTime option
LastSeenOn : Instant option
}
/// Functions to support web log users
@ -468,10 +467,9 @@ module WebLogUser =
LastName = ""
PreferredName = ""
PasswordHash = ""
Salt = Guid.Empty
Url = None
AccessLevel = Author
CreatedOn = DateTime.UnixEpoch
CreatedOn = Noda.epoch
LastSeenOn = None
}

View File

@ -7,9 +7,10 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="Markdig" Version="0.30.2" />
<PackageReference Include="Markdig" Version="0.30.3" />
<PackageReference Update="FSharp.Core" Version="6.0.5" />
<PackageReference Include="Markdown.ColorCode" Version="1.0.1" />
<PackageReference Include="NodaTime" Version="3.1.2" />
</ItemGroup>
</Project>

View File

@ -1,6 +1,7 @@
namespace MyWebLog
open System
open NodaTime
/// Support functions for domain definition
[<AutoOpen>]
@ -12,6 +13,29 @@ module private Helpers =
Convert.ToBase64String(Guid.NewGuid().ToByteArray ()).Replace('/', '_').Replace('+', '-').Substring (0, 22)
/// Functions to support NodaTime manipulation
module Noda =
/// The clock to use when getting "now" (will make mutable for testing)
let clock : IClock = SystemClock.Instance
/// The Unix epoch
let epoch = Instant.FromUnixTimeSeconds 0L
/// Truncate an instant to remove fractional seconds
let toSecondsPrecision (value : Instant) =
Instant.FromUnixTimeSeconds (value.ToUnixTimeSeconds ())
/// The current Instant, with fractional seconds truncated
let now () =
toSecondsPrecision (clock.GetCurrentInstant ())
/// Convert a date/time to an Instant with whole seconds
let fromDateTime (dt : DateTime) =
toSecondsPrecision (Instant.FromDateTimeUtc (DateTime (dt.Ticks, DateTimeKind.Utc)))
/// A user's access level
type AccessLevel =
/// The user may create and publish posts and edit the ones they have created
@ -137,6 +161,8 @@ module ExplicitRating =
| x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating")
open NodaTime.Text
/// A podcast episode
type Episode =
{ /// The URL to the media file for the episode (may be permalink)
@ -146,7 +172,7 @@ type Episode =
Length : int64
/// The duration of the episode
Duration : TimeSpan option
Duration : Duration option
/// The media type of the file (overrides podcast default if present)
MediaType : string option
@ -215,6 +241,10 @@ module Episode =
EpisodeDescription = None
}
/// Format a duration for an episode
let formatDuration ep =
ep.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format)
open Markdig
open Markdown.ColorCode
@ -269,12 +299,11 @@ module MetaItem =
let empty =
{ Name = ""; Value = "" }
/// A revision of a page or post
[<CLIMutable; NoComparison; NoEquality>]
type Revision =
{ /// When this revision was saved
AsOf : DateTime
AsOf : Instant
/// The text of the revision
Text : MarkupText
@ -285,7 +314,7 @@ module Revision =
/// An empty revision
let empty =
{ AsOf = DateTime.UtcNow
{ AsOf = Noda.epoch
Text = Html ""
}

View File

@ -2,6 +2,7 @@
open System
open MyWebLog
open NodaTime
/// Helper functions for view models
[<AutoOpen>]
@ -138,8 +139,8 @@ type DisplayPage =
AuthorId = WebLogUserId.toString page.AuthorId
Title = page.Title
Permalink = Permalink.toString page.Permalink
PublishedOn = page.PublishedOn
UpdatedOn = page.UpdatedOn
PublishedOn = WebLog.localTime webLog page.PublishedOn
UpdatedOn = WebLog.localTime webLog page.UpdatedOn
IsInPageList = page.IsInPageList
IsDefault = pageId = webLog.DefaultPage
Text = ""
@ -154,8 +155,8 @@ type DisplayPage =
AuthorId = WebLogUserId.toString page.AuthorId
Title = page.Title
Permalink = Permalink.toString page.Permalink
PublishedOn = page.PublishedOn
UpdatedOn = page.UpdatedOn
PublishedOn = WebLog.localTime webLog page.PublishedOn
UpdatedOn = WebLog.localTime webLog page.UpdatedOn
IsInPageList = page.IsInPageList
IsDefault = pageId = webLog.DefaultPage
Text = addBaseToRelativeUrls extra page.Text
@ -179,7 +180,7 @@ with
/// Create a display revision from an actual revision
static member fromRevision webLog (rev : Revision) =
{ AsOf = rev.AsOf
{ AsOf = rev.AsOf.ToDateTimeUtc ()
AsOfLocal = WebLog.localTime webLog rev.AsOf
Format = MarkupText.sourceType rev.Text
}
@ -723,7 +724,7 @@ type EditPostModel =
IsEpisode = Option.isSome post.Episode
Media = episode.Media
Length = episode.Length
Duration = defaultArg (episode.Duration |> Option.map (fun it -> it.ToString """hh\:mm\:ss""")) ""
Duration = defaultArg (Episode.formatDuration episode) ""
MediaType = defaultArg episode.MediaType ""
ImageUrl = defaultArg episode.ImageUrl ""
Subtitle = defaultArg episode.Subtitle ""
@ -781,7 +782,8 @@ type EditPostModel =
Some {
Media = this.Media
Length = this.Length
Duration = noneIfBlank this.Duration |> Option.map TimeSpan.Parse
Duration = noneIfBlank this.Duration
|> Option.map (TimeSpan.Parse >> Duration.FromTimeSpan)
MediaType = noneIfBlank this.MediaType
ImageUrl = noneIfBlank this.ImageUrl
Subtitle = noneIfBlank this.Subtitle

View File

@ -56,7 +56,6 @@ module Extensions =
defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false
open System.Collections.Concurrent
/// <summary>

View File

@ -5,6 +5,7 @@ open System.Threading.Tasks
open Giraffe
open MyWebLog
open MyWebLog.ViewModels
open NodaTime
/// ~~ DASHBOARDS ~~
module Dashboard =
@ -13,22 +14,21 @@ module Dashboard =
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let getCount (f : WebLogId -> Task<int>) = f ctx.WebLog.Id
let data = ctx.Data
let posts = getCount (data.Post.CountByStatus Published)
let drafts = getCount (data.Post.CountByStatus Draft)
let pages = getCount data.Page.CountAll
let listed = getCount data.Page.CountListed
let cats = getCount data.Category.CountAll
let topCats = getCount data.Category.CountTopLevel
let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats)
let! posts = getCount (data.Post.CountByStatus Published)
let! drafts = getCount (data.Post.CountByStatus Draft)
let! pages = getCount data.Page.CountAll
let! listed = getCount data.Page.CountListed
let! cats = getCount data.Category.CountAll
let! topCats = getCount data.Category.CountTopLevel
return!
hashForPage "Dashboard"
|> addToHash ViewContext.Model {
Posts = posts.Result
Drafts = drafts.Result
Pages = pages.Result
ListedPages = listed.Result
Categories = cats.Result
TopLevelCategories = topCats.Result
Posts = posts
Drafts = drafts
Pages = pages
ListedPages = listed
Categories = cats
TopLevelCategories = topCats
}
|> adminView "dashboard" next ctx
}
@ -344,7 +344,8 @@ module Theme =
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ Id = ThemeAssetId (themeId, assetName)
UpdatedOn = asset.LastWriteTime.DateTime
UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime)
.InZoneLeniently(DateTimeZone.Utc).ToInstant ()
Data = stream.ToArray ()
}
}

View File

@ -95,8 +95,8 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[
let item = SyndicationItem (
Id = WebLog.absoluteUrl webLog post.Permalink,
Title = TextSyndicationContent.CreateHtmlContent post.Title,
PublishDate = DateTimeOffset post.PublishedOn.Value,
LastUpdatedTime = DateTimeOffset post.UpdatedOn,
PublishDate = post.PublishedOn.Value.ToDateTimeOffset (),
LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset (),
Content = TextSyndicationContent.CreatePlaintextContent plainText)
item.AddPermalink (Uri item.Id)
@ -163,8 +163,8 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.DisplayedAuthor)
item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit)
episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it))
episode.Duration
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it.ToString """hh\:mm\:ss"""))
Episode.formatDuration episode
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it))
match episode.ChapterFile with
| Some chapters ->
@ -381,7 +381,7 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
addNamespace feed "content" Namespace.content
setTitleAndDescription feedType webLog cats feed
feed.LastUpdatedTime <- (List.head posts).UpdatedOn |> DateTimeOffset
feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset ()
feed.Generator <- ctx.Generator
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"

View File

@ -419,10 +419,11 @@ let getCategoryIds slug ctx =
open System
open System.Globalization
open NodaTime
/// Parse a date/time to UTC
let parseToUtc (date : string) =
DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal)
Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal))
open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging

View File

@ -139,15 +139,13 @@ let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
| _, None -> return! Error.notFound next ctx
}
open System
// POST /admin/page/{id}/revision/{revision-date}/restore
let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update
{ pg with
Revisions = { rev with AsOf = DateTime.UtcNow }
Revisions = { rev with AsOf = Noda.now () }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
@ -173,7 +171,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let data = ctx.Data
let now = DateTime.UtcNow
let now = Noda.now ()
let tryPage =
if model.IsNew then
{ Page.empty with

View File

@ -53,8 +53,8 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
match listType with
| SinglePost ->
let post = List.head posts
let dateTime = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id dateTime
let target = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id target
| _ -> Task.FromResult (None, None)
let newerLink =
match listType, pageNbr with
@ -350,7 +350,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update
{ post with
Revisions = { rev with AsOf = DateTime.UtcNow }
Revisions = { rev with AsOf = Noda.now () }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
@ -376,7 +376,6 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> ()
let data = ctx.Data
let now = DateTime.UtcNow
let tryPost =
if model.IsNew then
{ Post.empty with
@ -389,7 +388,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| Some post when canEdit post.AuthorId ctx ->
let priorCats = post.CategoryIds
let updatedPost =
model.UpdatePost post now
model.UpdatePost post (Noda.now ())
|> function
| post ->
if model.SetPublished then

View File

@ -94,7 +94,7 @@ module Asset =
| Some asset ->
match Upload.checkModified asset.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! Upload.sendFile asset.UpdatedOn path asset.Data next ctx
| None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc ()) path asset.Data next ctx
| None -> return! Error.notFound next ctx
}

View File

@ -29,15 +29,17 @@ module private Helpers =
// ~~ SERVING UPLOADS ~~
open System.Globalization
open Giraffe
open Microsoft.AspNetCore.Http
open NodaTime
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header
let checkModified since (ctx : HttpContext) : HttpHandler option =
match ctx.Request.Headers.IfModifiedSince with
| it when it.Count < 1 -> None
| it when since > DateTime.Parse it[0] -> None
| _ -> Some (setStatusCode 304 >=> setBodyFromString "Not Modified")
| it when since > Instant.FromDateTimeUtc (DateTime.Parse (it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| _ -> Some (setStatusCode 304)
open Microsoft.AspNetCore.Http.Headers
@ -73,7 +75,7 @@ let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
| Some upload ->
match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! sendFile upload.UpdatedOn path upload.Data next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc ()) path upload.Data next ctx
| None -> return! Error.notFound next ctx
else
return! Error.notFound next ctx
@ -143,7 +145,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let upload = Seq.head ctx.Request.Form.Files
let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName),
Path.GetExtension(upload.FileName).ToLowerInvariant ())
let localNow = WebLog.localTime ctx.WebLog DateTime.Now
let now = Noda.now ()
let localNow = WebLog.localTime ctx.WebLog now
let year = localNow.ToString "yyyy"
let month = localNow.ToString "MM"
let! form = ctx.BindFormAsync<UploadFileModel> ()
@ -156,7 +159,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ Id = UploadId.create ()
WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = DateTime.UtcNow
UpdatedOn = now
Data = stream.ToArray ()
}
do! ctx.Data.Upload.Add file

View File

@ -2,19 +2,32 @@
module MyWebLog.Handlers.User
open System
open System.Security.Cryptography
open System.Text
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Identity
open MyWebLog
open NodaTime
// ~~ LOG ON / LOG OFF ~~
/// Hash a password for a given user
let hashedPassword (plainText : string) (email : string) (salt : Guid) =
let allSalt = Array.concat [ salt.ToByteArray (); Encoding.UTF8.GetBytes email ]
use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048)
Convert.ToBase64String (alg.GetBytes 64)
/// Create a password hash a password for a given user
let createPasswordHash user password =
PasswordHasher<WebLogUser>().HashPassword (user, password)
/// Verify whether a password is valid
let verifyPassword user password (ctx : HttpContext) = backgroundTask {
match user with
| Some usr ->
let hasher = PasswordHasher<WebLogUser> ()
match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with
| PasswordVerificationResult.Success -> return Ok ()
| PasswordVerificationResult.SuccessRehashNeeded ->
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword (usr, password) }
return Ok ()
| _ -> return Error "Log on attempt unsuccessful"
| None -> return Error "Log on attempt unsuccessful"
}
open Giraffe
open MyWebLog
open MyWebLog.ViewModels
// GET /user/log-on
@ -37,8 +50,10 @@ open Microsoft.AspNetCore.Authentication.Cookies
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
let data = ctx.Data
match! data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id with
| Some user when user.PasswordHash = hashedPassword model.Password user.Email user.Salt ->
let! tryUser = data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id
match! verifyPassword tryUser model.Password ctx with
| Ok _ ->
let user = tryUser.Value
let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.Id)
Claim (ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
@ -59,8 +74,8 @@ let doLogOn : HttpHandler = fun next ctx -> task {
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
| None -> redirectToGet "admin/dashboard" next ctx
| _ ->
do! addMessage ctx { UserMessage.error with Message = "Log on attempt unsuccessful" }
| Error msg ->
do! addMessage ctx { UserMessage.error with Message = msg }
return! logOn model.ReturnTo next ctx
}
@ -147,7 +162,9 @@ let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandl
|> addToHash ViewContext.Model model
|> addToHash "access_level" (AccessLevel.toString user.AccessLevel)
|> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn)
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch))
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog
(defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0)))
|> adminView "my-info" next ctx
@ -164,19 +181,13 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user when model.NewPassword = model.NewPasswordConfirm ->
let pw, salt =
if model.NewPassword = "" then
user.PasswordHash, user.Salt
else
let newSalt = Guid.NewGuid ()
hashedPassword model.NewPassword user.Email newSalt, newSalt
let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword
let user =
{ user with
FirstName = model.FirstName
LastName = model.LastName
PreferredName = model.PreferredName
PasswordHash = pw
Salt = salt
}
do! data.WebLogUser.Update user
let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
@ -200,7 +211,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
{ WebLogUser.empty with
Id = WebLogUserId.create ()
WebLogId = ctx.WebLog.Id
CreatedOn = DateTime.UtcNow
CreatedOn = Noda.now ()
} |> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
@ -211,9 +222,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
else
let toUpdate =
if model.Password = "" then updatedUser
else
let salt = Guid.NewGuid ()
{ updatedUser with PasswordHash = hashedPassword model.Password model.Email salt; Salt = salt }
else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password }
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
do! addMessage ctx
{ UserMessage.success with
@ -227,4 +236,3 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
next ctx
| None -> return! Error.notFound next ctx
}

View File

@ -4,6 +4,7 @@ open System
open System.IO
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
open NodaTime
/// Create the web log information
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
@ -41,10 +42,8 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
}
// Create the admin user
let salt = Guid.NewGuid ()
let now = DateTime.UtcNow
do! data.WebLogUser.Add
let now = Noda.now ()
let user =
{ WebLogUser.empty with
Id = userId
WebLogId = webLogId
@ -52,11 +51,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
FirstName = "Admin"
LastName = "User"
PreferredName = "Admin"
PasswordHash = Handlers.User.hashedPassword args[4] args[3] salt
Salt = salt
AccessLevel = accessLevel
CreatedOn = now
}
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page
do! data.Page.Add
@ -155,7 +153,6 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
/// Back up a web log's data
module Backup =
open System.Threading.Tasks
open MyWebLog.Converters
open Newtonsoft.Json
@ -165,7 +162,7 @@ module Backup =
Id : ThemeAssetId
/// The updated date for this asset
UpdatedOn : DateTime
UpdatedOn : Instant
/// The data for this asset, base-64 encoded
Data : string
@ -197,7 +194,7 @@ module Backup =
Path : Permalink
/// The date/time this upload was last updated (file time)
UpdatedOn : DateTime
UpdatedOn : Instant
/// The data for the upload, base-64 encoded
Data : string
@ -251,10 +248,9 @@ module Backup =
Uploads : EncodedUpload list
}
/// Create a JSON serializer (uses RethinkDB data implementation's JSON converters)
/// Create a JSON serializer
let private getSerializer prettyOutput =
let serializer = JsonSerializer.CreateDefault ()
Json.all () |> Seq.iter serializer.Converters.Add
let serializer = Json.configure (JsonSerializer.CreateDefault ())
if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer
@ -382,7 +378,8 @@ module Backup =
printfn ""
printfn "- Importing theme..."
do! data.Theme.Save restore.Theme
let! _ = restore.Assets |> List.map (EncodedAsset.toAsset >> data.ThemeAsset.Save) |> Task.WhenAll
restore.Assets
|> List.iter (EncodedAsset.toAsset >> data.ThemeAsset.Save >> Async.AwaitTask >> Async.RunSynchronously)
// Restore web log data
@ -393,18 +390,19 @@ module Backup =
do! data.WebLogUser.Restore restore.Users
printfn "- Restoring categories and tag mappings..."
do! data.TagMap.Restore restore.TagMappings
do! data.Category.Restore restore.Categories
if not (List.isEmpty restore.TagMappings) then do! data.TagMap.Restore restore.TagMappings
if not (List.isEmpty restore.Categories) then do! data.Category.Restore restore.Categories
printfn "- Restoring pages..."
do! data.Page.Restore restore.Pages
if not (List.isEmpty restore.Pages) then do! data.Page.Restore restore.Pages
printfn "- Restoring posts..."
do! data.Post.Restore restore.Posts
if not (List.isEmpty restore.Posts) then do! data.Post.Restore restore.Posts
// TODO: comments not yet implemented
printfn "- Restoring uploads..."
if not (List.isEmpty restore.Uploads) then
do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload)
displayStats "Restored for <>NAME<>:" restore.WebLog restore
@ -490,3 +488,22 @@ let upgradeUser (args : string[]) (sp : IServiceProvider) = task {
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData> ())
| _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]"
}
/// Set a user's password
let doSetPassword urlBase email password (data : IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
| Some user ->
do! data.WebLogUser.Update { user with PasswordHash = Handlers.User.createPasswordHash user password }
printfn $"Password for user {email} at {webLog.Name} set successfully"
| None -> eprintfn $"ERROR: no user {email} found at {urlBase}"
| None -> eprintfn $"ERROR: no web log found for {urlBase}"
}
/// Set a user's password if the command-line arguments are good
let setPassword (args : string[]) (sp : IServiceProvider) = task {
match args.Length with
| 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService<IData> ())
| _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]"
}

View File

@ -29,11 +29,14 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
open System
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
open Newtonsoft.Json
open Npgsql
/// Logic to obtain a data connection and implementation based on configured values
module DataImplementation =
open MyWebLog.Converters
// open Npgsql.Logging
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
@ -43,23 +46,29 @@ module DataImplementation =
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr =
let createSQLite connStr : IData =
let log = sp.GetRequiredService<ILogger<SQLiteData>> ()
let conn = new SqliteConnection (connStr)
log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log)
SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ()))
if hasConnStr "SQLite" then
upcast createSQLite (connStr "SQLite")
createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>> ()
Json.all () |> Seq.iter Converter.Serializer.Converters.Add
let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
upcast RethinkDbData (conn, rethinkCfg, log)
RethinkDbData (conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then
let log = sp.GetRequiredService<ILogger<PostgresData>> ()
// NpgsqlLogManager.Provider <- ConsoleLoggingProvider NpgsqlLogLevel.Debug
let conn = new NpgsqlConnection (connStr "PostgreSQL")
log.LogInformation $"Using PostgreSQL database {conn.Host}:{conn.Port}/{conn.Database}"
PostgresData (conn, log, Json.configure (JsonSerializer.CreateDefault ()))
else
upcast createSQLite "Data Source=./myweblog.db;Cache=Shared"
createSQLite "Data Source=./myweblog.db;Cache=Shared"
open System.Threading.Tasks
@ -76,6 +85,7 @@ let showHelp () =
printfn "init Initializes a new web log"
printfn "load-theme Load a theme"
printfn "restore Restore a JSON file backup (prompt before overwriting)"
printfn "set-password Set a password for a specific user"
printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " "
printfn "For more information on a particular command, run it with no options."
@ -88,6 +98,7 @@ open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite
open RethinkDB.DistributedCache
@ -110,6 +121,7 @@ let rec main args =
let sp = builder.Services.BuildServiceProvider ()
let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task {
do! data.StartUp ()
@ -121,23 +133,36 @@ let rec main args =
match data with
| :? RethinkDbData as rethink ->
// A RethinkDB connection is designed to work as a singleton
builder.Services.AddSingleton<IData> data |> ignore
let _ = builder.Services.AddSingleton<IData> data
let _ =
builder.Services.AddDistributedRethinkDBCache (fun opts ->
opts.TableName <- "Session"
opts.Connection <- rethink.Conn)
|> ignore
()
| :? SQLiteData as sql ->
// ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> ()
let _ =
builder.Services.AddScoped<SqliteConnection> (fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn)
|> ignore
builder.Services.AddScoped<IData, SQLiteData> () |> ignore
let _ = builder.Services.AddScoped<IData, SQLiteData> () |> ignore
// Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db"
builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) |> ignore
let _ = builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath)
()
| :? PostgresData ->
// ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> ()
let _ =
builder.Services.AddScoped<NpgsqlConnection> (fun sp ->
new NpgsqlConnection (cfg.GetConnectionString "PostgreSQL"))
let _ = builder.Services.AddScoped<IData, PostgresData> ()
let _ =
builder.Services.AddSingleton<IDistributedCache> (fun sp ->
Postgres.DistributedCache (cfg.GetConnectionString "PostgreSQL") :> IDistributedCache)
()
| _ -> ()
let _ = builder.Services.AddSession(fun opts ->
@ -159,6 +184,7 @@ let rec main args =
| Some it when it = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "do-restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "upgrade-user" -> Maintenance.upgradeUser args app.Services
| Some it when it = "set-password" -> Maintenance.setPassword args app.Services
| Some it when it = "help" -> showHelp ()
| Some it ->
printfn $"""Unrecognized command "{it}" - valid commands are:"""

View File

@ -1,5 +1,5 @@
{
"Generator": "myWebLog 2.0-rc1",
"Generator": "myWebLog 2.0-rc2",
"Logging": {
"LogLevel": {
"MyWebLog.Handlers": "Information"

View File

@ -1,2 +1,2 @@
myWebLog Admin
2.0.0-rc1
2.0.0-rc2

View File

@ -1,2 +1,2 @@
myWebLog Default Theme
2.0.0-rc1
2.0.0-rc2