* Add PostgreSQL back end (#30)
* Upgrade password storage (#32)
* Change podcast/episode storage for SQLite (#29)
* Move date/time handling to NodaTime (#31)
This commit is contained in:
Daniel J. Summers 2022-08-21 18:56:18 -04:00 committed by GitHub
parent 1ec664ad24
commit 5f3daa1de9
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
45 changed files with 3820 additions and 1306 deletions

View File

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

View File

@ -122,12 +122,13 @@ module Json =
(string >> WebLogUserId) reader.Value (string >> WebLogUserId) reader.Value
open Microsoft.FSharpLu.Json open Microsoft.FSharpLu.Json
open NodaTime
open NodaTime.Serialization.JsonNet
/// All converters to use for data conversion /// Configure a serializer to use these converters
let all () : JsonConverter seq = let configure (ser : JsonSerializer) =
seq {
// Our converters // Our converters
CategoryIdConverter () [ CategoryIdConverter () :> JsonConverter
CommentIdConverter () CommentIdConverter ()
CustomFeedIdConverter () CustomFeedIdConverter ()
CustomFeedSourceConverter () CustomFeedSourceConverter ()
@ -143,6 +144,35 @@ module Json =
UploadIdConverter () UploadIdConverter ()
WebLogIdConverter () WebLogIdConverter ()
WebLogUserIdConverter () WebLogUserIdConverter ()
] |> List.iter ser.Converters.Add
// NodaTime
let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb
// Handles DUs with no associated data, as well as option fields // 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 namespace MyWebLog.Data
open System
open System.Threading.Tasks open System.Threading.Tasks
open MyWebLog open MyWebLog
open MyWebLog.ViewModels open MyWebLog.ViewModels
open Newtonsoft.Json
open NodaTime
/// The result of a category deletion attempt /// The result of a category deletion attempt
type CategoryDeleteResult = type CategoryDeleteResult =
@ -137,7 +138,7 @@ type IPostData =
WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task<Post list> 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) /// 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 /// Restore posts from a backup
abstract member Restore : Post list -> Task<unit> abstract member Restore : Post list -> Task<unit>
@ -326,6 +327,9 @@ type IData =
/// Web log user data functions /// Web log user data functions
abstract member WebLogUser : IWebLogUserData abstract member WebLogUser : IWebLogUserData
/// A JSON serializer for use in persistence
abstract member Serializer : JsonSerializer
/// Do any required start up data checks /// Do any required start up data checks
abstract member StartUp : unit -> Task<unit> abstract member StartUp : unit -> Task<unit>

View File

@ -5,10 +5,16 @@
</ItemGroup> </ItemGroup>
<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.Extensions.Configuration.Abstractions" Version="6.0.0" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" /> <PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" /> <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" Version="2.3.150" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" /> <PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" />
<PackageReference Update="FSharp.Core" Version="6.0.5" /> <PackageReference Update="FSharp.Core" Version="6.0.5" />
@ -29,6 +35,17 @@
<Compile Include="SQLite\SQLiteWebLogData.fs" /> <Compile Include="SQLite\SQLiteWebLogData.fs" />
<Compile Include="SQLite\SQLiteWebLogUserData.fs" /> <Compile Include="SQLite\SQLiteWebLogUserData.fs" />
<Compile Include="SQLiteData.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> </ItemGroup>
</Project> </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 /// The comment table
let Comment = "Comment" let Comment = "Comment"
/// The database version table
let DbVersion = "DbVersion"
/// The page table /// The page table
let Page = "Page" let Page = "Page"
@ -43,7 +46,7 @@ module private RethinkHelpers =
let WebLogUser = "WebLogUser" let WebLogUser = "WebLogUser"
/// A list of all tables /// 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 /// 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 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 /// The connection for this instance
member _.Conn = conn member _.Conn = conn
@ -1079,7 +1117,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! rethink { do! rethink {
withTable Table.WebLogUser withTable Table.WebLogUser
get userId get userId
update [ nameof WebLogUser.empty.LastSeenOn, DateTime.UtcNow :> obj ] update [ nameof WebLogUser.empty.LastSeenOn, Noda.now () :> obj ]
write; withRetryOnce; ignoreResult conn write; withRetryOnce; ignoreResult conn
} }
| None -> () | None -> ()
@ -1094,7 +1132,6 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
nameof user.LastName, user.LastName nameof user.LastName, user.LastName
nameof user.PreferredName, user.PreferredName nameof user.PreferredName, user.PreferredName
nameof user.PasswordHash, user.PasswordHash nameof user.PasswordHash, user.PasswordHash
nameof user.Salt, user.Salt
nameof user.Url, user.Url nameof user.Url, user.Url
nameof user.AccessLevel, user.AccessLevel 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 { member _.StartUp () = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn } let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then 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}..." log.LogInformation $"Creating table {tbl}..."
do! rethink { tableCreate tbl [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn } 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.Category [ nameof Category.empty.WebLogId ]
do! ensureIndexes Table.Comment [ nameof Comment.empty.PostId ] do! ensureIndexes Table.Comment [ nameof Comment.empty.PostId ]
do! ensureIndexes Table.Page [ nameof Page.empty.WebLogId; nameof Page.empty.AuthorId ] 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.Upload []
do! ensureIndexes Table.WebLog [ nameof WebLog.empty.UrlBase ] do! ensureIndexes Table.WebLog [ nameof WebLog.empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.empty.WebLogId ] 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 System
open Microsoft.Data.Sqlite open Microsoft.Data.Sqlite
open MyWebLog open MyWebLog
open MyWebLog.Data
open NodaTime.Text
/// Run a command that returns a count /// Run a command that returns a count
let count (cmd : SqliteCommand) = backgroundTask { let count (cmd : SqliteCommand) = backgroundTask {
@ -12,23 +14,6 @@ let count (cmd : SqliteCommand) = backgroundTask {
return int (it :?> int64) 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 /// Create a list of items from the given data reader
let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) = let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) =
seq { while rdr.Read () do it rdr } 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 /// Functions to map domain items from a data reader
module Map = module Map =
@ -73,6 +94,26 @@ module Map =
/// Get a string value from a data reader /// Get a string value from a data reader
let getString col (rdr : SqliteDataReader) = rdr.GetString (rdr.GetOrdinal col) 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 /// Get a timespan value from a data reader
let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col) let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col)
@ -96,6 +137,14 @@ module Map =
let tryString col (rdr : SqliteDataReader) = let tryString col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getString col rdr) 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 /// Get a possibly null timespan value from a data reader
let tryTimeSpan col (rdr : SqliteDataReader) = let tryTimeSpan col (rdr : SqliteDataReader) =
if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getTimeSpan col rdr) 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 /// 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 { Id = getString "id" rdr |> CustomFeedId
Source = getString "source" rdr |> CustomFeedSource.parse Source = getString "source" rdr |> CustomFeedSource.parse
Path = getString "path" rdr |> Permalink Path = getString "path" rdr |> Permalink
Podcast = Podcast = tryString "podcast" rdr |> Option.map (Utils.deserialize ser)
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
} }
/// Create a permalink from the current row in the given data reader /// Create a permalink from the current row in the given data reader
let toPermalink rdr = getString "permalink" rdr |> Permalink let toPermalink rdr = getString "permalink" rdr |> Permalink
/// Create a page from the current row in the given data reader /// Create a page from the current row in the given data reader
let toPage rdr : Page = let toPage ser rdr : Page =
{ Page.empty with { Page.empty with
Id = getString "id" rdr |> PageId Id = getString "id" rdr |> PageId
WebLogId = getString "web_log_id" rdr |> WebLogId WebLogId = getString "web_log_id" rdr |> WebLogId
AuthorId = getString "author_id" rdr |> WebLogUserId AuthorId = getString "author_id" rdr |> WebLogUserId
Title = getString "title" rdr Title = getString "title" rdr
Permalink = toPermalink rdr Permalink = toPermalink rdr
PublishedOn = getDateTime "published_on" rdr PublishedOn = getInstant "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr UpdatedOn = getInstant "updated_on" rdr
IsInPageList = getBoolean "is_in_page_list" rdr IsInPageList = getBoolean "is_in_page_list" rdr
Template = tryString "template" rdr Template = tryString "template" rdr
Text = getString "page_text" 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 /// Create a post from the current row in the given data reader
let toPost rdr : Post = let toPost ser rdr : Post =
{ Post.empty with { Post.empty with
Id = getString "id" rdr |> PostId Id = getString "id" rdr |> PostId
WebLogId = getString "web_log_id" rdr |> WebLogId WebLogId = getString "web_log_id" rdr |> WebLogId
@ -175,38 +200,19 @@ module Map =
Status = getString "status" rdr |> PostStatus.parse Status = getString "status" rdr |> PostStatus.parse
Title = getString "title" rdr Title = getString "title" rdr
Permalink = toPermalink rdr Permalink = toPermalink rdr
PublishedOn = tryDateTime "published_on" rdr PublishedOn = tryInstant "published_on" rdr
UpdatedOn = getDateTime "updated_on" rdr UpdatedOn = getInstant "updated_on" rdr
Template = tryString "template" rdr Template = tryString "template" rdr
Text = getString "post_text" rdr Text = getString "post_text" rdr
Episode = Episode = tryString "episode" rdr |> Option.map (Utils.deserialize ser)
match tryString "media" rdr with Metadata = tryString "meta_items" rdr
| Some media -> |> Option.map (Utils.deserialize ser)
Some { |> Option.defaultValue []
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
} }
/// Create a revision from the current row in the given data reader /// Create a revision from the current row in the given data reader
let toRevision rdr : Revision = let toRevision rdr : Revision =
{ AsOf = getDateTime "as_of" rdr { AsOf = getInstant "as_of" rdr
Text = getString "revision_text" rdr |> MarkupText.parse Text = getString "revision_text" rdr |> MarkupText.parse
} }
@ -237,7 +243,7 @@ module Map =
else else
[||] [||]
{ Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr) { Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr)
UpdatedOn = getDateTime "updated_on" rdr UpdatedOn = getInstant "updated_on" rdr
Data = assetData Data = assetData
} }
@ -260,7 +266,7 @@ module Map =
{ Id = getString "id" rdr |> UploadId { Id = getString "id" rdr |> UploadId
WebLogId = getString "web_log_id" rdr |> WebLogId WebLogId = getString "web_log_id" rdr |> WebLogId
Path = getString "path" rdr |> Permalink Path = getString "path" rdr |> Permalink
UpdatedOn = getDateTime "updated_on" rdr UpdatedOn = getInstant "updated_on" rdr
Data = data Data = data
} }
@ -297,16 +303,12 @@ module Map =
LastName = getString "last_name" rdr LastName = getString "last_name" rdr
PreferredName = getString "preferred_name" rdr PreferredName = getString "preferred_name" rdr
PasswordHash = getString "password_hash" rdr PasswordHash = getString "password_hash" rdr
Salt = getGuid "salt" rdr
Url = tryString "url" rdr Url = tryString "url" rdr
AccessLevel = getString "access_level" rdr |> AccessLevel.parse AccessLevel = getString "access_level" rdr |> AccessLevel.parse
CreatedOn = getDateTime "created_on" rdr CreatedOn = getInstant "created_on" rdr
LastSeenOn = tryDateTime "last_seen_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 /// Add a web log ID parameter
let addWebLogId (cmd : SqliteCommand) webLogId = let addWebLogId (cmd : SqliteCommand) webLogId =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore

View File

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

View File

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

View File

@ -1,13 +1,14 @@
namespace MyWebLog.Data.SQLite namespace MyWebLog.Data.SQLite
open System
open System.Threading.Tasks open System.Threading.Tasks
open Microsoft.Data.Sqlite open Microsoft.Data.Sqlite
open MyWebLog open MyWebLog
open MyWebLog.Data open MyWebLog.Data
open Newtonsoft.Json
open NodaTime
/// SQLite myWebLog post data implementation /// SQLite myWebLog post data implementation
type SQLitePostData (conn : SqliteConnection) = type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS // SUPPORT FUNCTIONS
@ -19,35 +20,19 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status) cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status)
cmd.Parameters.AddWithValue ("@title", post.Title) cmd.Parameters.AddWithValue ("@title", post.Title)
cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink) cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink)
cmd.Parameters.AddWithValue ("@publishedOn", maybe post.PublishedOn) cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn)
cmd.Parameters.AddWithValue ("@updatedOn", post.UpdatedOn) cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn)
cmd.Parameters.AddWithValue ("@template", maybe post.Template) cmd.Parameters.AddWithValue ("@template", maybe post.Template)
cmd.Parameters.AddWithValue ("@text", post.Text) 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 ] |> ignore
/// Add parameters for episode INSERT or UPDATE statements /// Append category IDs and tags to a post
let addEpisodeParameters (cmd : SqliteCommand) (ep : Episode) = let appendPostCategoryAndTag (post : Post) = backgroundTask {
[ 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 {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) |> ignore 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" cmd.CommandText <- "SELECT tag FROM post_tag WHERE post_id = @id"
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let post = { post with Tags = toList (Map.getString "tag") rdr } return { 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 }
} }
/// Append revisions and permalinks to a post /// 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 /// 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) /// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks)
let findPostById postId webLogId = backgroundTask { let findPostById postId webLogId = backgroundTask {
@ -90,16 +74,16 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.CommandText <- $"{selectPost} WHERE p.id = @id" cmd.CommandText <- $"{selectPost} WHERE p.id = @id"
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
use! rdr = cmd.ExecuteReaderAsync () 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 /// Return a post with no revisions, prior permalinks, or text
let postWithoutText rdr = let postWithoutText rdr =
{ Map.toPost rdr with Text = "" } { toPost rdr with Text = "" }
/// Update a post's assigned categories /// Update a post's assigned categories
let updatePostCategories postId oldCats newCats = backgroundTask { 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 if List.isEmpty toDelete && List.isEmpty toAdd then
return () return ()
else else
@ -125,7 +109,7 @@ type SQLitePostData (conn : SqliteConnection) =
/// Update a post's assigned categories /// Update a post's assigned categories
let updatePostTags postId (oldTags : string list) newTags = backgroundTask { 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 if List.isEmpty toDelete && List.isEmpty toAdd then
return () return ()
else else
@ -149,89 +133,9 @@ type SQLitePostData (conn : SqliteConnection) =
|> ignore |> 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 /// Update a post's prior permalinks
let updatePostPermalinks postId oldLinks newLinks = backgroundTask { 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 if List.isEmpty toDelete && List.isEmpty toAdd then
return () return ()
else else
@ -257,7 +161,7 @@ type SQLitePostData (conn : SqliteConnection) =
/// Update a post's revisions /// Update a post's revisions
let updatePostRevisions postId oldRevs newRevs = backgroundTask { 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 if List.isEmpty toDelete && List.isEmpty toAdd then
return () return ()
else else
@ -265,7 +169,7 @@ type SQLitePostData (conn : SqliteConnection) =
let runCmd withText rev = backgroundTask { let runCmd withText rev = backgroundTask {
cmd.Parameters.Clear () cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.AddWithValue ("@asOf", rev.AsOf) cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf)
] |> ignore ] |> ignore
if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore
do! write cmd do! write cmd
@ -287,18 +191,18 @@ type SQLitePostData (conn : SqliteConnection) =
/// Add a post /// Add a post
let add post = backgroundTask { let add post = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <-
INSERT INTO post ( "INSERT INTO post (
id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text,
episode, meta_items
) VALUES ( ) 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 addPostParameters cmd post
do! write cmd do! write cmd
do! updatePostCategories post.Id [] post.CategoryIds do! updatePostCategories post.Id [] post.CategoryIds
do! updatePostTags post.Id [] post.Tags do! updatePostTags post.Id [] post.Tags
do! updatePostEpisode post
do! updatePostMeta post.Id [] post.Metadata
do! updatePostPermalinks post.Id [] post.PriorPermalinks do! updatePostPermalinks post.Id [] post.PriorPermalinks
do! updatePostRevisions post.Id [] post.Revisions do! updatePostRevisions post.Id [] post.Revisions
} }
@ -316,7 +220,7 @@ type SQLitePostData (conn : SqliteConnection) =
let findById postId webLogId = backgroundTask { let findById postId webLogId = backgroundTask {
match! findPostById postId webLogId with match! findPostById postId webLogId with
| Some post -> | Some post ->
let! post = appendPostCategoryTagAndMeta post let! post = appendPostCategoryAndTag post
return Some post return Some post
| None -> return None | None -> return None
} }
@ -329,7 +233,7 @@ type SQLitePostData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
if rdr.Read () then if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (Map.toPost rdr) let! post = appendPostCategoryAndTag (toPost rdr)
return Some post return Some post
else else
return None return None
@ -350,14 +254,13 @@ type SQLitePostData (conn : SqliteConnection) =
| Some _ -> | Some _ ->
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore
cmd.CommandText <- """ cmd.CommandText <-
DELETE FROM post_revision WHERE post_id = @id; "DELETE FROM post_revision WHERE post_id = @id;
DELETE FROM post_permalink 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_tag WHERE post_id = @id;
DELETE FROM post_category 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 do! write cmd
return true return true
| None -> return false | 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 /// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink permalinks webLogId = backgroundTask { let findCurrentPermalink permalinks webLogId = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks
cmd.CommandText <- $"
SELECT p.permalink SELECT p.permalink
FROM post p FROM post p
INNER JOIN post_permalink pp ON pp.post_id = p.id INNER JOIN post_permalink pp ON pp.post_id = p.id
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND pp.permalink IN (""" {linkSql}"
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})"
addWebLogId cmd webLogId addWebLogId cmd webLogId
cmd.Parameters.AddRange linkParams
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toPermalink rdr) else None return if rdr.Read () then Some (Map.toPermalink rdr) else None
} }
@ -390,9 +289,9 @@ type SQLitePostData (conn : SqliteConnection) =
addWebLogId cmd webLogId addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! posts = let! posts =
toList Map.toPost rdr toList toPost rdr
|> List.map (fun post -> backgroundTask { |> List.map (fun post -> backgroundTask {
let! post = appendPostCategoryTagAndMeta post let! post = appendPostCategoryAndTag post
return! appendPostRevisionsAndPermalinks post return! appendPostRevisionsAndPermalinks post
}) })
|> Task.WhenAll |> 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) /// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks)
let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask { let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- $""" let catSql, catParams = inClause "AND pc.category_id" "catId" CategoryId.toString categoryIds
cmd.CommandText <- $"
{selectPost} {selectPost}
INNER JOIN post_category pc ON pc.post_id = p.id INNER JOIN post_category pc ON pc.post_id = p.id
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND p.status = @status AND p.status = @status
AND pc.category_id IN (""" {catSql}
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})
ORDER BY published_on DESC ORDER BY published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
cmd.Parameters.AddRange catParams
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! posts = let! posts =
toList Map.toPost rdr toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll |> Task.WhenAll
return List.ofArray posts 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) /// Get a page of posts for the given web log (excludes text, revisions, and prior permalinks)
let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask { let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- $""" cmd.CommandText <- $"
{selectPost} {selectPost}
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
ORDER BY p.published_on DESC NULLS FIRST, p.updated_on 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 addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! posts = let! posts =
toList postWithoutText rdr toList postWithoutText rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll |> Task.WhenAll
return List.ofArray posts 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) /// Get a page of published posts for the given web log (excludes revisions and prior permalinks)
let findPageOfPublishedPosts webLogId pageNbr postsPerPage = backgroundTask { let findPageOfPublishedPosts webLogId pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- $""" cmd.CommandText <- $"
{selectPost} {selectPost}
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND p.status = @status AND p.status = @status
ORDER BY p.published_on DESC ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! posts = let! posts =
toList Map.toPost rdr toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll |> Task.WhenAll
return List.ofArray posts 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) /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = backgroundTask { let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- $""" cmd.CommandText <- $"
{selectPost} {selectPost}
INNER JOIN post_tag pt ON pt.post_id = p.id INNER JOIN post_tag pt ON pt.post_id = p.id
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND p.status = @status AND p.status = @status
AND pt.tag = @tag AND pt.tag = @tag
ORDER BY p.published_on DESC ORDER BY p.published_on DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
addWebLogId cmd webLogId addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@tag", tag) cmd.Parameters.AddWithValue ("@tag", tag)
] |> ignore ] |> ignore
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! posts = let! posts =
toList Map.toPost rdr toList toPost rdr
|> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post })
|> Task.WhenAll |> Task.WhenAll
return List.ofArray posts return List.ofArray posts
} }
/// Find the next newest and oldest post from a publish date for the given web log /// 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 () use cmd = conn.CreateCommand ()
cmd.CommandText <- $""" cmd.CommandText <- $"
{selectPost} {selectPost}
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND p.status = @status AND p.status = @status
AND p.published_on < @publishedOn AND p.published_on < @publishedOn
ORDER BY p.published_on DESC ORDER BY p.published_on DESC
LIMIT 1""" LIMIT 1"
addWebLogId cmd webLogId addWebLogId cmd webLogId
[ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published)
cmd.Parameters.AddWithValue ("@publishedOn", publishedOn) cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn)
] |> ignore ] |> ignore
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! older = backgroundTask { let! older = backgroundTask {
if rdr.Read () then if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr) let! post = appendPostCategoryAndTag (postWithoutText rdr)
return Some post return Some post
else else
return None return None
} }
do! rdr.CloseAsync () do! rdr.CloseAsync ()
cmd.CommandText <- $""" cmd.CommandText <- $"
{selectPost} {selectPost}
WHERE p.web_log_id = @webLogId WHERE p.web_log_id = @webLogId
AND p.status = @status AND p.status = @status
AND p.published_on > @publishedOn AND p.published_on > @publishedOn
ORDER BY p.published_on ORDER BY p.published_on
LIMIT 1""" LIMIT 1"
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
let! newer = backgroundTask { let! newer = backgroundTask {
if rdr.Read () then if rdr.Read () then
let! post = appendPostCategoryTagAndMeta (postWithoutText rdr) let! post = appendPostCategoryAndTag (postWithoutText rdr)
return Some post return Some post
else else
return None return None
@ -538,8 +432,8 @@ type SQLitePostData (conn : SqliteConnection) =
match! findFullById post.Id post.WebLogId with match! findFullById post.Id post.WebLogId with
| Some oldPost -> | Some oldPost ->
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <-
UPDATE post "UPDATE post
SET author_id = @authorId, SET author_id = @authorId,
status = @status, status = @status,
title = @title, title = @title,
@ -547,15 +441,15 @@ type SQLitePostData (conn : SqliteConnection) =
published_on = @publishedOn, published_on = @publishedOn,
updated_on = @updatedOn, updated_on = @updatedOn,
template = @template, template = @template,
post_text = @text post_text = @text,
episode = @episode,
meta_items = @metaItems
WHERE id = @id WHERE id = @id
AND web_log_id = @webLogId""" AND web_log_id = @webLogId"
addPostParameters cmd post addPostParameters cmd post
do! write cmd do! write cmd
do! updatePostCategories post.Id oldPost.CategoryIds post.CategoryIds do! updatePostCategories post.Id oldPost.CategoryIds post.CategoryIds
do! updatePostTags post.Id oldPost.Tags post.Tags 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! updatePostPermalinks post.Id oldPost.PriorPermalinks post.PriorPermalinks
do! updatePostRevisions post.Id oldPost.Revisions post.Revisions do! updatePostRevisions post.Id oldPost.Revisions post.Revisions
| None -> return () | 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 /// Find any tag mappings in a list of tags for the given web log
let findMappingForTags (tags : string list) webLogId = backgroundTask { let findMappingForTags (tags : string list) webLogId = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ let mapSql, mapParams = inClause "AND tag" "tag" id tags
cmd.CommandText <- $"
SELECT * SELECT *
FROM tag_map FROM tag_map
WHERE web_log_id = @webLogId WHERE web_log_id = @webLogId
AND tag IN (""" {mapSql}"
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})"
addWebLogId cmd webLogId addWebLogId cmd webLogId
cmd.Parameters.AddRange mapParams
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toTagMap rdr return toList Map.toTagMap rdr
} }
@ -71,19 +67,19 @@ type SQLiteTagMapData (conn : SqliteConnection) =
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
match! findById tagMap.Id tagMap.WebLogId with match! findById tagMap.Id tagMap.WebLogId with
| Some _ -> | Some _ ->
cmd.CommandText <- """ cmd.CommandText <-
UPDATE tag_map "UPDATE tag_map
SET tag = @tag, SET tag = @tag,
url_value = @urlValue url_value = @urlValue
WHERE id = @id WHERE id = @id
AND web_log_id = @webLogId""" AND web_log_id = @webLogId"
| None -> | None ->
cmd.CommandText <- """ cmd.CommandText <-
INSERT INTO tag_map ( "INSERT INTO tag_map (
id, web_log_id, tag, url_value id, web_log_id, tag, url_value
) VALUES ( ) VALUES (
@id, @webLogId, @tag, @urlValue @id, @webLogId, @tag, @urlValue
)""" )"
addWebLogId cmd tagMap.WebLogId addWebLogId cmd tagMap.WebLogId
[ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id) [ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id)
cmd.Parameters.AddWithValue ("@tag", tagMap.Tag) cmd.Parameters.AddWithValue ("@tag", tagMap.Tag)

View File

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

View File

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

View File

@ -4,12 +4,13 @@ open System.Threading.Tasks
open Microsoft.Data.Sqlite open Microsoft.Data.Sqlite
open MyWebLog open MyWebLog
open MyWebLog.Data open MyWebLog.Data
open Newtonsoft.Json
// The web log podcast insert loop is not statically compilable; this is OK // The web log podcast insert loop is not statically compilable; this is OK
#nowarn "3511" #nowarn "3511"
/// SQLite myWebLog web log data implementation /// SQLite myWebLog web log data implementation
type SQLiteWebLogData (conn : SqliteConnection) = type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) =
// SUPPORT FUNCTIONS // SUPPORT FUNCTIONS
@ -45,40 +46,22 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId)
cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source) cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source)
cmd.Parameters.AddWithValue ("@path", Permalink.toString feed.Path) 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 ] |> ignore
/// Add parameters for podcast INSERT or UPDATE statements /// Shorthand to map a data reader to a custom feed
let addPodcastParameters (cmd : SqliteCommand) feedId (podcast : PodcastOptions) = let toCustomFeed =
[ cmd.Parameters.AddWithValue ("@feedId", CustomFeedId.toString feedId) Map.toCustomFeed ser
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
/// Get the current custom feeds for a web log /// Get the current custom feeds for a web log
let getCustomFeeds (webLog : WebLog) = backgroundTask { let getCustomFeeds (webLog : WebLog) = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <- "SELECT * FROM web_log_feed WHERE web_log_id = @webLogId"
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"""
addWebLogId cmd webLog.Id addWebLogId cmd webLog.Id
use! rdr = cmd.ExecuteReaderAsync () use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toCustomFeed rdr return toList toCustomFeed rdr
} }
/// Append custom feeds to a web log /// Append custom feeds to a web log
@ -87,27 +70,10 @@ type SQLiteWebLogData (conn : SqliteConnection) =
return { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } } 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 /// Update the custom feeds for a web log
let updateCustomFeeds (webLog : WebLog) = backgroundTask { let updateCustomFeeds (webLog : WebLog) = backgroundTask {
let! feeds = getCustomFeeds webLog 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 toId (feed : CustomFeed) = feed.Id
let toUpdate = let toUpdate =
webLog.Rss.CustomFeeds webLog.Rss.CustomFeeds
@ -117,9 +83,7 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.Add ("@id", SqliteType.Text) |> ignore cmd.Parameters.Add ("@id", SqliteType.Text) |> ignore
toDelete toDelete
|> List.map (fun it -> backgroundTask { |> List.map (fun it -> backgroundTask {
cmd.CommandText <- """ cmd.CommandText <- "DELETE FROM web_log_feed WHERE id = @id"
DELETE FROM web_log_feed_podcast WHERE feed_id = @id;
DELETE FROM web_log_feed WHERE id = @id"""
cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id
do! write cmd do! write cmd
}) })
@ -128,68 +92,30 @@ type SQLiteWebLogData (conn : SqliteConnection) =
cmd.Parameters.Clear () cmd.Parameters.Clear ()
toAdd toAdd
|> List.map (fun it -> backgroundTask { |> List.map (fun it -> backgroundTask {
cmd.CommandText <- """ cmd.CommandText <-
INSERT INTO web_log_feed ( "INSERT INTO web_log_feed (
id, web_log_id, source, path id, web_log_id, source, path, podcast
) VALUES ( ) VALUES (
@id, @webLogId, @source, @path @id, @webLogId, @source, @path, @podcast
)""" )"
cmd.Parameters.Clear () cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it addCustomFeedParameters cmd webLog.Id it
do! write cmd do! write cmd
match it.Podcast with
| Some podcast -> do! addPodcast it.Id podcast
| None -> ()
}) })
|> Task.WhenAll |> Task.WhenAll
|> ignore |> ignore
toUpdate toUpdate
|> List.map (fun it -> backgroundTask { |> List.map (fun it -> backgroundTask {
cmd.CommandText <- """ cmd.CommandText <-
UPDATE web_log_feed "UPDATE web_log_feed
SET source = @source, SET source = @source,
path = @path path = @path,
podcast = @podcast
WHERE id = @id WHERE id = @id
AND web_log_id = @webLogId""" AND web_log_id = @webLogId"
cmd.Parameters.Clear () cmd.Parameters.Clear ()
addCustomFeedParameters cmd webLog.Id it addCustomFeedParameters cmd webLog.Id it
do! write cmd 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 |> Task.WhenAll
|> ignore |> ignore
@ -200,14 +126,14 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Add a web log /// Add a web log
let add webLog = backgroundTask { let add webLog = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <-
INSERT INTO web_log ( "INSERT INTO web_log (
id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx, 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 uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright
) VALUES ( ) VALUES (
@id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx, @id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx,
@uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright @uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright
)""" )"
addWebLogParameters cmd webLog addWebLogParameters cmd webLog
do! write cmd do! write cmd
do! updateCustomFeeds webLog do! updateCustomFeeds webLog
@ -232,26 +158,22 @@ type SQLiteWebLogData (conn : SqliteConnection) =
let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)" let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)"
let postSubQuery = subQuery "post" let postSubQuery = subQuery "post"
let pageSubQuery = subQuery "page" let pageSubQuery = subQuery "page"
cmd.CommandText <- $""" cmd.CommandText <- $"
DELETE FROM post_comment WHERE post_id IN {postSubQuery}; DELETE FROM post_comment WHERE post_id IN {postSubQuery};
DELETE FROM post_revision 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_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_tag WHERE post_id IN {postSubQuery};
DELETE FROM post_category 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 post WHERE web_log_id = @webLogId;
DELETE FROM page_revision WHERE page_id IN {pageSubQuery}; DELETE FROM page_revision WHERE page_id IN {pageSubQuery};
DELETE FROM page_permalink 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 page WHERE web_log_id = @webLogId;
DELETE FROM category WHERE web_log_id = @webLogId; DELETE FROM category WHERE web_log_id = @webLogId;
DELETE FROM tag_map WHERE web_log_id = @webLogId; DELETE FROM tag_map WHERE web_log_id = @webLogId;
DELETE FROM upload 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_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_feed WHERE web_log_id = @webLogId;
DELETE FROM web_log WHERE id = @webLogId""" DELETE FROM web_log WHERE id = @webLogId"
do! write cmd do! write cmd
} }
@ -284,8 +206,8 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Update settings for a web log /// Update settings for a web log
let updateSettings webLog = backgroundTask { let updateSettings webLog = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <-
UPDATE web_log "UPDATE web_log
SET name = @name, SET name = @name,
slug = @slug, slug = @slug,
subtitle = @subtitle, subtitle = @subtitle,
@ -302,7 +224,7 @@ type SQLiteWebLogData (conn : SqliteConnection) =
is_category_enabled = @isCategoryEnabled, is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled, is_tag_enabled = @isTagEnabled,
copyright = @copyright copyright = @copyright
WHERE id = @id""" WHERE id = @id"
addWebLogParameters cmd webLog addWebLogParameters cmd webLog
do! write cmd do! write cmd
} }
@ -310,15 +232,15 @@ type SQLiteWebLogData (conn : SqliteConnection) =
/// Update RSS options for a web log /// Update RSS options for a web log
let updateRssOptions webLog = backgroundTask { let updateRssOptions webLog = backgroundTask {
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
cmd.CommandText <- """ cmd.CommandText <-
UPDATE web_log "UPDATE web_log
SET is_feed_enabled = @isFeedEnabled, SET is_feed_enabled = @isFeedEnabled,
feed_name = @feedName, feed_name = @feedName,
items_in_feed = @itemsInFeed, items_in_feed = @itemsInFeed,
is_category_enabled = @isCategoryEnabled, is_category_enabled = @isCategoryEnabled,
is_tag_enabled = @isTagEnabled, is_tag_enabled = @isTagEnabled,
copyright = @copyright copyright = @copyright
WHERE id = @id""" WHERE id = @id"
addWebLogRssParameters cmd webLog addWebLogRssParameters cmd webLog
cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore
do! write cmd do! write cmd

View File

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

View File

@ -2,90 +2,53 @@ namespace MyWebLog.Data
open Microsoft.Data.Sqlite open Microsoft.Data.Sqlite
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
open MyWebLog
open MyWebLog.Data.SQLite open MyWebLog.Data.SQLite
open Newtonsoft.Json
open NodaTime
/// SQLite myWebLog data implementation /// 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 () use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table"
cmd.Parameters.AddWithValue ("@table", table) |> ignore let! tables = backgroundTask {
let! count = count cmd cmd.CommandText <- "SELECT name FROM sqlite_master WHERE type = 'table'"
return count = 1 let! rdr = cmd.ExecuteReaderAsync ()
let mutable tableList = []
while rdr.Read() do
tableList <- Map.getString "name" rdr :: tableList
do! rdr.CloseAsync ()
return tableList
} }
let needsTable table =
/// The connection for this instance not (List.contains table tables)
member _.Conn = conn seq {
/// 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 ()
// Theme tables // Theme tables
match! tableExists "theme" with if needsTable "theme" then
| true -> () "CREATE TABLE theme (
| false ->
log.LogInformation "Creating theme table..."
cmd.CommandText <- """
CREATE TABLE theme (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
name TEXT NOT NULL, name TEXT NOT NULL,
version TEXT NOT NULL)""" version TEXT NOT NULL)"
do! write cmd if needsTable "theme_template" then
match! tableExists "theme_template" with "CREATE TABLE theme_template (
| true -> ()
| false ->
log.LogInformation "Creating theme_template table..."
cmd.CommandText <- """
CREATE TABLE theme_template (
theme_id TEXT NOT NULL REFERENCES theme (id), theme_id TEXT NOT NULL REFERENCES theme (id),
name TEXT NOT NULL, name TEXT NOT NULL,
template TEXT NOT NULL, template TEXT NOT NULL,
PRIMARY KEY (theme_id, name))""" PRIMARY KEY (theme_id, name))"
do! write cmd if needsTable "theme_asset" then
match! tableExists "theme_asset" with "CREATE TABLE theme_asset (
| true -> ()
| false ->
log.LogInformation "Creating theme_asset table..."
cmd.CommandText <- """
CREATE TABLE theme_asset (
theme_id TEXT NOT NULL REFERENCES theme (id), theme_id TEXT NOT NULL REFERENCES theme (id),
path TEXT NOT NULL, path TEXT NOT NULL,
updated_on TEXT NOT NULL, updated_on TEXT NOT NULL,
data BLOB NOT NULL, data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))""" PRIMARY KEY (theme_id, path))"
do! write cmd
// Web log tables // Web log tables
match! tableExists "web_log" with if needsTable "web_log" then
| true -> () "CREATE TABLE web_log (
| false ->
log.LogInformation "Creating web_log table..."
cmd.CommandText <- """
CREATE TABLE web_log (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
name TEXT NOT NULL, name TEXT NOT NULL,
slug 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_category_enabled INTEGER NOT NULL DEFAULT 0,
is_tag_enabled INTEGER NOT NULL DEFAULT 0, is_tag_enabled INTEGER NOT NULL DEFAULT 0,
copyright TEXT); copyright TEXT);
CREATE INDEX web_log_theme_idx ON web_log (theme_id)""" CREATE INDEX web_log_theme_idx ON web_log (theme_id)"
do! write cmd if needsTable "web_log_feed" then
match! tableExists "web_log_feed" with "CREATE TABLE web_log_feed (
| true -> ()
| false ->
log.LogInformation "Creating web_log_feed table..."
cmd.CommandText <- """
CREATE TABLE web_log_feed (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
source TEXT NOT NULL, source TEXT NOT NULL,
path TEXT NOT NULL); path TEXT NOT NULL,
CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)""" podcast TEXT);
do! write cmd CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)"
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
// Category table // Category table
match! tableExists "category" with if needsTable "category" then
| true -> () "CREATE TABLE category (
| false ->
log.LogInformation "Creating category table..."
cmd.CommandText <- """
CREATE TABLE category (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
name TEXT NOT NULL, name TEXT NOT NULL,
slug TEXT NOT NULL, slug TEXT NOT NULL,
description TEXT, description TEXT,
parent_id TEXT); parent_id TEXT);
CREATE INDEX category_web_log_idx ON category (web_log_id)""" CREATE INDEX category_web_log_idx ON category (web_log_id)"
do! write cmd
// Web log user table // Web log user table
match! tableExists "web_log_user" with if needsTable "web_log_user" then
| true -> () "CREATE TABLE web_log_user (
| false ->
log.LogInformation "Creating web_log_user table..."
cmd.CommandText <- """
CREATE TABLE web_log_user (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
email TEXT NOT NULL, email TEXT NOT NULL,
@ -172,22 +97,16 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
last_name TEXT NOT NULL, last_name TEXT NOT NULL,
preferred_name TEXT NOT NULL, preferred_name TEXT NOT NULL,
password_hash TEXT NOT NULL, password_hash TEXT NOT NULL,
salt TEXT NOT NULL,
url TEXT, url TEXT,
access_level TEXT NOT NULL, access_level TEXT NOT NULL,
created_on TEXT NOT NULL, created_on TEXT NOT NULL,
last_seen_on TEXT); last_seen_on TEXT);
CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id); 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)""" CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)"
do! write cmd
// Page tables // Page tables
match! tableExists "page" with if needsTable "page" then
| true -> () "CREATE TABLE page (
| false ->
log.LogInformation "Creating page table..."
cmd.CommandText <- """
CREATE TABLE page (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (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, updated_on TEXT NOT NULL,
is_in_page_list INTEGER NOT NULL DEFAULT 0, is_in_page_list INTEGER NOT NULL DEFAULT 0,
template TEXT, 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_web_log_idx ON page (web_log_id);
CREATE INDEX page_author_idx ON page (author_id); CREATE INDEX page_author_idx ON page (author_id);
CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)""" CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)"
do! write cmd if needsTable "page_permalink" then
match! tableExists "page_meta" with "CREATE TABLE page_permalink (
| 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 (
page_id TEXT NOT NULL REFERENCES page (id), page_id TEXT NOT NULL REFERENCES page (id),
permalink TEXT NOT NULL, permalink TEXT NOT NULL,
PRIMARY KEY (page_id, permalink))""" PRIMARY KEY (page_id, permalink))"
do! write cmd if needsTable "page_revision" then
match! tableExists "page_revision" with "CREATE TABLE page_revision (
| true -> ()
| false ->
log.LogInformation "Creating page_revision table..."
cmd.CommandText <- """
CREATE TABLE page_revision (
page_id TEXT NOT NULL REFERENCES page (id), page_id TEXT NOT NULL REFERENCES page (id),
as_of TEXT NOT NULL, as_of TEXT NOT NULL,
revision_text TEXT NOT NULL, revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))""" PRIMARY KEY (page_id, as_of))"
do! write cmd
// Post tables // Post tables
match! tableExists "post" with if needsTable "post" then
| true -> () "CREATE TABLE post (
| false ->
log.LogInformation "Creating post table..."
cmd.CommandText <- """
CREATE TABLE post (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
author_id TEXT NOT NULL REFERENCES web_log_user (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, published_on TEXT,
updated_on TEXT NOT NULL, updated_on TEXT NOT NULL,
template TEXT, 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_web_log_idx ON post (web_log_id);
CREATE INDEX post_author_idx ON post (author_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_status_idx ON post (web_log_id, status, updated_on);
CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)""" CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)"
do! write cmd if needsTable "post_category" then
match! tableExists "post_category" with "CREATE TABLE post_category (
| true -> ()
| false ->
log.LogInformation "Creating post_category table..."
cmd.CommandText <- """
CREATE TABLE post_category (
post_id TEXT NOT NULL REFERENCES post (id), post_id TEXT NOT NULL REFERENCES post (id),
category_id TEXT NOT NULL REFERENCES category (id), category_id TEXT NOT NULL REFERENCES category (id),
PRIMARY KEY (post_id, category_id)); PRIMARY KEY (post_id, category_id));
CREATE INDEX post_category_category_idx ON post_category (category_id)""" CREATE INDEX post_category_category_idx ON post_category (category_id)"
do! write cmd if needsTable "post_tag" then
match! tableExists "post_episode" with "CREATE TABLE post_tag (
| 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 (
post_id TEXT NOT NULL REFERENCES post (id), post_id TEXT NOT NULL REFERENCES post (id),
tag TEXT NOT NULL, tag TEXT NOT NULL,
PRIMARY KEY (post_id, tag))""" PRIMARY KEY (post_id, tag))"
do! write cmd if needsTable "post_permalink" then
match! tableExists "post_meta" with "CREATE TABLE post_permalink (
| 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 (
post_id TEXT NOT NULL REFERENCES post (id), post_id TEXT NOT NULL REFERENCES post (id),
permalink TEXT NOT NULL, permalink TEXT NOT NULL,
PRIMARY KEY (post_id, permalink))""" PRIMARY KEY (post_id, permalink))"
do! write cmd if needsTable "post_revision" then
match! tableExists "post_revision" with "CREATE TABLE post_revision (
| true -> ()
| false ->
log.LogInformation "Creating post_revision table..."
cmd.CommandText <- """
CREATE TABLE post_revision (
post_id TEXT NOT NULL REFERENCES post (id), post_id TEXT NOT NULL REFERENCES post (id),
as_of TEXT NOT NULL, as_of TEXT NOT NULL,
revision_text TEXT NOT NULL, revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))""" PRIMARY KEY (post_id, as_of))"
do! write cmd if needsTable "post_comment" then
match! tableExists "post_comment" with "CREATE TABLE post_comment (
| true -> ()
| false ->
log.LogInformation "Creating post_comment table..."
cmd.CommandText <- """
CREATE TABLE post_comment (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
post_id TEXT NOT NULL REFERENCES post(id), post_id TEXT NOT NULL REFERENCES post(id),
in_reply_to_id TEXT, in_reply_to_id TEXT,
@ -350,36 +185,397 @@ type SQLiteData (conn : SqliteConnection, log : ILogger<SQLiteData>) =
status TEXT NOT NULL, status TEXT NOT NULL,
posted_on TEXT NOT NULL, posted_on TEXT NOT NULL,
comment_text TEXT NOT NULL); comment_text TEXT NOT NULL);
CREATE INDEX post_comment_post_idx ON post_comment (post_id)""" CREATE INDEX post_comment_post_idx ON post_comment (post_id)"
do! write cmd
// Tag map table // Tag map table
match! tableExists "tag_map" with if needsTable "tag_map" then
| true -> () "CREATE TABLE tag_map (
| false ->
log.LogInformation "Creating tag_map table..."
cmd.CommandText <- """
CREATE TABLE tag_map (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
tag TEXT NOT NULL, tag TEXT NOT NULL,
url_value TEXT NOT NULL); url_value TEXT NOT NULL);
CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)""" CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)"
do! write cmd
// Uploaded file table // Uploaded file table
match! tableExists "upload" with if needsTable "upload" then
| true -> () "CREATE TABLE upload (
| false ->
log.LogInformation "Creating upload table..."
cmd.CommandText <- """
CREATE TABLE upload (
id TEXT PRIMARY KEY, id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL REFERENCES web_log (id), web_log_id TEXT NOT NULL REFERENCES web_log (id),
path TEXT NOT NULL, path TEXT NOT NULL,
updated_on TEXT NOT NULL, updated_on TEXT NOT NULL,
data BLOB NOT NULL); data BLOB NOT NULL);
CREATE INDEX upload_web_log_idx ON upload (web_log_id); 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 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
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// The current database version
let currentDbVersion = "v2-rc2"
/// Create a category hierarchy from the given list of categories /// Create a category hierarchy from the given list of categories
let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq { let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do 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) 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 System
open MyWebLog open MyWebLog
open NodaTime
/// A category under which a post may be identified /// A category under which a post may be identified
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
@ -64,7 +65,7 @@ type Comment =
Status : CommentStatus Status : CommentStatus
/// When the comment was posted /// When the comment was posted
PostedOn : DateTime PostedOn : Instant
/// The text of the comment /// The text of the comment
Text : string Text : string
@ -82,7 +83,7 @@ module Comment =
Email = "" Email = ""
Url = None Url = None
Status = Pending Status = Pending
PostedOn = DateTime.UtcNow PostedOn = Noda.epoch
Text = "" Text = ""
} }
@ -106,10 +107,10 @@ type Page =
Permalink : Permalink Permalink : Permalink
/// When this page was published /// When this page was published
PublishedOn : DateTime PublishedOn : Instant
/// When this page was last updated /// When this page was last updated
UpdatedOn : DateTime UpdatedOn : Instant
/// Whether this page shows as part of the web log's navigation /// Whether this page shows as part of the web log's navigation
IsInPageList : bool IsInPageList : bool
@ -140,8 +141,8 @@ module Page =
AuthorId = WebLogUserId.empty AuthorId = WebLogUserId.empty
Title = "" Title = ""
Permalink = Permalink.empty Permalink = Permalink.empty
PublishedOn = DateTime.MinValue PublishedOn = Noda.epoch
UpdatedOn = DateTime.MinValue UpdatedOn = Noda.epoch
IsInPageList = false IsInPageList = false
Template = None Template = None
Text = "" Text = ""
@ -173,10 +174,10 @@ type Post =
Permalink : Permalink Permalink : Permalink
/// The instant on which the post was originally published /// The instant on which the post was originally published
PublishedOn : DateTime option PublishedOn : Instant option
/// The instant on which the post was last updated /// The instant on which the post was last updated
UpdatedOn : DateTime UpdatedOn : Instant
/// The template to use in displaying the post /// The template to use in displaying the post
Template : string option Template : string option
@ -215,7 +216,7 @@ module Post =
Title = "" Title = ""
Permalink = Permalink.empty Permalink = Permalink.empty
PublishedOn = None PublishedOn = None
UpdatedOn = DateTime.MinValue UpdatedOn = Noda.epoch
Text = "" Text = ""
Template = None Template = None
CategoryIds = [] CategoryIds = []
@ -288,7 +289,7 @@ type ThemeAsset =
Id : ThemeAssetId Id : ThemeAssetId
/// The updated date (set from the file date from the ZIP archive) /// The updated date (set from the file date from the ZIP archive)
UpdatedOn : DateTime UpdatedOn : Instant
/// The data for the asset /// The data for the asset
Data : byte[] Data : byte[]
@ -300,7 +301,7 @@ module ThemeAsset =
/// An empty theme asset /// An empty theme asset
let empty = let empty =
{ Id = ThemeAssetId (ThemeId "", "") { Id = ThemeAssetId (ThemeId "", "")
UpdatedOn = DateTime.MinValue UpdatedOn = Noda.epoch
Data = [||] Data = [||]
} }
@ -317,7 +318,7 @@ type Upload =
Path : Permalink Path : Permalink
/// The updated date/time for this upload /// The updated date/time for this upload
UpdatedOn : DateTime UpdatedOn : Instant
/// The data for the upload /// The data for the upload
Data : byte[] Data : byte[]
@ -331,7 +332,7 @@ module Upload =
{ Id = UploadId.empty { Id = UploadId.empty
WebLogId = WebLogId.empty WebLogId = WebLogId.empty
Path = Permalink.empty Path = Permalink.empty
UpdatedOn = DateTime.MinValue UpdatedOn = Noda.epoch
Data = [||] Data = [||]
} }
@ -410,10 +411,11 @@ module WebLog =
let _, leadPath = hostAndPath webLog let _, leadPath = hostAndPath webLog
$"{leadPath}/{Permalink.toString permalink}" $"{leadPath}/{Permalink.toString permalink}"
/// Convert a UTC date/time to the web log's local date/time /// Convert an Instant (UTC reference) to the web log's local date/time
let localTime webLog (date : DateTime) = let localTime webLog (date : Instant) =
TimeZoneInfo.ConvertTimeFromUtc match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with
(DateTime (date.Ticks, DateTimeKind.Utc), TimeZoneInfo.FindSystemTimeZoneById webLog.TimeZone) | null -> date.ToDateTimeUtc ()
| tz -> date.InZone(tz).ToDateTimeUnspecified ()
/// A user of the web log /// A user of the web log
@ -440,9 +442,6 @@ type WebLogUser =
/// The hash of the user's password /// The hash of the user's password
PasswordHash : string PasswordHash : string
/// Salt used to calculate the user's password hash
Salt : Guid
/// The URL of the user's personal site /// The URL of the user's personal site
Url : string option Url : string option
@ -450,10 +449,10 @@ type WebLogUser =
AccessLevel : AccessLevel AccessLevel : AccessLevel
/// When the user was created /// When the user was created
CreatedOn : DateTime CreatedOn : Instant
/// When the user last logged on /// When the user last logged on
LastSeenOn : DateTime option LastSeenOn : Instant option
} }
/// Functions to support web log users /// Functions to support web log users
@ -468,10 +467,9 @@ module WebLogUser =
LastName = "" LastName = ""
PreferredName = "" PreferredName = ""
PasswordHash = "" PasswordHash = ""
Salt = Guid.Empty
Url = None Url = None
AccessLevel = Author AccessLevel = Author
CreatedOn = DateTime.UnixEpoch CreatedOn = Noda.epoch
LastSeenOn = None LastSeenOn = None
} }

View File

@ -7,9 +7,10 @@
</ItemGroup> </ItemGroup>
<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 Update="FSharp.Core" Version="6.0.5" />
<PackageReference Include="Markdown.ColorCode" Version="1.0.1" /> <PackageReference Include="Markdown.ColorCode" Version="1.0.1" />
<PackageReference Include="NodaTime" Version="3.1.2" />
</ItemGroup> </ItemGroup>
</Project> </Project>

View File

@ -1,6 +1,7 @@
namespace MyWebLog namespace MyWebLog
open System open System
open NodaTime
/// Support functions for domain definition /// Support functions for domain definition
[<AutoOpen>] [<AutoOpen>]
@ -12,6 +13,29 @@ module private Helpers =
Convert.ToBase64String(Guid.NewGuid().ToByteArray ()).Replace('/', '_').Replace('+', '-').Substring (0, 22) 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 /// A user's access level
type AccessLevel = type AccessLevel =
/// The user may create and publish posts and edit the ones they have created /// 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") | x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating")
open NodaTime.Text
/// A podcast episode /// A podcast episode
type Episode = type Episode =
{ /// The URL to the media file for the episode (may be permalink) { /// The URL to the media file for the episode (may be permalink)
@ -146,7 +172,7 @@ type Episode =
Length : int64 Length : int64
/// The duration of the episode /// The duration of the episode
Duration : TimeSpan option Duration : Duration option
/// The media type of the file (overrides podcast default if present) /// The media type of the file (overrides podcast default if present)
MediaType : string option MediaType : string option
@ -215,6 +241,10 @@ module Episode =
EpisodeDescription = None EpisodeDescription = None
} }
/// Format a duration for an episode
let formatDuration ep =
ep.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format)
open Markdig open Markdig
open Markdown.ColorCode open Markdown.ColorCode
@ -269,12 +299,11 @@ module MetaItem =
let empty = let empty =
{ Name = ""; Value = "" } { Name = ""; Value = "" }
/// A revision of a page or post /// A revision of a page or post
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type Revision = type Revision =
{ /// When this revision was saved { /// When this revision was saved
AsOf : DateTime AsOf : Instant
/// The text of the revision /// The text of the revision
Text : MarkupText Text : MarkupText
@ -285,7 +314,7 @@ module Revision =
/// An empty revision /// An empty revision
let empty = let empty =
{ AsOf = DateTime.UtcNow { AsOf = Noda.epoch
Text = Html "" Text = Html ""
} }

View File

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

View File

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

View File

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

View File

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

View File

@ -419,10 +419,11 @@ let getCategoryIds slug ctx =
open System open System
open System.Globalization open System.Globalization
open NodaTime
/// Parse a date/time to UTC /// Parse a date/time to UTC
let parseToUtc (date : string) = 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.DependencyInjection
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging

View File

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

View File

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

View File

@ -94,7 +94,7 @@ module Asset =
| Some asset -> | Some asset ->
match Upload.checkModified asset.UpdatedOn ctx with match Upload.checkModified asset.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx | 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 | None -> return! Error.notFound next ctx
} }

View File

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

View File

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

View File

@ -4,6 +4,7 @@ open System
open System.IO open System.IO
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data open MyWebLog.Data
open NodaTime
/// Create the web log information /// Create the web log information
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
@ -41,10 +42,8 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
} }
// Create the admin user // Create the admin user
let salt = Guid.NewGuid () let now = Noda.now ()
let now = DateTime.UtcNow let user =
do! data.WebLogUser.Add
{ WebLogUser.empty with { WebLogUser.empty with
Id = userId Id = userId
WebLogId = webLogId WebLogId = webLogId
@ -52,11 +51,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
FirstName = "Admin" FirstName = "Admin"
LastName = "User" LastName = "User"
PreferredName = "Admin" PreferredName = "Admin"
PasswordHash = Handlers.User.hashedPassword args[4] args[3] salt
Salt = salt
AccessLevel = accessLevel AccessLevel = accessLevel
CreatedOn = now CreatedOn = now
} }
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page // Create the default home page
do! data.Page.Add do! data.Page.Add
@ -155,7 +153,6 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
/// Back up a web log's data /// Back up a web log's data
module Backup = module Backup =
open System.Threading.Tasks
open MyWebLog.Converters open MyWebLog.Converters
open Newtonsoft.Json open Newtonsoft.Json
@ -165,7 +162,7 @@ module Backup =
Id : ThemeAssetId Id : ThemeAssetId
/// The updated date for this asset /// The updated date for this asset
UpdatedOn : DateTime UpdatedOn : Instant
/// The data for this asset, base-64 encoded /// The data for this asset, base-64 encoded
Data : string Data : string
@ -197,7 +194,7 @@ module Backup =
Path : Permalink Path : Permalink
/// The date/time this upload was last updated (file time) /// The date/time this upload was last updated (file time)
UpdatedOn : DateTime UpdatedOn : Instant
/// The data for the upload, base-64 encoded /// The data for the upload, base-64 encoded
Data : string Data : string
@ -251,10 +248,9 @@ module Backup =
Uploads : EncodedUpload list Uploads : EncodedUpload list
} }
/// Create a JSON serializer (uses RethinkDB data implementation's JSON converters) /// Create a JSON serializer
let private getSerializer prettyOutput = let private getSerializer prettyOutput =
let serializer = JsonSerializer.CreateDefault () let serializer = Json.configure (JsonSerializer.CreateDefault ())
Json.all () |> Seq.iter serializer.Converters.Add
if prettyOutput then serializer.Formatting <- Formatting.Indented if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer serializer
@ -382,7 +378,8 @@ module Backup =
printfn "" printfn ""
printfn "- Importing theme..." printfn "- Importing theme..."
do! data.Theme.Save restore.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 // Restore web log data
@ -393,18 +390,19 @@ module Backup =
do! data.WebLogUser.Restore restore.Users do! data.WebLogUser.Restore restore.Users
printfn "- Restoring categories and tag mappings..." printfn "- Restoring categories and tag mappings..."
do! data.TagMap.Restore restore.TagMappings if not (List.isEmpty restore.TagMappings) then do! data.TagMap.Restore restore.TagMappings
do! data.Category.Restore restore.Categories if not (List.isEmpty restore.Categories) then do! data.Category.Restore restore.Categories
printfn "- Restoring pages..." 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..." 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 // TODO: comments not yet implemented
printfn "- Restoring uploads..." printfn "- Restoring uploads..."
if not (List.isEmpty restore.Uploads) then
do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload) do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload)
displayStats "Restored for <>NAME<>:" restore.WebLog restore 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> ()) | 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData> ())
| _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]" | _ -> 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 System
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data open MyWebLog.Data
open Newtonsoft.Json
open Npgsql
/// Logic to obtain a data connection and implementation based on configured values /// Logic to obtain a data connection and implementation based on configured values
module DataImplementation = module DataImplementation =
open MyWebLog.Converters open MyWebLog.Converters
// open Npgsql.Logging
open RethinkDb.Driver.FSharp open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
@ -43,23 +46,29 @@ module DataImplementation =
let await it = (Async.AwaitTask >> Async.RunSynchronously) it let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr = let createSQLite connStr : IData =
let log = sp.GetRequiredService<ILogger<SQLiteData>> () let log = sp.GetRequiredService<ILogger<SQLiteData>> ()
let conn = new SqliteConnection (connStr) let conn = new SqliteConnection (connStr)
log.LogInformation $"Using SQLite database {conn.DataSource}" log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn) await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log) SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ()))
if hasConnStr "SQLite" then if hasConnStr "SQLite" then
upcast createSQLite (connStr "SQLite") createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>> () 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 rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log) 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 else
upcast createSQLite "Data Source=./myweblog.db;Cache=Shared" createSQLite "Data Source=./myweblog.db;Cache=Shared"
open System.Threading.Tasks open System.Threading.Tasks
@ -76,6 +85,7 @@ let showHelp () =
printfn "init Initializes a new web log" printfn "init Initializes a new web log"
printfn "load-theme Load a theme" printfn "load-theme Load a theme"
printfn "restore Restore a JSON file backup (prompt before overwriting)" 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 "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " " printfn " "
printfn "For more information on a particular command, run it with no options." 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.Authentication.Cookies
open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite open NeoSmart.Caching.Sqlite
open RethinkDB.DistributedCache open RethinkDB.DistributedCache
@ -110,6 +121,7 @@ let rec main args =
let sp = builder.Services.BuildServiceProvider () let sp = builder.Services.BuildServiceProvider ()
let data = DataImplementation.get sp let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task { task {
do! data.StartUp () do! data.StartUp ()
@ -121,23 +133,36 @@ let rec main args =
match data with match data with
| :? RethinkDbData as rethink -> | :? RethinkDbData as rethink ->
// A RethinkDB connection is designed to work as a singleton // 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 -> builder.Services.AddDistributedRethinkDBCache (fun opts ->
opts.TableName <- "Session" opts.TableName <- "Session"
opts.Connection <- rethink.Conn) opts.Connection <- rethink.Conn)
|> ignore ()
| :? SQLiteData as sql -> | :? SQLiteData as sql ->
// ADO.NET connections are designed to work as per-request instantiation // ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> () let cfg = sp.GetRequiredService<IConfiguration> ()
let _ =
builder.Services.AddScoped<SqliteConnection> (fun sp -> builder.Services.AddScoped<SqliteConnection> (fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString) let conn = new SqliteConnection (sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn) conn)
|> ignore let _ = builder.Services.AddScoped<IData, SQLiteData> () |> ignore
builder.Services.AddScoped<IData, SQLiteData> () |> ignore
// Use SQLite for caching as well // Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" 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 -> 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 = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "do-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 = "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 when it = "help" -> showHelp ()
| Some it -> | Some it ->
printfn $"""Unrecognized command "{it}" - valid commands are:""" printfn $"""Unrecognized command "{it}" - valid commands are:"""

View File

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

View File

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

View File

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