diff --git a/src/Directory.Build.props b/src/Directory.Build.props index b50ea6d..b9690f2 100644 --- a/src/Directory.Build.props +++ b/src/Directory.Build.props @@ -5,6 +5,6 @@ 2.0.0.0 2.0.0.0 2.0.0 - rc1 + rc2 diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index b17d587..82ff4c7 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -122,12 +122,13 @@ module Json = (string >> WebLogUserId) reader.Value open Microsoft.FSharpLu.Json - - /// All converters to use for data conversion - let all () : JsonConverter seq = - seq { - // Our converters - CategoryIdConverter () + open NodaTime + open NodaTime.Serialization.JsonNet + + /// Configure a serializer to use these converters + let configure (ser : JsonSerializer) = + // Our converters + [ CategoryIdConverter () :> JsonConverter CommentIdConverter () CustomFeedIdConverter () CustomFeedSourceConverter () @@ -143,6 +144,35 @@ module Json = UploadIdConverter () WebLogIdConverter () WebLogUserIdConverter () - // Handles DUs with no associated data, as well as option fields - CompactUnionJsonConverter () - } + ] |> List.iter ser.Converters.Add + // NodaTime + let _ = ser.ConfigureForNodaTime DateTimeZoneProviders.Tzdb + // Handles DUs with no associated data, as well as option fields + 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 diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index afa5e0c..f064cc4 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -1,9 +1,10 @@ namespace MyWebLog.Data -open System open System.Threading.Tasks open MyWebLog open MyWebLog.ViewModels +open Newtonsoft.Json +open NodaTime /// The result of a category deletion attempt type CategoryDeleteResult = @@ -137,7 +138,7 @@ type IPostData = WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task /// 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 + abstract member FindSurroundingPosts : WebLogId -> publishedOn : Instant -> Task /// Restore posts from a backup abstract member Restore : Post list -> Task @@ -326,6 +327,9 @@ type IData = /// Web log user data functions abstract member WebLogUser : IWebLogUserData + /// A JSON serializer for use in persistence + abstract member Serializer : JsonSerializer + /// Do any required start up data checks abstract member StartUp : unit -> Task \ No newline at end of file diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 558c1cf..4f2b61b 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -5,10 +5,16 @@ - + + + + + + + @@ -29,6 +35,17 @@ + + + + + + + + + + + diff --git a/src/MyWebLog.Data/Postgres/PostgresCache.fs b/src/MyWebLog.Data/Postgres/PostgresCache.fs new file mode 100644 index 0000000..70b79d8 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresCache.fs @@ -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 +[] +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 "expire_at" + SlidingExpiration = row.fieldValueOrNone "sliding_expiration" + AbsoluteExpiration = row.fieldValueOrNone "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 diff --git a/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs new file mode 100644 index 0000000..eec7703 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresCategoryData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresHelpers.fs b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs new file mode 100644 index 0000000..4f289ab --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresHelpers.fs @@ -0,0 +1,240 @@ +/// Helper functions for the PostgreSQL data implementation +[] +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 "published_on" + UpdatedOn = row.fieldValue "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 "published_on" + UpdatedOn = row.fieldValue "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 "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 "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 "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 "created_on" + LastSeenOn = row.fieldValueOrNone "last_seen_on" + } diff --git a/src/MyWebLog.Data/Postgres/PostgresPageData.fs b/src/MyWebLog.Data/Postgres/PostgresPageData.fs new file mode 100644 index 0000000..48ab3c3 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresPageData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresPostData.fs b/src/MyWebLog.Data/Postgres/PostgresPostData.fs new file mode 100644 index 0000000..aad6af6 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresPostData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs new file mode 100644 index 0000000..d76bbe6 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresTagMapData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresThemeData.fs b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs new file mode 100644 index 0000000..be2805d --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresThemeData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresUploadData.fs b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs new file mode 100644 index 0000000..89de2e9 --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresUploadData.fs @@ -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 + \ No newline at end of file diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs new file mode 100644 index 0000000..59899ac --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogData.fs @@ -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 diff --git a/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs new file mode 100644 index 0000000..333f5ec --- /dev/null +++ b/src/MyWebLog.Data/Postgres/PostgresWebLogUserData.fs @@ -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 + diff --git a/src/MyWebLog.Data/PostgresData.fs b/src/MyWebLog.Data/PostgresData.fs new file mode 100644 index 0000000..223efc5 --- /dev/null +++ b/src/MyWebLog.Data/PostgresData.fs @@ -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, 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 + } diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 620c10a..475923d 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -17,7 +17,10 @@ module private RethinkHelpers = /// The comment table let Comment = "Comment" - + + /// The database version table + let DbVersion = "DbVersion" + /// The page table let Page = "Page" @@ -43,7 +46,7 @@ module private RethinkHelpers = let WebLogUser = "WebLogUser" /// A list of all tables - let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ] + let all = [ Category; Comment; DbVersion; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ] /// Index names for indexes not on a data item's name @@ -187,7 +190,42 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger () + | Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 () + | Some _ + | None -> + log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" + do! setDbVersion Utils.currentDbVersion + } + /// The connection for this instance member _.Conn = conn @@ -1079,7 +1117,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger obj ] + update [ nameof WebLogUser.empty.LastSeenOn, Noda.now () :> obj ] write; withRetryOnce; ignoreResult conn } | None -> () @@ -1094,7 +1132,6 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { dbList; result; withRetryOnce conn } if not (dbs |> List.contains config.Database) then @@ -1114,6 +1154,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { + 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)) } diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 88955d6..150085f 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -5,6 +5,8 @@ module MyWebLog.Data.SQLite.Helpers open System open Microsoft.Data.Sqlite open MyWebLog +open MyWebLog.Data +open NodaTime.Text /// Run a command that returns a count let count (cmd : SqliteCommand) = backgroundTask { @@ -12,23 +14,6 @@ let count (cmd : SqliteCommand) = backgroundTask { return int (it :?> int64) } -/// Get lists of items removed from and added to the given lists -let diffLists<'T, 'U when 'U : equality> oldItems newItems (f : 'T -> 'U) = - let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other)) - List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems - -/// Find meta items added and removed -let diffMetaItems (oldItems : MetaItem list) newItems = - diffLists oldItems newItems (fun item -> $"{item.Name}|{item.Value}") - -/// Find the permalinks added and removed -let diffPermalinks oldLinks newLinks = - diffLists oldLinks newLinks Permalink.toString - -/// Find the revisions added and removed -let diffRevisions oldRevs newRevs = - diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.Ticks}|{MarkupText.toString rev.Text}") - /// Create a list of items from the given data reader let toList<'T> (it : SqliteDataReader -> 'T) (rdr : SqliteDataReader) = seq { while rdr.Read () do it rdr } @@ -47,6 +32,42 @@ let write (cmd : SqliteCommand) = backgroundTask { () } +/// Add a possibly-missing parameter, substituting null for None +let maybe<'T> (it : 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value + +/// Create a value for a Duration +let durationParam = + DurationPattern.Roundtrip.Format + +/// Create a value for an Instant +let instantParam = + InstantPattern.General.Format + +/// Create an optional value for a Duration +let maybeDuration = + Option.map durationParam >> maybe + +/// Create an optional value for an Instant +let maybeInstant = + Option.map instantParam >> maybe + +/// Create the SQL and parameters for an IN clause +let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items : 'T list) = + if List.isEmpty items then "", [] + else + let mutable idx = 0 + items + |> List.skip 1 + |> List.fold (fun (itemS, itemP) it -> + idx <- idx + 1 + $"{itemS}, @%s{paramName}{idx}", (SqliteParameter ($"@%s{paramName}{idx}", valueFunc it) :: itemP)) + (Seq.ofList items + |> Seq.map (fun it -> + $"%s{colNameAndPrefix} IN (@%s{paramName}0", [ SqliteParameter ($"@%s{paramName}0", valueFunc it) ]) + |> Seq.head) + |> function sql, ps -> $"{sql})", ps + + /// Functions to map domain items from a data reader module Map = @@ -73,6 +94,26 @@ module Map = /// Get a string value from a data reader let getString col (rdr : SqliteDataReader) = rdr.GetString (rdr.GetOrdinal col) + /// Parse a Duration from the given value + let parseDuration value = + match DurationPattern.Roundtrip.Parse value with + | it when it.Success -> it.Value + | it -> raise it.Exception + + /// Get a Duration value from a data reader + let getDuration col rdr = + getString col rdr |> parseDuration + + /// Parse an Instant from the given value + let parseInstant value = + match InstantPattern.General.Parse value with + | it when it.Success -> it.Value + | it -> raise it.Exception + + /// Get an Instant value from a data reader + let getInstant col rdr = + getString col rdr |> parseInstant + /// Get a timespan value from a data reader let getTimeSpan col (rdr : SqliteDataReader) = rdr.GetTimeSpan (rdr.GetOrdinal col) @@ -96,6 +137,14 @@ module Map = let tryString col (rdr : SqliteDataReader) = if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getString col rdr) + /// Get a possibly null Duration value from a data reader + let tryDuration col rdr = + tryString col rdr |> Option.map parseDuration + + /// Get a possibly null Instant value from a data reader + let tryInstant col rdr = + tryString col rdr |> Option.map parseInstant + /// Get a possibly null timespan value from a data reader let tryTimeSpan col (rdr : SqliteDataReader) = if rdr.IsDBNull (rdr.GetOrdinal col) then None else Some (getTimeSpan col rdr) @@ -114,100 +163,57 @@ module Map = } /// Create a custom feed from the current row in the given data reader - let toCustomFeed rdr : CustomFeed = - { Id = getString "id" rdr |> CustomFeedId - Source = getString "source" rdr |> CustomFeedSource.parse - Path = getString "path" rdr |> Permalink - Podcast = - if rdr.IsDBNull (rdr.GetOrdinal "title") then - None - else - Some { - Title = getString "title" rdr - Subtitle = tryString "subtitle" rdr - ItemsInFeed = getInt "items_in_feed" rdr - Summary = getString "summary" rdr - DisplayedAuthor = getString "displayed_author" rdr - Email = getString "email" rdr - ImageUrl = getString "image_url" rdr |> Permalink - AppleCategory = getString "apple_category" rdr - AppleSubcategory = tryString "apple_subcategory" rdr - Explicit = getString "explicit" rdr |> ExplicitRating.parse - DefaultMediaType = tryString "default_media_type" rdr - MediaBaseUrl = tryString "media_base_url" rdr - PodcastGuid = tryGuid "podcast_guid" rdr - FundingUrl = tryString "funding_url" rdr - FundingText = tryString "funding_text" rdr - Medium = tryString "medium" rdr |> Option.map PodcastMedium.parse - } - } - - /// Create a meta item from the current row in the given data reader - let toMetaItem rdr : MetaItem = - { Name = getString "name" rdr - Value = getString "value" rdr + let toCustomFeed ser rdr : CustomFeed = + { Id = getString "id" rdr |> CustomFeedId + Source = getString "source" rdr |> CustomFeedSource.parse + Path = getString "path" rdr |> Permalink + Podcast = tryString "podcast" rdr |> Option.map (Utils.deserialize ser) } /// Create a permalink from the current row in the given data reader let toPermalink rdr = getString "permalink" rdr |> Permalink /// Create a page from the current row in the given data reader - let toPage rdr : Page = + let toPage ser rdr : Page = { Page.empty with Id = getString "id" rdr |> PageId WebLogId = getString "web_log_id" rdr |> WebLogId AuthorId = getString "author_id" rdr |> WebLogUserId Title = getString "title" rdr Permalink = toPermalink rdr - PublishedOn = getDateTime "published_on" rdr - UpdatedOn = getDateTime "updated_on" rdr + PublishedOn = getInstant "published_on" rdr + UpdatedOn = getInstant "updated_on" rdr IsInPageList = getBoolean "is_in_page_list" rdr Template = tryString "template" rdr Text = getString "page_text" rdr + Metadata = tryString "meta_items" rdr + |> Option.map (Utils.deserialize ser) + |> Option.defaultValue [] } /// Create a post from the current row in the given data reader - let toPost rdr : Post = + let toPost ser rdr : Post = { Post.empty with - Id = getString "id" rdr |> PostId - WebLogId = getString "web_log_id" rdr |> WebLogId - AuthorId = getString "author_id" rdr |> WebLogUserId - Status = getString "status" rdr |> PostStatus.parse - Title = getString "title" rdr - Permalink = toPermalink rdr - PublishedOn = tryDateTime "published_on" rdr - UpdatedOn = getDateTime "updated_on" rdr - Template = tryString "template" rdr - Text = getString "post_text" rdr - Episode = - match tryString "media" rdr with - | Some media -> - Some { - Media = media - Length = getLong "length" rdr - Duration = tryTimeSpan "duration" rdr - MediaType = tryString "media_type" rdr - ImageUrl = tryString "image_url" rdr - Subtitle = tryString "subtitle" rdr - Explicit = tryString "explicit" rdr |> Option.map ExplicitRating.parse - ChapterFile = tryString "chapter_file" rdr - ChapterType = tryString "chapter_type" rdr - TranscriptUrl = tryString "transcript_url" rdr - TranscriptType = tryString "transcript_type" rdr - TranscriptLang = tryString "transcript_lang" rdr - TranscriptCaptions = tryBoolean "transcript_captions" rdr - SeasonNumber = tryInt "season_number" rdr - SeasonDescription = tryString "season_description" rdr - EpisodeNumber = tryString "episode_number" rdr |> Option.map Double.Parse - EpisodeDescription = tryString "episode_description" rdr - } - | None -> None + Id = getString "id" rdr |> PostId + WebLogId = getString "web_log_id" rdr |> WebLogId + AuthorId = getString "author_id" rdr |> WebLogUserId + Status = getString "status" rdr |> PostStatus.parse + Title = getString "title" rdr + Permalink = toPermalink rdr + PublishedOn = tryInstant "published_on" rdr + UpdatedOn = getInstant "updated_on" rdr + Template = tryString "template" rdr + Text = getString "post_text" rdr + Episode = tryString "episode" rdr |> Option.map (Utils.deserialize ser) + Metadata = tryString "meta_items" rdr + |> Option.map (Utils.deserialize ser) + |> Option.defaultValue [] } /// Create a revision from the current row in the given data reader let toRevision rdr : Revision = - { AsOf = getDateTime "as_of" rdr - Text = getString "revision_text" rdr |> MarkupText.parse + { AsOf = getInstant "as_of" rdr + Text = getString "revision_text" rdr |> MarkupText.parse } /// Create a tag mapping from the current row in the given data reader @@ -237,7 +243,7 @@ module Map = else [||] { Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr) - UpdatedOn = getDateTime "updated_on" rdr + UpdatedOn = getInstant "updated_on" rdr Data = assetData } @@ -257,10 +263,10 @@ module Map = dataStream.ToArray () else [||] - { Id = getString "id" rdr |> UploadId - WebLogId = getString "web_log_id" rdr |> WebLogId - Path = getString "path" rdr |> Permalink - UpdatedOn = getDateTime "updated_on" rdr + { Id = getString "id" rdr |> UploadId + WebLogId = getString "web_log_id" rdr |> WebLogId + Path = getString "path" rdr |> Permalink + UpdatedOn = getInstant "updated_on" rdr Data = data } @@ -290,23 +296,19 @@ module Map = /// Create a web log user from the current row in the given data reader let toWebLogUser rdr : WebLogUser = - { Id = getString "id" rdr |> WebLogUserId - WebLogId = getString "web_log_id" rdr |> WebLogId - Email = getString "email" rdr - FirstName = getString "first_name" rdr - LastName = getString "last_name" rdr - PreferredName = getString "preferred_name" rdr - PasswordHash = getString "password_hash" rdr - Salt = getGuid "salt" rdr - Url = tryString "url" rdr - AccessLevel = getString "access_level" rdr |> AccessLevel.parse - CreatedOn = getDateTime "created_on" rdr - LastSeenOn = tryDateTime "last_seen_on" rdr + { Id = getString "id" rdr |> WebLogUserId + WebLogId = getString "web_log_id" rdr |> WebLogId + Email = getString "email" rdr + FirstName = getString "first_name" rdr + LastName = getString "last_name" rdr + PreferredName = getString "preferred_name" rdr + PasswordHash = getString "password_hash" rdr + Url = tryString "url" rdr + AccessLevel = getString "access_level" rdr |> AccessLevel.parse + CreatedOn = getInstant "created_on" rdr + LastSeenOn = tryInstant "last_seen_on" rdr } -/// Add a possibly-missing parameter, substituting null for None -let maybe<'T> (it : 'T option) : obj = match it with Some x -> x :> obj | None -> DBNull.Value - /// Add a web log ID parameter let addWebLogId (cmd : SqliteCommand) webLogId = cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore diff --git a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs index f14e2ec..75728b8 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteCategoryData.fs @@ -10,23 +10,23 @@ type SQLiteCategoryData (conn : SqliteConnection) = /// Add parameters for category INSERT or UPDATE statements let addCategoryParameters (cmd : SqliteCommand) (cat : Category) = - [ cmd.Parameters.AddWithValue ("@id", CategoryId.toString cat.Id) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString cat.WebLogId) - cmd.Parameters.AddWithValue ("@name", cat.Name) - cmd.Parameters.AddWithValue ("@slug", cat.Slug) + [ cmd.Parameters.AddWithValue ("@id", CategoryId.toString cat.Id) + cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString cat.WebLogId) + cmd.Parameters.AddWithValue ("@name", cat.Name) + cmd.Parameters.AddWithValue ("@slug", cat.Slug) cmd.Parameters.AddWithValue ("@description", maybe cat.Description) - cmd.Parameters.AddWithValue ("@parentId", maybe (cat.ParentId |> Option.map CategoryId.toString)) + cmd.Parameters.AddWithValue ("@parentId", maybe (cat.ParentId |> Option.map CategoryId.toString)) ] |> ignore /// Add a category let add cat = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO category ( + cmd.CommandText <- + "INSERT INTO category ( id, web_log_id, name, slug, description, parent_id ) VALUES ( @id, @webLogId, @name, @slug, @description, @parentId - )""" + )" addCategoryParameters cmd cat let! _ = cmd.ExecuteNonQueryAsync () () @@ -68,24 +68,23 @@ type SQLiteCategoryData (conn : SqliteConnection) = ordered |> Seq.map (fun it -> backgroundTask { // Parent category post counts include posts in subcategories + let catSql, catParams = + ordered + |> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name) + |> Seq.map (fun cat -> cat.Id) + |> Seq.append (Seq.singleton it.Id) + |> List.ofSeq + |> inClause "AND pc.category_id" "catId" id cmd.Parameters.Clear () addWebLogId cmd webLogId - cmd.CommandText <- """ + cmd.Parameters.AddRange catParams + cmd.CommandText <- $" SELECT COUNT(DISTINCT p.id) FROM post p INNER JOIN post_category pc ON pc.post_id = p.id WHERE p.web_log_id = @webLogId AND p.status = 'Published' - AND pc.category_id IN (""" - ordered - |> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name) - |> Seq.map (fun cat -> cat.Id) - |> Seq.append (Seq.singleton it.Id) - |> Seq.iteri (fun idx item -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@catId{idx}" - cmd.Parameters.AddWithValue ($"@catId{idx}", item) |> ignore) - cmd.CommandText <- $"{cmd.CommandText})" + {catSql}" let! postCount = count cmd return it.Id, postCount }) @@ -133,19 +132,15 @@ type SQLiteCategoryData (conn : SqliteConnection) = cmd.Parameters.AddWithValue ("@newParentId", maybe (cat.ParentId |> Option.map CategoryId.toString)) |> ignore do! write cmd - // Delete the category off all posts where it is assigned - cmd.CommandText <- """ - DELETE FROM post_category - WHERE category_id = @id - AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId)""" + // Delete the category off all posts where it is assigned, and the category itself + cmd.CommandText <- + "DELETE FROM post_category + WHERE category_id = @id + AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId); + DELETE FROM category WHERE id = @id" cmd.Parameters.Clear () - let catIdParameter = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore - do! write cmd - // Delete the category itself - cmd.CommandText <- "DELETE FROM category WHERE id = @id" - cmd.Parameters.Clear () - cmd.Parameters.Add catIdParameter |> ignore + let _ = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) + addWebLogId cmd webLogId do! write cmd return if children = 0 then CategoryDeleted else ReassignedChildCategories | None -> return CategoryNotFound @@ -160,14 +155,14 @@ type SQLiteCategoryData (conn : SqliteConnection) = /// Update a category let update cat = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE category - SET name = @name, - slug = @slug, - description = @description, - parent_id = @parentId - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE category + SET name = @name, + slug = @slug, + description = @description, + parent_id = @parentId + WHERE id = @id + AND web_log_id = @webLogId" addCategoryParameters cmd cat do! write cmd } diff --git a/src/MyWebLog.Data/SQLite/SQLitePageData.fs b/src/MyWebLog.Data/SQLite/SQLitePageData.fs index 5dbb71e..5562bcc 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -4,35 +4,29 @@ open System.Threading.Tasks open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data +open Newtonsoft.Json /// SQLite myWebLog page data implementation -type SQLitePageData (conn : SqliteConnection) = +type SQLitePageData (conn : SqliteConnection, ser : JsonSerializer) = // SUPPORT FUNCTIONS /// Add parameters for page INSERT or UPDATE statements let addPageParameters (cmd : SqliteCommand) (page : Page) = - [ cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString page.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString page.AuthorId) - cmd.Parameters.AddWithValue ("@title", page.Title) - cmd.Parameters.AddWithValue ("@permalink", Permalink.toString page.Permalink) - cmd.Parameters.AddWithValue ("@publishedOn", page.PublishedOn) - cmd.Parameters.AddWithValue ("@updatedOn", page.UpdatedOn) + [ cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) + cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString page.WebLogId) + cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString page.AuthorId) + cmd.Parameters.AddWithValue ("@title", page.Title) + cmd.Parameters.AddWithValue ("@permalink", Permalink.toString page.Permalink) + cmd.Parameters.AddWithValue ("@publishedOn", instantParam page.PublishedOn) + cmd.Parameters.AddWithValue ("@updatedOn", instantParam page.UpdatedOn) cmd.Parameters.AddWithValue ("@isInPageList", page.IsInPageList) - cmd.Parameters.AddWithValue ("@template", maybe page.Template) - cmd.Parameters.AddWithValue ("@text", page.Text) + cmd.Parameters.AddWithValue ("@template", maybe page.Template) + cmd.Parameters.AddWithValue ("@text", page.Text) + cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty page.Metadata then None + else Some (Utils.serialize ser page.Metadata))) ] |> ignore - /// Append meta items to a page - let appendPageMeta (page : Page) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT name, value FROM page_meta WHERE page_id = @id" - cmd.Parameters.AddWithValue ("@id", PageId.toString page.Id) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return { page with Metadata = toList Map.toMetaItem rdr } - } - /// Append revisions and permalinks to a page let appendPageRevisionsAndPermalinks (page : Page) = backgroundTask { use cmd = conn.CreateCommand () @@ -48,47 +42,23 @@ type SQLitePageData (conn : SqliteConnection) = return { page with Revisions = toList Map.toRevision rdr } } - /// Return a page with no text (or meta items, prior permalinks, or revisions) - let pageWithoutTextOrMeta rdr = - { Map.toPage rdr with Text = "" } + /// Shorthand for mapping a data reader to a page + let toPage = + Map.toPage ser - /// Update a page's metadata items - let updatePageMeta pageId oldItems newItems = backgroundTask { - let toDelete, toAdd = diffMetaItems oldItems newItems - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId) - cmd.Parameters.Add ("@name", SqliteType.Text) - cmd.Parameters.Add ("@value", SqliteType.Text) - ] |> ignore - let runCmd (item : MetaItem) = backgroundTask { - cmd.Parameters["@name" ].Value <- item.Name - cmd.Parameters["@value"].Value <- item.Value - do! write cmd - } - cmd.CommandText <- "DELETE FROM page_meta WHERE page_id = @pageId AND name = @name AND value = @value" - toDelete - |> List.map runCmd - |> Task.WhenAll - |> ignore - cmd.CommandText <- "INSERT INTO page_meta VALUES (@pageId, @name, @value)" - toAdd - |> List.map runCmd - |> Task.WhenAll - |> ignore - } + /// Return a page with no text (or prior permalinks or revisions) + let pageWithoutText rdr = + { toPage rdr with Text = "" } /// Update a page's prior permalinks let updatePagePermalinks pageId oldLinks newLinks = backgroundTask { - let toDelete, toAdd = diffPermalinks oldLinks newLinks + let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () [ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId) - cmd.Parameters.Add ("@link", SqliteType.Text) + cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore let runCmd link = backgroundTask { cmd.Parameters["@link"].Value <- Permalink.toString link @@ -108,15 +78,15 @@ type SQLitePageData (conn : SqliteConnection) = /// Update a page's revisions let updatePageRevisions pageId oldRevs newRevs = backgroundTask { - let toDelete, toAdd = diffRevisions oldRevs newRevs + let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId) - cmd.Parameters.AddWithValue ("@asOf", rev.AsOf) + [ cmd.Parameters.AddWithValue ("@pageId", PageId.toString pageId) + cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore do! write cmd @@ -139,17 +109,16 @@ type SQLitePageData (conn : SqliteConnection) = let add page = backgroundTask { use cmd = conn.CreateCommand () // The page itself - cmd.CommandText <- """ - INSERT INTO page ( + cmd.CommandText <- + "INSERT INTO page ( id, web_log_id, author_id, title, permalink, published_on, updated_on, is_in_page_list, template, - page_text + page_text, meta_items ) VALUES ( @id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @isInPageList, @template, - @text - )""" + @text, @metaItems + )" addPageParameters cmd page do! write cmd - do! updatePageMeta page.Id [] page.Metadata do! updatePagePermalinks page.Id [] page.PriorPermalinks do! updatePageRevisions page.Id [] page.Revisions } @@ -160,7 +129,7 @@ type SQLitePageData (conn : SqliteConnection) = cmd.CommandText <- "SELECT * FROM page WHERE web_log_id = @webLogId ORDER BY LOWER(title)" addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () - return toList pageWithoutTextOrMeta rdr + return toList pageWithoutText rdr } /// Count all pages for the given web log @@ -174,11 +143,11 @@ type SQLitePageData (conn : SqliteConnection) = /// Count all pages shown in the page list for the given web log let countListed webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - SELECT COUNT(id) - FROM page - WHERE web_log_id = @webLogId - AND is_in_page_list = @isInPageList""" + cmd.CommandText <- + "SELECT COUNT(id) + FROM page + WHERE web_log_id = @webLogId + AND is_in_page_list = @isInPageList" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore return! count cmd @@ -190,11 +159,7 @@ type SQLitePageData (conn : SqliteConnection) = cmd.CommandText <- "SELECT * FROM page WHERE id = @id" cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore use! rdr = cmd.ExecuteReaderAsync () - match Helpers.verifyWebLog webLogId (fun it -> it.WebLogId) Map.toPage rdr with - | Some page -> - let! page = appendPageMeta page - return Some page - | None -> return None + return Helpers.verifyWebLog webLogId (fun it -> it.WebLogId) (Map.toPage ser) rdr } /// Find a complete page by its ID @@ -211,11 +176,10 @@ type SQLitePageData (conn : SqliteConnection) = | Some _ -> use cmd = conn.CreateCommand () cmd.Parameters.AddWithValue ("@id", PageId.toString pageId) |> ignore - cmd.CommandText <- """ - DELETE FROM page_revision WHERE page_id = @id; - DELETE FROM page_permalink WHERE page_id = @id; - DELETE FROM page_meta WHERE page_id = @id; - DELETE FROM page WHERE id = @id""" + cmd.CommandText <- + "DELETE FROM page_revision WHERE page_id = @id; + DELETE FROM page_permalink WHERE page_id = @id; + DELETE FROM page WHERE id = @id" do! write cmd return true | None -> return false @@ -228,29 +192,21 @@ type SQLitePageData (conn : SqliteConnection) = addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore use! rdr = cmd.ExecuteReaderAsync () - if rdr.Read () then - let! page = appendPageMeta (Map.toPage rdr) - return Some page - else - return None + return if rdr.Read () then Some (toPage rdr) else None } /// Find the current permalink within a set of potential prior permalinks for the given web log let findCurrentPermalink permalinks webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ + let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks + cmd.CommandText <- $" SELECT p.permalink - FROM page p - INNER JOIN page_permalink pp ON pp.page_id = p.id - WHERE p.web_log_id = @webLogId - AND pp.permalink IN (""" - permalinks - |> List.iteri (fun idx link -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@link{idx}" - cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore) - cmd.CommandText <- $"{cmd.CommandText})" + FROM page p + INNER JOIN page_permalink pp ON pp.page_id = p.id + WHERE p.web_log_id = @webLogId + {linkSql}" addWebLogId cmd webLogId + cmd.Parameters.AddRange linkParams use! rdr = cmd.ExecuteReaderAsync () return if rdr.Read () then Some (Map.toPermalink rdr) else None } @@ -262,11 +218,8 @@ type SQLitePageData (conn : SqliteConnection) = addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () let! pages = - toList Map.toPage rdr - |> List.map (fun page -> backgroundTask { - let! page = appendPageMeta page - return! appendPageRevisionsAndPermalinks page - }) + toList toPage rdr + |> List.map (fun page -> backgroundTask { return! appendPageRevisionsAndPermalinks page }) |> Task.WhenAll return List.ofArray pages } @@ -274,37 +227,33 @@ type SQLitePageData (conn : SqliteConnection) = /// Get all listed pages for the given web log (without revisions, prior permalinks, or text) let findListed webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - SELECT * - FROM page - WHERE web_log_id = @webLogId - AND is_in_page_list = @isInPageList - ORDER BY LOWER(title)""" + cmd.CommandText <- + "SELECT * + FROM page + WHERE web_log_id = @webLogId + AND is_in_page_list = @isInPageList + ORDER BY LOWER(title)" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@isInPageList", true) |> ignore use! rdr = cmd.ExecuteReaderAsync () - let! pages = - toList pageWithoutTextOrMeta rdr - |> List.map (fun page -> backgroundTask { return! appendPageMeta page }) - |> Task.WhenAll - return List.ofArray pages + return toList pageWithoutText rdr } /// Get a page of pages for the given web log (without revisions, prior permalinks, or metadata) let findPageOfPages webLogId pageNbr = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - SELECT * - FROM page - WHERE web_log_id = @webLogId - ORDER BY LOWER(title) - LIMIT @pageSize OFFSET @toSkip""" + cmd.CommandText <- + "SELECT * + FROM page + WHERE web_log_id = @webLogId + ORDER BY LOWER(title) + LIMIT @pageSize OFFSET @toSkip" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@pageSize", 26) - cmd.Parameters.AddWithValue ("@toSkip", (pageNbr - 1) * 25) + [ cmd.Parameters.AddWithValue ("@pageSize", 26) + cmd.Parameters.AddWithValue ("@toSkip", (pageNbr - 1) * 25) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toPage rdr + return toList toPage rdr } /// Restore pages from a backup @@ -318,21 +267,21 @@ type SQLitePageData (conn : SqliteConnection) = match! findFullById page.Id page.WebLogId with | Some oldPage -> use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE page - SET author_id = @authorId, - title = @title, - permalink = @permalink, - published_on = @publishedOn, - updated_on = @updatedOn, - is_in_page_list = @isInPageList, - template = @template, - page_text = @text - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE page + SET author_id = @authorId, + title = @title, + permalink = @permalink, + published_on = @publishedOn, + updated_on = @updatedOn, + is_in_page_list = @isInPageList, + template = @template, + page_text = @text, + meta_items = @metaItems + WHERE id = @id + AND web_log_id = @webLogId" addPageParameters cmd page do! write cmd - do! updatePageMeta page.Id oldPage.Metadata page.Metadata do! updatePagePermalinks page.Id oldPage.PriorPermalinks page.PriorPermalinks do! updatePageRevisions page.Id oldPage.Revisions page.Revisions return () diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index fdfa1e9..257bdf7 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -1,53 +1,38 @@ namespace MyWebLog.Data.SQLite -open System open System.Threading.Tasks open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data +open Newtonsoft.Json +open NodaTime /// SQLite myWebLog post data implementation -type SQLitePostData (conn : SqliteConnection) = +type SQLitePostData (conn : SqliteConnection, ser : JsonSerializer) = // SUPPORT FUNCTIONS /// Add parameters for post INSERT or UPDATE statements let addPostParameters (cmd : SqliteCommand) (post : Post) = - [ cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString post.WebLogId) - cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString post.AuthorId) - cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status) - cmd.Parameters.AddWithValue ("@title", post.Title) - cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink) - cmd.Parameters.AddWithValue ("@publishedOn", maybe post.PublishedOn) - cmd.Parameters.AddWithValue ("@updatedOn", post.UpdatedOn) - cmd.Parameters.AddWithValue ("@template", maybe post.Template) - cmd.Parameters.AddWithValue ("@text", post.Text) + [ cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) + cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString post.WebLogId) + cmd.Parameters.AddWithValue ("@authorId", WebLogUserId.toString post.AuthorId) + cmd.Parameters.AddWithValue ("@status", PostStatus.toString post.Status) + cmd.Parameters.AddWithValue ("@title", post.Title) + cmd.Parameters.AddWithValue ("@permalink", Permalink.toString post.Permalink) + cmd.Parameters.AddWithValue ("@publishedOn", maybeInstant post.PublishedOn) + cmd.Parameters.AddWithValue ("@updatedOn", instantParam post.UpdatedOn) + cmd.Parameters.AddWithValue ("@template", maybe post.Template) + cmd.Parameters.AddWithValue ("@text", post.Text) + cmd.Parameters.AddWithValue ("@episode", maybe (if Option.isSome post.Episode then + Some (Utils.serialize ser post.Episode) + else None)) + cmd.Parameters.AddWithValue ("@metaItems", maybe (if List.isEmpty post.Metadata then None + else Some (Utils.serialize ser post.Metadata))) ] |> ignore - /// Add parameters for episode INSERT or UPDATE statements - let addEpisodeParameters (cmd : SqliteCommand) (ep : Episode) = - [ cmd.Parameters.AddWithValue ("@media", ep.Media) - cmd.Parameters.AddWithValue ("@length", ep.Length) - cmd.Parameters.AddWithValue ("@duration", maybe ep.Duration) - cmd.Parameters.AddWithValue ("@mediaType", maybe ep.MediaType) - cmd.Parameters.AddWithValue ("@imageUrl", maybe ep.ImageUrl) - cmd.Parameters.AddWithValue ("@subtitle", maybe ep.Subtitle) - cmd.Parameters.AddWithValue ("@explicit", maybe (ep.Explicit |> Option.map ExplicitRating.toString)) - cmd.Parameters.AddWithValue ("@chapterFile", maybe ep.ChapterFile) - cmd.Parameters.AddWithValue ("@chapterType", maybe ep.ChapterType) - cmd.Parameters.AddWithValue ("@transcriptUrl", maybe ep.TranscriptUrl) - cmd.Parameters.AddWithValue ("@transcriptType", maybe ep.TranscriptType) - cmd.Parameters.AddWithValue ("@transcriptLang", maybe ep.TranscriptLang) - cmd.Parameters.AddWithValue ("@transcriptCaptions", maybe ep.TranscriptCaptions) - cmd.Parameters.AddWithValue ("@seasonNumber", maybe ep.SeasonNumber) - cmd.Parameters.AddWithValue ("@seasonDescription", maybe ep.SeasonDescription) - cmd.Parameters.AddWithValue ("@episodeNumber", maybe (ep.EpisodeNumber |> Option.map string)) - cmd.Parameters.AddWithValue ("@episodeDescription", maybe ep.EpisodeDescription) - ] |> ignore - - /// Append category IDs, tags, and meta items to a post - let appendPostCategoryTagAndMeta (post : Post) = backgroundTask { + /// Append category IDs and tags to a post + let appendPostCategoryAndTag (post : Post) = backgroundTask { use cmd = conn.CreateCommand () cmd.Parameters.AddWithValue ("@id", PostId.toString post.Id) |> ignore @@ -58,12 +43,7 @@ type SQLitePostData (conn : SqliteConnection) = cmd.CommandText <- "SELECT tag FROM post_tag WHERE post_id = @id" use! rdr = cmd.ExecuteReaderAsync () - let post = { post with Tags = toList (Map.getString "tag") rdr } - do! rdr.CloseAsync () - - cmd.CommandText <- "SELECT name, value FROM post_meta WHERE post_id = @id" - use! rdr = cmd.ExecuteReaderAsync () - return { post with Metadata = toList Map.toMetaItem rdr } + return { post with Tags = toList (Map.getString "tag") rdr } } /// Append revisions and permalinks to a post @@ -82,7 +62,11 @@ type SQLitePostData (conn : SqliteConnection) = } /// The SELECT statement for a post that will include episode data, if it exists - let selectPost = "SELECT p.*, e.* FROM post p LEFT JOIN post_episode e ON e.post_id = p.id" + let selectPost = "SELECT p.* FROM post p" + + /// Shorthand for mapping a data reader to a post + let toPost = + Map.toPost ser /// Find just-the-post by its ID for the given web log (excludes category, tag, meta, revisions, and permalinks) let findPostById postId webLogId = backgroundTask { @@ -90,22 +74,22 @@ type SQLitePostData (conn : SqliteConnection) = cmd.CommandText <- $"{selectPost} WHERE p.id = @id" cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun p -> p.WebLogId) Map.toPost rdr + return Helpers.verifyWebLog webLogId (fun p -> p.WebLogId) toPost rdr } /// Return a post with no revisions, prior permalinks, or text let postWithoutText rdr = - { Map.toPost rdr with Text = "" } + { toPost rdr with Text = "" } /// Update a post's assigned categories let updatePostCategories postId oldCats newCats = backgroundTask { - let toDelete, toAdd = diffLists oldCats newCats CategoryId.toString + let toDelete, toAdd = Utils.diffLists oldCats newCats CategoryId.toString if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) - cmd.Parameters.Add ("@categoryId", SqliteType.Text) + [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + cmd.Parameters.Add ("@categoryId", SqliteType.Text) ] |> ignore let runCmd catId = backgroundTask { cmd.Parameters["@categoryId"].Value <- CategoryId.toString catId @@ -125,13 +109,13 @@ type SQLitePostData (conn : SqliteConnection) = /// Update a post's assigned categories let updatePostTags postId (oldTags : string list) newTags = backgroundTask { - let toDelete, toAdd = diffLists oldTags newTags id + let toDelete, toAdd = Utils.diffLists oldTags newTags id if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) - cmd.Parameters.Add ("@tag", SqliteType.Text) + [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + cmd.Parameters.Add ("@tag", SqliteType.Text) ] |> ignore let runCmd (tag : string) = backgroundTask { cmd.Parameters["@tag"].Value <- tag @@ -149,95 +133,15 @@ type SQLitePostData (conn : SqliteConnection) = |> ignore } - /// Update an episode - let updatePostEpisode (post : Post) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT COUNT(post_id) FROM post_episode WHERE post_id = @postId" - cmd.Parameters.AddWithValue ("@postId", PostId.toString post.Id) |> ignore - let! count = count cmd - if count = 1 then - match post.Episode with - | Some ep -> - cmd.CommandText <- """ - UPDATE post_episode - SET media = @media, - length = @length, - duration = @duration, - media_type = @mediaType, - image_url = @imageUrl, - subtitle = @subtitle, - explicit = @explicit, - chapter_file = @chapterFile, - chapter_type = @chapterType, - transcript_url = @transcriptUrl, - transcript_type = @transcriptType, - transcript_lang = @transcriptLang, - transcript_captions = @transcriptCaptions, - season_number = @seasonNumber, - season_description = @seasonDescription, - episode_number = @episodeNumber, - episode_description = @episodeDescription - WHERE post_id = @postId""" - addEpisodeParameters cmd ep - do! write cmd - | None -> - cmd.CommandText <- "DELETE FROM post_episode WHERE post_id = @postId" - do! write cmd - else - match post.Episode with - | Some ep -> - cmd.CommandText <- """ - INSERT INTO post_episode ( - post_id, media, length, duration, media_type, image_url, subtitle, explicit, chapter_file, - chapter_type, transcript_url, transcript_type, transcript_lang, transcript_captions, - season_number, season_description, episode_number, episode_description - ) VALUES ( - @postId, @media, @length, @duration, @mediaType, @imageUrl, @subtitle, @explicit, @chapterFile, - @chapterType, @transcriptUrl, @transcriptType, @transcriptLang, @transcriptCaptions, - @seasonNumber, @seasonDescription, @episodeNumber, @episodeDescription - )""" - addEpisodeParameters cmd ep - do! write cmd - | None -> () - } - - /// Update a post's metadata items - let updatePostMeta postId oldItems newItems = backgroundTask { - let toDelete, toAdd = diffMetaItems oldItems newItems - if List.isEmpty toDelete && List.isEmpty toAdd then - return () - else - use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) - cmd.Parameters.Add ("@name", SqliteType.Text) - cmd.Parameters.Add ("@value", SqliteType.Text) - ] |> ignore - let runCmd (item : MetaItem) = backgroundTask { - cmd.Parameters["@name" ].Value <- item.Name - cmd.Parameters["@value"].Value <- item.Value - do! write cmd - } - cmd.CommandText <- "DELETE FROM post_meta WHERE post_id = @postId AND name = @name AND value = @value" - toDelete - |> List.map runCmd - |> Task.WhenAll - |> ignore - cmd.CommandText <- "INSERT INTO post_meta VALUES (@postId, @name, @value)" - toAdd - |> List.map runCmd - |> Task.WhenAll - |> ignore - } - /// Update a post's prior permalinks let updatePostPermalinks postId oldLinks newLinks = backgroundTask { - let toDelete, toAdd = diffPermalinks oldLinks newLinks + let toDelete, toAdd = Utils.diffPermalinks oldLinks newLinks if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) - cmd.Parameters.Add ("@link", SqliteType.Text) + [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + cmd.Parameters.Add ("@link", SqliteType.Text) ] |> ignore let runCmd link = backgroundTask { cmd.Parameters["@link"].Value <- Permalink.toString link @@ -257,15 +161,15 @@ type SQLitePostData (conn : SqliteConnection) = /// Update a post's revisions let updatePostRevisions postId oldRevs newRevs = backgroundTask { - let toDelete, toAdd = diffRevisions oldRevs newRevs + let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs if List.isEmpty toDelete && List.isEmpty toAdd then return () else use cmd = conn.CreateCommand () let runCmd withText rev = backgroundTask { cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) - cmd.Parameters.AddWithValue ("@asOf", rev.AsOf) + [ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId) + cmd.Parameters.AddWithValue ("@asOf", instantParam rev.AsOf) ] |> ignore if withText then cmd.Parameters.AddWithValue ("@text", MarkupText.toString rev.Text) |> ignore do! write cmd @@ -287,18 +191,18 @@ type SQLitePostData (conn : SqliteConnection) = /// Add a post let add post = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO post ( - id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text + cmd.CommandText <- + "INSERT INTO post ( + id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text, + episode, meta_items ) VALUES ( - @id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text - )""" + @id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text, + @episode, @metaItems + )" addPostParameters cmd post do! write cmd do! updatePostCategories post.Id [] post.CategoryIds do! updatePostTags post.Id [] post.Tags - do! updatePostEpisode post - do! updatePostMeta post.Id [] post.Metadata do! updatePostPermalinks post.Id [] post.PriorPermalinks do! updatePostRevisions post.Id [] post.Revisions } @@ -316,7 +220,7 @@ type SQLitePostData (conn : SqliteConnection) = let findById postId webLogId = backgroundTask { match! findPostById postId webLogId with | Some post -> - let! post = appendPostCategoryTagAndMeta post + let! post = appendPostCategoryAndTag post return Some post | None -> return None } @@ -329,7 +233,7 @@ type SQLitePostData (conn : SqliteConnection) = cmd.Parameters.AddWithValue ("@link", Permalink.toString permalink) |> ignore use! rdr = cmd.ExecuteReaderAsync () if rdr.Read () then - let! post = appendPostCategoryTagAndMeta (Map.toPost rdr) + let! post = appendPostCategoryAndTag (toPost rdr) return Some post else return None @@ -350,14 +254,13 @@ type SQLitePostData (conn : SqliteConnection) = | Some _ -> use cmd = conn.CreateCommand () cmd.Parameters.AddWithValue ("@id", PostId.toString postId) |> ignore - cmd.CommandText <- """ - DELETE FROM post_revision WHERE post_id = @id; - DELETE FROM post_permalink WHERE post_id = @id; - DELETE FROM post_meta WHERE post_id = @id; - DELETE FROM post_episode WHERE post_id = @id; - DELETE FROM post_tag WHERE post_id = @id; - DELETE FROM post_category WHERE post_id = @id; - DELETE FROM post WHERE id = @id""" + cmd.CommandText <- + "DELETE FROM post_revision WHERE post_id = @id; + DELETE FROM post_permalink WHERE post_id = @id; + DELETE FROM post_tag WHERE post_id = @id; + DELETE FROM post_category WHERE post_id = @id; + DELETE FROM post_comment WHERE post_id = @id; + DELETE FROM post WHERE id = @id" do! write cmd return true | None -> return false @@ -366,19 +269,15 @@ type SQLitePostData (conn : SqliteConnection) = /// Find the current permalink from a list of potential prior permalinks for the given web log let findCurrentPermalink permalinks webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ + let linkSql, linkParams = inClause "AND pp.permalink" "link" Permalink.toString permalinks + cmd.CommandText <- $" SELECT p.permalink - FROM post p - INNER JOIN post_permalink pp ON pp.post_id = p.id - WHERE p.web_log_id = @webLogId - AND pp.permalink IN (""" - permalinks - |> List.iteri (fun idx link -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@link{idx}" - cmd.Parameters.AddWithValue ($"@link{idx}", Permalink.toString link) |> ignore) - cmd.CommandText <- $"{cmd.CommandText})" + FROM post p + INNER JOIN post_permalink pp ON pp.post_id = p.id + WHERE p.web_log_id = @webLogId + {linkSql}" addWebLogId cmd webLogId + cmd.Parameters.AddRange linkParams use! rdr = cmd.ExecuteReaderAsync () return if rdr.Read () then Some (Map.toPermalink rdr) else None } @@ -390,9 +289,9 @@ type SQLitePostData (conn : SqliteConnection) = addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () let! posts = - toList Map.toPost rdr + toList toPost rdr |> List.map (fun post -> backgroundTask { - let! post = appendPostCategoryTagAndMeta post + let! post = appendPostCategoryAndTag post return! appendPostRevisionsAndPermalinks post }) |> Task.WhenAll @@ -402,27 +301,22 @@ type SQLitePostData (conn : SqliteConnection) = /// Get a page of categorized posts for the given web log (excludes revisions and prior permalinks) let findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $""" + let catSql, catParams = inClause "AND pc.category_id" "catId" CategoryId.toString categoryIds + cmd.CommandText <- $" {selectPost} INNER JOIN post_category pc ON pc.post_id = p.id WHERE p.web_log_id = @webLogId AND p.status = @status - AND pc.category_id IN (""" - categoryIds - |> List.iteri (fun idx catId -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@catId{idx}" - cmd.Parameters.AddWithValue ($"@catId{idx}", CategoryId.toString catId) |> ignore) - cmd.CommandText <- - $"""{cmd.CommandText}) - ORDER BY published_on DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" + {catSql} + ORDER BY published_on DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore + cmd.Parameters.AddRange catParams use! rdr = cmd.ExecuteReaderAsync () let! posts = - toList Map.toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) + toList toPost rdr + |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) |> Task.WhenAll return List.ofArray posts } @@ -430,16 +324,16 @@ type SQLitePostData (conn : SqliteConnection) = /// Get a page of posts for the given web log (excludes text, revisions, and prior permalinks) let findPageOfPosts webLogId pageNbr postsPerPage = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $""" + cmd.CommandText <- $" {selectPost} - WHERE p.web_log_id = @webLogId - ORDER BY p.published_on DESC NULLS FIRST, p.updated_on - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" + WHERE p.web_log_id = @webLogId + ORDER BY p.published_on DESC NULLS FIRST, p.updated_on + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () let! posts = toList postWithoutText rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) + |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) |> Task.WhenAll return List.ofArray posts } @@ -447,18 +341,18 @@ type SQLitePostData (conn : SqliteConnection) = /// Get a page of published posts for the given web log (excludes revisions and prior permalinks) let findPageOfPublishedPosts webLogId pageNbr postsPerPage = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $""" + cmd.CommandText <- $" {selectPost} - WHERE p.web_log_id = @webLogId - AND p.status = @status - ORDER BY p.published_on DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" + WHERE p.web_log_id = @webLogId + AND p.status = @status + ORDER BY p.published_on DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore use! rdr = cmd.ExecuteReaderAsync () let! posts = - toList Map.toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) + toList toPost rdr + |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) |> Task.WhenAll return List.ofArray posts } @@ -466,60 +360,60 @@ type SQLitePostData (conn : SqliteConnection) = /// Get a page of tagged posts for the given web log (excludes revisions and prior permalinks) let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $""" + cmd.CommandText <- $" {selectPost} - INNER JOIN post_tag pt ON pt.post_id = p.id - WHERE p.web_log_id = @webLogId - AND p.status = @status - AND pt.tag = @tag - ORDER BY p.published_on DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" + INNER JOIN post_tag pt ON pt.post_id = p.id + WHERE p.web_log_id = @webLogId + AND p.status = @status + AND pt.tag = @tag + ORDER BY p.published_on DESC + LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}" addWebLogId cmd webLogId [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) cmd.Parameters.AddWithValue ("@tag", tag) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () let! posts = - toList Map.toPost rdr - |> List.map (fun post -> backgroundTask { return! appendPostCategoryTagAndMeta post }) + toList toPost rdr + |> List.map (fun post -> backgroundTask { return! appendPostCategoryAndTag post }) |> Task.WhenAll return List.ofArray posts } /// Find the next newest and oldest post from a publish date for the given web log - let findSurroundingPosts webLogId (publishedOn : DateTime) = backgroundTask { + let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- $""" + cmd.CommandText <- $" {selectPost} WHERE p.web_log_id = @webLogId AND p.status = @status AND p.published_on < @publishedOn ORDER BY p.published_on DESC - LIMIT 1""" + LIMIT 1" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) - cmd.Parameters.AddWithValue ("@publishedOn", publishedOn) + [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) + cmd.Parameters.AddWithValue ("@publishedOn", instantParam publishedOn) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () let! older = backgroundTask { if rdr.Read () then - let! post = appendPostCategoryTagAndMeta (postWithoutText rdr) + let! post = appendPostCategoryAndTag (postWithoutText rdr) return Some post else return None } do! rdr.CloseAsync () - cmd.CommandText <- $""" + cmd.CommandText <- $" {selectPost} WHERE p.web_log_id = @webLogId AND p.status = @status AND p.published_on > @publishedOn ORDER BY p.published_on - LIMIT 1""" + LIMIT 1" use! rdr = cmd.ExecuteReaderAsync () let! newer = backgroundTask { if rdr.Read () then - let! post = appendPostCategoryTagAndMeta (postWithoutText rdr) + let! post = appendPostCategoryAndTag (postWithoutText rdr) return Some post else return None @@ -538,24 +432,24 @@ type SQLitePostData (conn : SqliteConnection) = match! findFullById post.Id post.WebLogId with | Some oldPost -> use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE post - SET author_id = @authorId, - status = @status, - title = @title, - permalink = @permalink, - published_on = @publishedOn, - updated_on = @updatedOn, - template = @template, - post_text = @text - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE post + SET author_id = @authorId, + status = @status, + title = @title, + permalink = @permalink, + published_on = @publishedOn, + updated_on = @updatedOn, + template = @template, + post_text = @text, + episode = @episode, + meta_items = @metaItems + WHERE id = @id + AND web_log_id = @webLogId" addPostParameters cmd post do! write cmd do! updatePostCategories post.Id oldPost.CategoryIds post.CategoryIds do! updatePostTags post.Id oldPost.Tags post.Tags - do! updatePostEpisode post - do! updatePostMeta post.Id oldPost.Metadata post.Metadata do! updatePostPermalinks post.Id oldPost.PriorPermalinks post.PriorPermalinks do! updatePostRevisions post.Id oldPost.Revisions post.Revisions | None -> return () diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index 12f53a5..00de07b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -50,18 +50,14 @@ type SQLiteTagMapData (conn : SqliteConnection) = /// Find any tag mappings in a list of tags for the given web log let findMappingForTags (tags : string list) webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ + let mapSql, mapParams = inClause "AND tag" "tag" id tags + cmd.CommandText <- $" SELECT * - FROM tag_map - WHERE web_log_id = @webLogId - AND tag IN (""" - tags - |> List.iteri (fun idx tag -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@tag{idx}" - cmd.Parameters.AddWithValue ($"@tag{idx}", tag) |> ignore) - cmd.CommandText <- $"{cmd.CommandText})" + FROM tag_map + WHERE web_log_id = @webLogId + {mapSql}" addWebLogId cmd webLogId + cmd.Parameters.AddRange mapParams use! rdr = cmd.ExecuteReaderAsync () return toList Map.toTagMap rdr } @@ -71,23 +67,23 @@ type SQLiteTagMapData (conn : SqliteConnection) = use cmd = conn.CreateCommand () match! findById tagMap.Id tagMap.WebLogId with | Some _ -> - cmd.CommandText <- """ - UPDATE tag_map - SET tag = @tag, - url_value = @urlValue - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE tag_map + SET tag = @tag, + url_value = @urlValue + WHERE id = @id + AND web_log_id = @webLogId" | None -> - cmd.CommandText <- """ - INSERT INTO tag_map ( + cmd.CommandText <- + "INSERT INTO tag_map ( id, web_log_id, tag, url_value ) VALUES ( @id, @webLogId, @tag, @urlValue - )""" + )" addWebLogId cmd tagMap.WebLogId - [ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id) - cmd.Parameters.AddWithValue ("@tag", tagMap.Tag) - cmd.Parameters.AddWithValue ("@urlValue", tagMap.UrlValue) + [ cmd.Parameters.AddWithValue ("@id", TagMapId.toString tagMap.Id) + cmd.Parameters.AddWithValue ("@tag", tagMap.Tag) + cmd.Parameters.AddWithValue ("@urlValue", tagMap.UrlValue) ] |> ignore do! write cmd } diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index 53c4204..dd3d81b 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -17,13 +17,13 @@ type SQLiteThemeData (conn : SqliteConnection) = do! rdr.CloseAsync () cmd.CommandText <- "SELECT name, theme_id FROM theme_template WHERE theme_id <> 'admin' ORDER BY name" use! rdr = cmd.ExecuteReaderAsync () - let mutable templates = [] - while rdr.Read () do - templates <- (ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr) :: templates + let templates = + seq { while rdr.Read () do ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr } + |> List.ofSeq return themes |> List.map (fun t -> - { t with Templates = templates |> List.filter (fun tt -> fst tt = t.Id) |> List.map snd }) + { t with Templates = templates |> List.filter (fun (themeId, _) -> themeId = t.Id) |> List.map snd }) } /// Does a given theme exist? @@ -67,10 +67,10 @@ type SQLiteThemeData (conn : SqliteConnection) = match! findByIdWithoutText themeId with | Some _ -> use cmd = conn.CreateCommand () - cmd.CommandText <- """ - DELETE FROM theme_asset WHERE theme_id = @id; - DELETE FROM theme_template WHERE theme_id = @id; - DELETE FROM theme WHERE id = @id""" + cmd.CommandText <- + "DELETE FROM theme_asset WHERE theme_id = @id; + DELETE FROM theme_template WHERE theme_id = @id; + DELETE FROM theme WHERE id = @id" cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore do! write cmd return true @@ -85,15 +85,15 @@ type SQLiteThemeData (conn : SqliteConnection) = match oldTheme with | Some _ -> "UPDATE theme SET name = @name, version = @version WHERE id = @id" | None -> "INSERT INTO theme VALUES (@id, @name, @version)" - [ cmd.Parameters.AddWithValue ("@id", ThemeId.toString theme.Id) - cmd.Parameters.AddWithValue ("@name", theme.Name) - cmd.Parameters.AddWithValue ("@version", theme.Version) + [ cmd.Parameters.AddWithValue ("@id", ThemeId.toString theme.Id) + cmd.Parameters.AddWithValue ("@name", theme.Name) + cmd.Parameters.AddWithValue ("@version", theme.Version) ] |> ignore do! write cmd let toDelete, toAdd = - diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue []) - theme.Templates (fun t -> t.Name) + Utils.diffLists (oldTheme |> Option.map (fun t -> t.Templates) |> Option.defaultValue []) + theme.Templates (fun t -> t.Name) let toUpdate = theme.Templates |> List.filter (fun t -> @@ -102,9 +102,9 @@ type SQLiteThemeData (conn : SqliteConnection) = cmd.CommandText <- "UPDATE theme_template SET template = @template WHERE theme_id = @themeId AND name = @name" cmd.Parameters.Clear () - [ cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString theme.Id) - cmd.Parameters.Add ("@name", SqliteType.Text) - cmd.Parameters.Add ("@template", SqliteType.Text) + [ cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString theme.Id) + cmd.Parameters.Add ("@name", SqliteType.Text) + cmd.Parameters.Add ("@template", SqliteType.Text) ] |> ignore toUpdate |> List.map (fun template -> backgroundTask { @@ -169,8 +169,8 @@ type SQLiteThemeAssetData (conn : SqliteConnection) = use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT *, ROWID FROM theme_asset WHERE theme_id = @themeId AND path = @path" let (ThemeAssetId (ThemeId themeId, path)) = assetId - [ cmd.Parameters.AddWithValue ("@themeId", themeId) - cmd.Parameters.AddWithValue ("@path", path) + [ cmd.Parameters.AddWithValue ("@themeId", themeId) + cmd.Parameters.AddWithValue ("@path", path) ] |> ignore use! rdr = cmd.ExecuteReaderAsync () return if rdr.Read () then Some (Map.toThemeAsset true rdr) else None @@ -200,29 +200,29 @@ type SQLiteThemeAssetData (conn : SqliteConnection) = sideCmd.CommandText <- "SELECT COUNT(path) FROM theme_asset WHERE theme_id = @themeId AND path = @path" let (ThemeAssetId (ThemeId themeId, path)) = asset.Id - [ sideCmd.Parameters.AddWithValue ("@themeId", themeId) - sideCmd.Parameters.AddWithValue ("@path", path) + [ sideCmd.Parameters.AddWithValue ("@themeId", themeId) + sideCmd.Parameters.AddWithValue ("@path", path) ] |> ignore let! exists = count sideCmd use cmd = conn.CreateCommand () cmd.CommandText <- if exists = 1 then - """UPDATE theme_asset - SET updated_on = @updatedOn, - data = ZEROBLOB(@dataLength) - WHERE theme_id = @themeId - AND path = @path""" + "UPDATE theme_asset + SET updated_on = @updatedOn, + data = ZEROBLOB(@dataLength) + WHERE theme_id = @themeId + AND path = @path" else - """INSERT INTO theme_asset ( - theme_id, path, updated_on, data - ) VALUES ( - @themeId, @path, @updatedOn, ZEROBLOB(@dataLength) - )""" - [ cmd.Parameters.AddWithValue ("@themeId", themeId) - cmd.Parameters.AddWithValue ("@path", path) - cmd.Parameters.AddWithValue ("@updatedOn", asset.UpdatedOn) - cmd.Parameters.AddWithValue ("@dataLength", asset.Data.Length) + "INSERT INTO theme_asset ( + theme_id, path, updated_on, data + ) VALUES ( + @themeId, @path, @updatedOn, ZEROBLOB(@dataLength) + )" + [ cmd.Parameters.AddWithValue ("@themeId", themeId) + cmd.Parameters.AddWithValue ("@path", path) + cmd.Parameters.AddWithValue ("@updatedOn", instantParam asset.UpdatedOn) + cmd.Parameters.AddWithValue ("@dataLength", asset.Data.Length) ] |> ignore do! write cmd diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs index 3960194..886e113 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -10,22 +10,22 @@ type SQLiteUploadData (conn : SqliteConnection) = /// Add parameters for uploaded file INSERT and UPDATE statements let addUploadParameters (cmd : SqliteCommand) (upload : Upload) = - [ cmd.Parameters.AddWithValue ("@id", UploadId.toString upload.Id) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString upload.WebLogId) - cmd.Parameters.AddWithValue ("@path", Permalink.toString upload.Path) - cmd.Parameters.AddWithValue ("@updatedOn", upload.UpdatedOn) + [ cmd.Parameters.AddWithValue ("@id", UploadId.toString upload.Id) + cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString upload.WebLogId) + cmd.Parameters.AddWithValue ("@path", Permalink.toString upload.Path) + cmd.Parameters.AddWithValue ("@updatedOn", instantParam upload.UpdatedOn) cmd.Parameters.AddWithValue ("@dataLength", upload.Data.Length) ] |> ignore /// Save an uploaded file let add upload = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO upload ( + cmd.CommandText <- + "INSERT INTO upload ( id, web_log_id, path, updated_on, data ) VALUES ( @id, @webLogId, @path, @updatedOn, ZEROBLOB(@dataLength) - )""" + )" addUploadParameters cmd upload do! write cmd @@ -40,11 +40,11 @@ type SQLiteUploadData (conn : SqliteConnection) = /// Delete an uploaded file by its ID let delete uploadId webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - SELECT id, web_log_id, path, updated_on - FROM upload - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "SELECT id, web_log_id, path, updated_on + FROM upload + WHERE id = @id + AND web_log_id = @webLogId" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@id", UploadId.toString uploadId) |> ignore let! rdr = cmd.ExecuteReaderAsync () diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 7013583..aa34719 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -4,81 +4,64 @@ open System.Threading.Tasks open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data +open Newtonsoft.Json // The web log podcast insert loop is not statically compilable; this is OK #nowarn "3511" /// SQLite myWebLog web log data implementation -type SQLiteWebLogData (conn : SqliteConnection) = +type SQLiteWebLogData (conn : SqliteConnection, ser : JsonSerializer) = // SUPPORT FUNCTIONS /// Add parameters for web log INSERT or web log/RSS options UPDATE statements let addWebLogRssParameters (cmd : SqliteCommand) (webLog : WebLog) = - [ cmd.Parameters.AddWithValue ("@isFeedEnabled", webLog.Rss.IsFeedEnabled) - cmd.Parameters.AddWithValue ("@feedName", webLog.Rss.FeedName) - cmd.Parameters.AddWithValue ("@itemsInFeed", maybe webLog.Rss.ItemsInFeed) + [ cmd.Parameters.AddWithValue ("@isFeedEnabled", webLog.Rss.IsFeedEnabled) + cmd.Parameters.AddWithValue ("@feedName", webLog.Rss.FeedName) + cmd.Parameters.AddWithValue ("@itemsInFeed", maybe webLog.Rss.ItemsInFeed) cmd.Parameters.AddWithValue ("@isCategoryEnabled", webLog.Rss.IsCategoryEnabled) - cmd.Parameters.AddWithValue ("@isTagEnabled", webLog.Rss.IsTagEnabled) - cmd.Parameters.AddWithValue ("@copyright", maybe webLog.Rss.Copyright) + cmd.Parameters.AddWithValue ("@isTagEnabled", webLog.Rss.IsTagEnabled) + cmd.Parameters.AddWithValue ("@copyright", maybe webLog.Rss.Copyright) ] |> ignore /// Add parameters for web log INSERT or UPDATE statements let addWebLogParameters (cmd : SqliteCommand) (webLog : WebLog) = - [ cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) - cmd.Parameters.AddWithValue ("@name", webLog.Name) - cmd.Parameters.AddWithValue ("@slug", webLog.Slug) - cmd.Parameters.AddWithValue ("@subtitle", maybe webLog.Subtitle) - cmd.Parameters.AddWithValue ("@defaultPage", webLog.DefaultPage) + [ cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) + cmd.Parameters.AddWithValue ("@name", webLog.Name) + cmd.Parameters.AddWithValue ("@slug", webLog.Slug) + cmd.Parameters.AddWithValue ("@subtitle", maybe webLog.Subtitle) + cmd.Parameters.AddWithValue ("@defaultPage", webLog.DefaultPage) cmd.Parameters.AddWithValue ("@postsPerPage", webLog.PostsPerPage) - cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString webLog.ThemeId) - cmd.Parameters.AddWithValue ("@urlBase", webLog.UrlBase) - cmd.Parameters.AddWithValue ("@timeZone", webLog.TimeZone) - cmd.Parameters.AddWithValue ("@autoHtmx", webLog.AutoHtmx) - cmd.Parameters.AddWithValue ("@uploads", UploadDestination.toString webLog.Uploads) + cmd.Parameters.AddWithValue ("@themeId", ThemeId.toString webLog.ThemeId) + cmd.Parameters.AddWithValue ("@urlBase", webLog.UrlBase) + cmd.Parameters.AddWithValue ("@timeZone", webLog.TimeZone) + cmd.Parameters.AddWithValue ("@autoHtmx", webLog.AutoHtmx) + cmd.Parameters.AddWithValue ("@uploads", UploadDestination.toString webLog.Uploads) ] |> ignore addWebLogRssParameters cmd webLog /// Add parameters for custom feed INSERT or UPDATE statements let addCustomFeedParameters (cmd : SqliteCommand) webLogId (feed : CustomFeed) = - [ cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString feed.Id) + [ cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString feed.Id) cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) - cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source) - cmd.Parameters.AddWithValue ("@path", Permalink.toString feed.Path) + cmd.Parameters.AddWithValue ("@source", CustomFeedSource.toString feed.Source) + cmd.Parameters.AddWithValue ("@path", Permalink.toString feed.Path) + cmd.Parameters.AddWithValue ("@podcast", maybe (if Option.isSome feed.Podcast then + Some (Utils.serialize ser feed.Podcast) + else None)) ] |> ignore - /// Add parameters for podcast INSERT or UPDATE statements - let addPodcastParameters (cmd : SqliteCommand) feedId (podcast : PodcastOptions) = - [ cmd.Parameters.AddWithValue ("@feedId", CustomFeedId.toString feedId) - cmd.Parameters.AddWithValue ("@title", podcast.Title) - cmd.Parameters.AddWithValue ("@subtitle", maybe podcast.Subtitle) - cmd.Parameters.AddWithValue ("@itemsInFeed", podcast.ItemsInFeed) - cmd.Parameters.AddWithValue ("@summary", podcast.Summary) - cmd.Parameters.AddWithValue ("@displayedAuthor", podcast.DisplayedAuthor) - cmd.Parameters.AddWithValue ("@email", podcast.Email) - cmd.Parameters.AddWithValue ("@imageUrl", Permalink.toString podcast.ImageUrl) - cmd.Parameters.AddWithValue ("@appleCategory", podcast.AppleCategory) - cmd.Parameters.AddWithValue ("@appleSubcategory", maybe podcast.AppleSubcategory) - cmd.Parameters.AddWithValue ("@explicit", ExplicitRating.toString podcast.Explicit) - cmd.Parameters.AddWithValue ("@defaultMediaType", maybe podcast.DefaultMediaType) - cmd.Parameters.AddWithValue ("@mediaBaseUrl", maybe podcast.MediaBaseUrl) - cmd.Parameters.AddWithValue ("@podcastGuid", maybe podcast.PodcastGuid) - cmd.Parameters.AddWithValue ("@fundingUrl", maybe podcast.FundingUrl) - cmd.Parameters.AddWithValue ("@fundingText", maybe podcast.FundingText) - cmd.Parameters.AddWithValue ("@medium", maybe (podcast.Medium |> Option.map PodcastMedium.toString)) - ] |> ignore - + /// Shorthand to map a data reader to a custom feed + let toCustomFeed = + Map.toCustomFeed ser + /// Get the current custom feeds for a web log let getCustomFeeds (webLog : WebLog) = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - SELECT f.*, p.* - FROM web_log_feed f - LEFT JOIN web_log_feed_podcast p ON p.feed_id = f.id - WHERE f.web_log_id = @webLogId""" + cmd.CommandText <- "SELECT * FROM web_log_feed WHERE web_log_id = @webLogId" addWebLogId cmd webLog.Id use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toCustomFeed rdr + return toList toCustomFeed rdr } /// Append custom feeds to a web log @@ -87,27 +70,10 @@ type SQLiteWebLogData (conn : SqliteConnection) = return { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } } } - /// Add a podcast to a custom feed - let addPodcast feedId (podcast : PodcastOptions) = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO web_log_feed_podcast ( - feed_id, title, subtitle, items_in_feed, summary, displayed_author, email, image_url, - apple_category, apple_subcategory, explicit, default_media_type, media_base_url, podcast_guid, - funding_url, funding_text, medium - ) VALUES ( - @feedId, @title, @subtitle, @itemsInFeed, @summary, @displayedAuthor, @email, @imageUrl, - @appleCategory, @appleSubcategory, @explicit, @defaultMediaType, @mediaBaseUrl, @podcastGuid, - @fundingUrl, @fundingText, @medium - )""" - addPodcastParameters cmd feedId podcast - do! write cmd - } - /// Update the custom feeds for a web log let updateCustomFeeds (webLog : WebLog) = backgroundTask { let! feeds = getCustomFeeds webLog - let toDelete, toAdd = diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}") + let toDelete, toAdd = Utils.diffLists feeds webLog.Rss.CustomFeeds (fun it -> $"{CustomFeedId.toString it.Id}") let toId (feed : CustomFeed) = feed.Id let toUpdate = webLog.Rss.CustomFeeds @@ -117,9 +83,7 @@ type SQLiteWebLogData (conn : SqliteConnection) = cmd.Parameters.Add ("@id", SqliteType.Text) |> ignore toDelete |> List.map (fun it -> backgroundTask { - cmd.CommandText <- """ - DELETE FROM web_log_feed_podcast WHERE feed_id = @id; - DELETE FROM web_log_feed WHERE id = @id""" + cmd.CommandText <- "DELETE FROM web_log_feed WHERE id = @id" cmd.Parameters["@id"].Value <- CustomFeedId.toString it.Id do! write cmd }) @@ -128,68 +92,30 @@ type SQLiteWebLogData (conn : SqliteConnection) = cmd.Parameters.Clear () toAdd |> List.map (fun it -> backgroundTask { - cmd.CommandText <- """ - INSERT INTO web_log_feed ( - id, web_log_id, source, path + cmd.CommandText <- + "INSERT INTO web_log_feed ( + id, web_log_id, source, path, podcast ) VALUES ( - @id, @webLogId, @source, @path - )""" + @id, @webLogId, @source, @path, @podcast + )" cmd.Parameters.Clear () addCustomFeedParameters cmd webLog.Id it do! write cmd - match it.Podcast with - | Some podcast -> do! addPodcast it.Id podcast - | None -> () }) |> Task.WhenAll |> ignore toUpdate |> List.map (fun it -> backgroundTask { - cmd.CommandText <- """ - UPDATE web_log_feed - SET source = @source, - path = @path - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE web_log_feed + SET source = @source, + path = @path, + podcast = @podcast + WHERE id = @id + AND web_log_id = @webLogId" cmd.Parameters.Clear () addCustomFeedParameters cmd webLog.Id it do! write cmd - let hadPodcast = Option.isSome (feeds |> List.find (fun f -> f.Id = it.Id)).Podcast - match it.Podcast with - | Some podcast -> - if hadPodcast then - cmd.CommandText <- """ - UPDATE web_log_feed_podcast - SET title = @title, - subtitle = @subtitle, - items_in_feed = @itemsInFeed, - summary = @summary, - displayed_author = @displayedAuthor, - email = @email, - image_url = @imageUrl, - apple_category = @appleCategory, - apple_subcategory = @appleSubcategory, - explicit = @explicit, - default_media_type = @defaultMediaType, - media_base_url = @mediaBaseUrl, - podcast_guid = @podcastGuid, - funding_url = @fundingUrl, - funding_text = @fundingText, - medium = @medium - WHERE feed_id = @feedId""" - cmd.Parameters.Clear () - addPodcastParameters cmd it.Id podcast - do! write cmd - else - do! addPodcast it.Id podcast - | None -> - if hadPodcast then - cmd.CommandText <- "DELETE FROM web_log_feed_podcast WHERE feed_id = @id" - cmd.Parameters.Clear () - cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString it.Id) |> ignore - do! write cmd - else - () }) |> Task.WhenAll |> ignore @@ -200,14 +126,14 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// Add a web log let add webLog = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO web_log ( + cmd.CommandText <- + "INSERT INTO web_log ( id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx, uploads, is_feed_enabled, feed_name, items_in_feed, is_category_enabled, is_tag_enabled, copyright ) VALUES ( @id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx, @uploads, @isFeedEnabled, @feedName, @itemsInFeed, @isCategoryEnabled, @isTagEnabled, @copyright - )""" + )" addWebLogParameters cmd webLog do! write cmd do! updateCustomFeeds webLog @@ -232,26 +158,22 @@ type SQLiteWebLogData (conn : SqliteConnection) = let subQuery table = $"(SELECT id FROM {table} WHERE web_log_id = @webLogId)" let postSubQuery = subQuery "post" let pageSubQuery = subQuery "page" - cmd.CommandText <- $""" - DELETE FROM post_comment WHERE post_id IN {postSubQuery}; - DELETE FROM post_revision WHERE post_id IN {postSubQuery}; - DELETE FROM post_permalink WHERE post_id IN {postSubQuery}; - DELETE FROM post_episode WHERE post_id IN {postSubQuery}; - DELETE FROM post_tag WHERE post_id IN {postSubQuery}; - DELETE FROM post_category WHERE post_id IN {postSubQuery}; - DELETE FROM post_meta WHERE post_id IN {postSubQuery}; - DELETE FROM post WHERE web_log_id = @webLogId; - DELETE FROM page_revision WHERE page_id IN {pageSubQuery}; - DELETE FROM page_permalink WHERE page_id IN {pageSubQuery}; - DELETE FROM page_meta WHERE page_id IN {pageSubQuery}; - DELETE FROM page WHERE web_log_id = @webLogId; - DELETE FROM category WHERE web_log_id = @webLogId; - DELETE FROM tag_map WHERE web_log_id = @webLogId; - DELETE FROM upload WHERE web_log_id = @webLogId; - DELETE FROM web_log_user WHERE web_log_id = @webLogId; - DELETE FROM web_log_feed_podcast WHERE feed_id IN {subQuery "web_log_feed"}; - DELETE FROM web_log_feed WHERE web_log_id = @webLogId; - DELETE FROM web_log WHERE id = @webLogId""" + cmd.CommandText <- $" + DELETE FROM post_comment WHERE post_id IN {postSubQuery}; + DELETE FROM post_revision WHERE post_id IN {postSubQuery}; + DELETE FROM post_permalink WHERE post_id IN {postSubQuery}; + DELETE FROM post_tag 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_permalink 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" do! write cmd } @@ -284,25 +206,25 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// Update settings for a web log let updateSettings webLog = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - 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""" + cmd.CommandText <- + "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" addWebLogParameters cmd webLog do! write cmd } @@ -310,15 +232,15 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// Update RSS options for a web log let updateRssOptions webLog = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE web_log - SET is_feed_enabled = @isFeedEnabled, - feed_name = @feedName, - items_in_feed = @itemsInFeed, - is_category_enabled = @isCategoryEnabled, - is_tag_enabled = @isTagEnabled, - copyright = @copyright - WHERE id = @id""" + cmd.CommandText <- + "UPDATE web_log + SET is_feed_enabled = @isFeedEnabled, + feed_name = @feedName, + items_in_feed = @itemsInFeed, + is_category_enabled = @isCategoryEnabled, + is_tag_enabled = @isTagEnabled, + copyright = @copyright + WHERE id = @id" addWebLogRssParameters cmd webLog cmd.Parameters.AddWithValue ("@id", WebLogId.toString webLog.Id) |> ignore do! write cmd diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 334dc6a..8eb8cd9 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -1,6 +1,5 @@ namespace MyWebLog.Data.SQLite -open System open Microsoft.Data.Sqlite open MyWebLog open MyWebLog.Data @@ -12,18 +11,17 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Add parameters for web log user INSERT or UPDATE statements let addWebLogUserParameters (cmd : SqliteCommand) (user : WebLogUser) = - [ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString user.Id) - cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString user.WebLogId) - cmd.Parameters.AddWithValue ("@email", user.Email) - cmd.Parameters.AddWithValue ("@firstName", user.FirstName) - cmd.Parameters.AddWithValue ("@lastName", user.LastName) + [ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString user.Id) + cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString user.WebLogId) + cmd.Parameters.AddWithValue ("@email", user.Email) + cmd.Parameters.AddWithValue ("@firstName", user.FirstName) + cmd.Parameters.AddWithValue ("@lastName", user.LastName) cmd.Parameters.AddWithValue ("@preferredName", user.PreferredName) - cmd.Parameters.AddWithValue ("@passwordHash", user.PasswordHash) - cmd.Parameters.AddWithValue ("@salt", user.Salt) - cmd.Parameters.AddWithValue ("@url", maybe user.Url) - cmd.Parameters.AddWithValue ("@accessLevel", AccessLevel.toString user.AccessLevel) - cmd.Parameters.AddWithValue ("@createdOn", user.CreatedOn) - cmd.Parameters.AddWithValue ("@lastSeenOn", maybe user.LastSeenOn) + cmd.Parameters.AddWithValue ("@passwordHash", user.PasswordHash) + cmd.Parameters.AddWithValue ("@url", maybe user.Url) + cmd.Parameters.AddWithValue ("@accessLevel", AccessLevel.toString user.AccessLevel) + cmd.Parameters.AddWithValue ("@createdOn", instantParam user.CreatedOn) + cmd.Parameters.AddWithValue ("@lastSeenOn", maybeInstant user.LastSeenOn) ] |> ignore // IMPLEMENTATION FUNCTIONS @@ -31,14 +29,14 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Add a user let add user = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - INSERT INTO web_log_user ( - id, web_log_id, email, first_name, last_name, preferred_name, password_hash, salt, url, access_level, + cmd.CommandText <- + "INSERT INTO web_log_user ( + id, web_log_id, email, first_name, last_name, preferred_name, password_hash, url, access_level, created_on, last_seen_on ) VALUES ( - @id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @salt, @url, @accessLevel, + @id, @webLogId, @email, @firstName, @lastName, @preferredName, @passwordHash, @url, @accessLevel, @createdOn, @lastSeenOn - )""" + )" addWebLogUserParameters cmd user do! write cmd } @@ -93,14 +91,10 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Find the names of users by their IDs for the given web log let findNames webLogId userIds = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND id IN (" - userIds - |> List.iteri (fun idx userId -> - if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, " - cmd.CommandText <- $"{cmd.CommandText}@id{idx}" - cmd.Parameters.AddWithValue ($"@id{idx}", WebLogUserId.toString userId) |> ignore) - cmd.CommandText <- $"{cmd.CommandText})" + let nameSql, nameParams = inClause "AND id" "id" WebLogUserId.toString userIds + cmd.CommandText <- $"SELECT * FROM web_log_user WHERE web_log_id = @webLogId {nameSql}" addWebLogId cmd webLogId + cmd.Parameters.AddRange nameParams use! rdr = cmd.ExecuteReaderAsync () return toList Map.toWebLogUser rdr @@ -116,14 +110,14 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Set a user's last seen date/time to now let setLastSeen userId webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE web_log_user - SET last_seen_on = @lastSeenOn - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE web_log_user + SET last_seen_on = @lastSeenOn + WHERE id = @id + AND web_log_id = @webLogId" addWebLogId cmd webLogId - [ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) - cmd.Parameters.AddWithValue ("@lastSeenOn", DateTime.UtcNow) + [ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) + cmd.Parameters.AddWithValue ("@lastSeenOn", instantParam (Noda.now ())) ] |> ignore let! _ = cmd.ExecuteNonQueryAsync () () @@ -132,20 +126,19 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Update a user let update user = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- """ - UPDATE web_log_user - SET email = @email, - first_name = @firstName, - last_name = @lastName, - preferred_name = @preferredName, - password_hash = @passwordHash, - salt = @salt, - url = @url, - access_level = @accessLevel, - created_on = @createdOn, - last_seen_on = @lastSeenOn - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- + "UPDATE web_log_user + 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 + WHERE id = @id + AND web_log_id = @webLogId" addWebLogUserParameters cmd user do! write cmd } diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index 3d356f4..3c3bf91 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -2,20 +2,545 @@ namespace MyWebLog.Data open Microsoft.Data.Sqlite open Microsoft.Extensions.Logging +open MyWebLog open MyWebLog.Data.SQLite +open Newtonsoft.Json +open NodaTime /// SQLite myWebLog data implementation -type SQLiteData (conn : SqliteConnection, log : ILogger) = +type SQLiteData (conn : SqliteConnection, log : ILogger, ser : JsonSerializer) = - /// Determine if the given table exists - let tableExists (table : string) = backgroundTask { + let ensureTables () = backgroundTask { + use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table" - cmd.Parameters.AddWithValue ("@table", table) |> ignore - let! count = count cmd - return count = 1 + + let! tables = backgroundTask { + cmd.CommandText <- "SELECT name FROM sqlite_master WHERE type = 'table'" + let! rdr = cmd.ExecuteReaderAsync () + let mutable tableList = [] + while rdr.Read() do + tableList <- Map.getString "name" rdr :: tableList + do! rdr.CloseAsync () + return tableList + } + let needsTable table = + not (List.contains table tables) + seq { + // Theme tables + if needsTable "theme" then + "CREATE TABLE theme ( + id TEXT 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 TEXT NOT NULL, + data BLOB NOT NULL, + PRIMARY KEY (theme_id, path))" + + // Web log tables + if needsTable "web_log" then + "CREATE TABLE web_log ( + id TEXT 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 INTEGER NOT NULL DEFAULT 0, + uploads TEXT NOT NULL, + is_feed_enabled INTEGER NOT NULL DEFAULT 0, + feed_name TEXT NOT NULL, + items_in_feed INTEGER, + is_category_enabled INTEGER NOT NULL DEFAULT 0, + is_tag_enabled INTEGER NOT NULL DEFAULT 0, + copyright TEXT); + CREATE INDEX web_log_theme_idx ON web_log (theme_id)" + if needsTable "web_log_feed" then + "CREATE TABLE web_log_feed ( + id TEXT PRIMARY KEY, + web_log_id TEXT NOT NULL REFERENCES web_log (id), + source TEXT NOT NULL, + path TEXT NOT NULL, + podcast TEXT); + 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 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 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 TEXT NOT NULL, + last_seen_on TEXT); + CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id); + CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)" + + // Page tables + if needsTable "page" then + "CREATE TABLE page ( + id TEXT PRIMARY KEY, + web_log_id TEXT NOT NULL REFERENCES web_log (id), + author_id TEXT NOT NULL REFERENCES web_log_user (id), + title TEXT NOT NULL, + permalink TEXT NOT NULL, + published_on TEXT NOT NULL, + updated_on TEXT NOT NULL, + is_in_page_list INTEGER NOT NULL DEFAULT 0, + template TEXT, + page_text TEXT NOT NULL, + meta_items TEXT); + CREATE INDEX page_web_log_idx ON page (web_log_id); + CREATE INDEX page_author_idx ON page (author_id); + CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)" + if needsTable "page_permalink" then + "CREATE TABLE page_permalink ( + page_id TEXT NOT NULL REFERENCES page (id), + permalink TEXT NOT NULL, + PRIMARY KEY (page_id, permalink))" + if needsTable "page_revision" then + "CREATE TABLE page_revision ( + page_id TEXT NOT NULL REFERENCES page (id), + as_of TEXT NOT NULL, + revision_text TEXT NOT NULL, + PRIMARY KEY (page_id, as_of))" + + // Post tables + if needsTable "post" then + "CREATE TABLE post ( + id TEXT PRIMARY KEY, + web_log_id TEXT NOT NULL REFERENCES web_log (id), + author_id TEXT NOT NULL REFERENCES web_log_user (id), + status TEXT NOT NULL, + title TEXT NOT NULL, + permalink TEXT NOT NULL, + published_on TEXT, + updated_on TEXT NOT NULL, + template TEXT, + post_text TEXT NOT NULL, + meta_items TEXT, + episode TEXT); + CREATE INDEX post_web_log_idx ON post (web_log_id); + CREATE INDEX post_author_idx ON post (author_id); + CREATE INDEX post_status_idx ON post (web_log_id, status, updated_on); + CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)" + 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_tag" then + "CREATE TABLE post_tag ( + post_id TEXT NOT NULL REFERENCES post (id), + tag TEXT NOT NULL, + PRIMARY KEY (post_id, tag))" + if needsTable "post_permalink" then + "CREATE TABLE post_permalink ( + post_id TEXT NOT NULL REFERENCES post (id), + permalink TEXT NOT NULL, + PRIMARY KEY (post_id, permalink))" + if needsTable "post_revision" then + "CREATE TABLE post_revision ( + post_id TEXT NOT NULL REFERENCES post (id), + as_of TEXT NOT NULL, + revision_text TEXT NOT NULL, + PRIMARY KEY (post_id, as_of))" + if needsTable "post_comment" then + "CREATE TABLE post_comment ( + id TEXT PRIMARY KEY, + post_id TEXT NOT NULL REFERENCES post(id), + in_reply_to_id TEXT, + name TEXT NOT NULL, + email TEXT NOT NULL, + url TEXT, + status TEXT NOT NULL, + posted_on TEXT NOT NULL, + comment_text TEXT NOT NULL); + CREATE INDEX post_comment_post_idx ON post_comment (post_id)" + + // Tag map table + if needsTable "tag_map" then + "CREATE TABLE tag_map ( + id TEXT PRIMARY KEY, + web_log_id TEXT NOT NULL REFERENCES web_log (id), + tag TEXT NOT NULL, + url_value TEXT NOT NULL); + CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)" + + // Uploaded file table + if needsTable "upload" then + "CREATE TABLE upload ( + id TEXT PRIMARY KEY, + web_log_id TEXT NOT NULL REFERENCES web_log (id), + path TEXT NOT NULL, + updated_on TEXT NOT NULL, + data BLOB NOT NULL); + CREATE INDEX upload_web_log_idx ON upload (web_log_id); + CREATE INDEX upload_path_idx ON upload (web_log_id, path)" + + // Database version table + if needsTable "db_version" then + "CREATE TABLE db_version (id TEXT PRIMARY KEY); + INSERT INTO db_version VALUES ('v2-rc1')" + } + |> Seq.map (fun sql -> + log.LogInformation $"Creating {(sql.Split ' ')[2]} table..." + cmd.CommandText <- sql + write cmd |> Async.AwaitTask |> Async.RunSynchronously) + |> List.ofSeq + |> ignore } + /// Set the database version to the specified version + let setDbVersion version = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')" + do! write cmd + } + + /// Implement the changes between v2-rc1 and v2-rc2 + let migrateV2Rc1ToV2Rc2 () = backgroundTask { + let logStep = Utils.logMigrationStep log "v2-rc1 to v2-rc2" + // Move meta items, podcast settings, and episode details to JSON-encoded text fields + use cmd = conn.CreateCommand () + logStep "Adding new columns" + cmd.CommandText <- + "ALTER TABLE web_log_feed ADD COLUMN podcast TEXT; + ALTER TABLE page ADD COLUMN meta_items TEXT; + ALTER TABLE post ADD COLUMN meta_items TEXT; + ALTER TABLE post ADD COLUMN episode TEXT" + do! write cmd + logStep "Migrating meta items" + let migrateMeta entity = backgroundTask { + cmd.CommandText <- $"SELECT * FROM %s{entity}_meta" + use! metaRdr = cmd.ExecuteReaderAsync () + let allMetas = + seq { + while metaRdr.Read () do + Map.getString $"{entity}_id" metaRdr, + { Name = Map.getString "name" metaRdr; Value = Map.getString "value" metaRdr } + } |> List.ofSeq + metaRdr.Close () + let metas = + allMetas + |> List.map fst + |> List.distinct + |> List.map (fun it -> it, allMetas |> List.filter (fun meta -> fst meta = it)) + metas + |> List.iter (fun (entityId, items) -> + cmd.CommandText <- + "UPDATE post + SET meta_items = @metaItems + WHERE id = @postId" + [ cmd.Parameters.AddWithValue ("@metaItems", Utils.serialize ser items) + cmd.Parameters.AddWithValue ("@id", entityId) ] |> ignore + let _ = cmd.ExecuteNonQuery () + cmd.Parameters.Clear ()) + } + do! migrateMeta "page" + do! migrateMeta "post" + logStep "Migrating podcasts and episodes" + cmd.CommandText <- "SELECT * FROM web_log_feed_podcast" + use! podcastRdr = cmd.ExecuteReaderAsync () + let podcasts = + seq { + while podcastRdr.Read () do + CustomFeedId (Map.getString "feed_id" podcastRdr), + { Title = Map.getString "title" podcastRdr + Subtitle = Map.tryString "subtitle" podcastRdr + ItemsInFeed = Map.getInt "items_in_feed" podcastRdr + Summary = Map.getString "summary" podcastRdr + DisplayedAuthor = Map.getString "displayed_author" podcastRdr + Email = Map.getString "email" podcastRdr + ImageUrl = Map.getString "image_url" podcastRdr |> Permalink + AppleCategory = Map.getString "apple_category" podcastRdr + AppleSubcategory = Map.tryString "apple_subcategory" podcastRdr + Explicit = Map.getString "explicit" podcastRdr |> ExplicitRating.parse + DefaultMediaType = Map.tryString "default_media_type" podcastRdr + MediaBaseUrl = Map.tryString "media_base_url" podcastRdr + PodcastGuid = Map.tryGuid "podcast_guid" podcastRdr + FundingUrl = Map.tryString "funding_url" podcastRdr + FundingText = Map.tryString "funding_text" podcastRdr + Medium = Map.tryString "medium" podcastRdr + |> Option.map PodcastMedium.parse + } + } |> List.ofSeq + podcastRdr.Close () + podcasts + |> List.iter (fun (feedId, podcast) -> + cmd.CommandText <- "UPDATE web_log_feed SET podcast = @podcast WHERE id = @id" + [ cmd.Parameters.AddWithValue ("@podcast", Utils.serialize ser podcast) + cmd.Parameters.AddWithValue ("@id", CustomFeedId.toString feedId) ] |> ignore + let _ = cmd.ExecuteNonQuery () + cmd.Parameters.Clear ()) + cmd.CommandText <- "SELECT * FROM post_episode" + use! epRdr = cmd.ExecuteReaderAsync () + let episodes = + seq { + while epRdr.Read () do + PostId (Map.getString "post_id" epRdr), + { Media = Map.getString "media" epRdr + Length = Map.getLong "length" epRdr + Duration = Map.tryTimeSpan "duration" epRdr + |> Option.map Duration.FromTimeSpan + MediaType = Map.tryString "media_type" epRdr + ImageUrl = Map.tryString "image_url" epRdr + Subtitle = Map.tryString "subtitle" epRdr + Explicit = Map.tryString "explicit" epRdr + |> Option.map ExplicitRating.parse + ChapterFile = Map.tryString "chapter_file" epRdr + ChapterType = Map.tryString "chapter_type" epRdr + TranscriptUrl = Map.tryString "transcript_url" epRdr + TranscriptType = Map.tryString "transcript_type" epRdr + TranscriptLang = Map.tryString "transcript_lang" epRdr + TranscriptCaptions = Map.tryBoolean "transcript_captions" epRdr + SeasonNumber = Map.tryInt "season_number" epRdr + SeasonDescription = Map.tryString "season_description" epRdr + EpisodeNumber = Map.tryString "episode_number" epRdr + |> Option.map System.Double.Parse + EpisodeDescription = Map.tryString "episode_description" epRdr + } + } |> List.ofSeq + epRdr.Close () + episodes + |> List.iter (fun (postId, episode) -> + cmd.CommandText <- "UPDATE post SET episode = @episode WHERE id = @id" + [ cmd.Parameters.AddWithValue ("@episode", Utils.serialize ser episode) + cmd.Parameters.AddWithValue ("@id", PostId.toString postId) ] |> ignore + let _ = cmd.ExecuteNonQuery () + cmd.Parameters.Clear ()) + + logStep "Migrating dates/times" + let inst (dt : System.DateTime) = + System.DateTime (dt.Ticks, System.DateTimeKind.Utc) + |> (Instant.FromDateTimeUtc >> Noda.toSecondsPrecision) + // page.updated_on, page.published_on + cmd.CommandText <- "SELECT id, updated_on, published_on FROM page" + use! pageRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while pageRdr.Read () do + Map.getString "id" pageRdr, + inst (Map.getDateTime "updated_on" pageRdr), + inst (Map.getDateTime "published_on" pageRdr) + } |> List.ofSeq + pageRdr.Close () + cmd.CommandText <- "UPDATE page SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id" + [ cmd.Parameters.Add ("@id", SqliteType.Text) + cmd.Parameters.Add ("@updatedOn", SqliteType.Text) + cmd.Parameters.Add ("@publishedOn", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (pageId, updatedOn, publishedOn) -> + cmd.Parameters["@id" ].Value <- pageId + cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn + cmd.Parameters["@publishedOn"].Value <- instantParam publishedOn + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // page_revision.as_of + cmd.CommandText <- "SELECT * FROM page_revision" + use! pageRevRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while pageRevRdr.Read () do + let asOf = Map.getDateTime "as_of" pageRevRdr + Map.getString "page_id" pageRevRdr, asOf, inst asOf, Map.getString "revision_text" pageRevRdr + } |> List.ofSeq + pageRevRdr.Close () + cmd.CommandText <- + "DELETE FROM page_revision WHERE page_id = @pageId AND as_of = @oldAsOf; + INSERT INTO page_revision (page_id, as_of, revision_text) VALUES (@pageId, @asOf, @text)" + [ cmd.Parameters.Add ("@pageId", SqliteType.Text) + cmd.Parameters.Add ("@oldAsOf", SqliteType.Text) + cmd.Parameters.Add ("@asOf", SqliteType.Text) + cmd.Parameters.Add ("@text", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (pageId, oldAsOf, asOf, text) -> + cmd.Parameters["@pageId" ].Value <- pageId + cmd.Parameters["@oldAsOf"].Value <- oldAsOf + cmd.Parameters["@asOf" ].Value <- instantParam asOf + cmd.Parameters["@text" ].Value <- text + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // post.updated_on, post.published_on (opt) + cmd.CommandText <- "SELECT id, updated_on, published_on FROM post" + use! postRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while postRdr.Read () do + Map.getString "id" postRdr, + inst (Map.getDateTime "updated_on" postRdr), + (Map.tryDateTime "published_on" postRdr |> Option.map inst) + } |> List.ofSeq + postRdr.Close () + cmd.CommandText <- "UPDATE post SET updated_on = @updatedOn, published_on = @publishedOn WHERE id = @id" + [ cmd.Parameters.Add ("@id", SqliteType.Text) + cmd.Parameters.Add ("@updatedOn", SqliteType.Text) + cmd.Parameters.Add ("@publishedOn", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (postId, updatedOn, publishedOn) -> + cmd.Parameters["@id" ].Value <- postId + cmd.Parameters["@updatedOn" ].Value <- instantParam updatedOn + cmd.Parameters["@publishedOn"].Value <- maybeInstant publishedOn + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // post_revision.as_of + cmd.CommandText <- "SELECT * FROM post_revision" + use! postRevRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while postRevRdr.Read () do + let asOf = Map.getDateTime "as_of" postRevRdr + Map.getString "post_id" postRevRdr, asOf, inst asOf, Map.getString "revision_text" postRevRdr + } |> List.ofSeq + postRevRdr.Close () + cmd.CommandText <- + "DELETE FROM post_revision WHERE post_id = @postId AND as_of = @oldAsOf; + INSERT INTO post_revision (post_id, as_of, revision_text) VALUES (@postId, @asOf, @text)" + [ cmd.Parameters.Add ("@postId", SqliteType.Text) + cmd.Parameters.Add ("@oldAsOf", SqliteType.Text) + cmd.Parameters.Add ("@asOf", SqliteType.Text) + cmd.Parameters.Add ("@text", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (postId, oldAsOf, asOf, text) -> + cmd.Parameters["@postId" ].Value <- postId + cmd.Parameters["@oldAsOf"].Value <- oldAsOf + cmd.Parameters["@asOf" ].Value <- instantParam asOf + cmd.Parameters["@text" ].Value <- text + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // theme_asset.updated_on + cmd.CommandText <- "SELECT theme_id, path, updated_on FROM theme_asset" + use! assetRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while assetRdr.Read () do + Map.getString "theme_id" assetRdr, Map.getString "path" assetRdr, + inst (Map.getDateTime "updated_on" assetRdr) + } |> List.ofSeq + assetRdr.Close () + cmd.CommandText <- "UPDATE theme_asset SET updated_on = @updatedOn WHERE theme_id = @themeId AND path = @path" + [ cmd.Parameters.Add ("@updatedOn", SqliteType.Text) + cmd.Parameters.Add ("@themeId", SqliteType.Text) + cmd.Parameters.Add ("@path", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (themeId, path, updatedOn) -> + cmd.Parameters["@themeId" ].Value <- themeId + cmd.Parameters["@path" ].Value <- path + cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // upload.updated_on + cmd.CommandText <- "SELECT id, updated_on FROM upload" + use! upRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while upRdr.Read () do + Map.getString "id" upRdr, inst (Map.getDateTime "updated_on" upRdr) + } |> List.ofSeq + upRdr.Close () + cmd.CommandText <- "UPDATE upload SET updated_on = @updatedOn WHERE id = @id" + [ cmd.Parameters.Add ("@updatedOn", SqliteType.Text) + cmd.Parameters.Add ("@id", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (upId, updatedOn) -> + cmd.Parameters["@id" ].Value <- upId + cmd.Parameters["@updatedOn"].Value <- instantParam updatedOn + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + // web_log_user.created_on, web_log_user.last_seen_on (opt) + cmd.CommandText <- "SELECT id, created_on, last_seen_on FROM web_log_user" + use! userRdr = cmd.ExecuteReaderAsync () + let toUpdate = + seq { + while userRdr.Read () do + Map.getString "id" userRdr, + inst (Map.getDateTime "created_on" userRdr), + (Map.tryDateTime "last_seen_on" userRdr |> Option.map inst) + } |> List.ofSeq + userRdr.Close () + cmd.CommandText <- "UPDATE web_log_user SET created_on = @createdOn, last_seen_on = @lastSeenOn WHERE id = @id" + [ cmd.Parameters.Add ("@id", SqliteType.Text) + cmd.Parameters.Add ("@createdOn", SqliteType.Text) + cmd.Parameters.Add ("@lastSeenOn", SqliteType.Text) + ] |> ignore + toUpdate + |> List.iter (fun (userId, createdOn, lastSeenOn) -> + cmd.Parameters["@id" ].Value <- userId + cmd.Parameters["@createdOn" ].Value <- instantParam createdOn + cmd.Parameters["@lastSeenOn"].Value <- maybeInstant lastSeenOn + let _ = cmd.ExecuteNonQuery () + ()) + cmd.Parameters.Clear () + + conn.Close () + conn.Open () + + logStep "Dropping old tables and columns" + cmd.CommandText <- + "ALTER TABLE web_log_user DROP COLUMN salt; + DROP TABLE post_episode; + DROP TABLE post_meta; + DROP TABLE page_meta; + DROP TABLE web_log_feed_podcast" + do! write cmd + + logStep "Setting database version to v2-rc2" + do! setDbVersion "v2-rc2" + } + + /// Migrate data among versions (up only) + let migrate version = backgroundTask { + + match version with + | Some v when v = "v2-rc2" -> () + | Some v when v = "v2-rc1" -> do! migrateV2Rc1ToV2Rc2 () + | Some _ + | None -> + log.LogWarning $"Unknown database version; assuming {Utils.currentDbVersion}" + do! setDbVersion Utils.currentDbVersion + } + /// The connection for this instance member _.Conn = conn @@ -31,355 +556,26 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = interface IData with member _.Category = SQLiteCategoryData conn - member _.Page = SQLitePageData conn - member _.Post = SQLitePostData 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 + member _.WebLog = SQLiteWebLogData (conn, ser) member _.WebLogUser = SQLiteWebLogUserData conn + member _.Serializer = ser + member _.StartUp () = backgroundTask { - + do! ensureTables () + use cmd = conn.CreateCommand () - - // Theme tables - match! tableExists "theme" with - | true -> () - | false -> - log.LogInformation "Creating theme table..." - cmd.CommandText <- """ - CREATE TABLE theme ( - id TEXT PRIMARY KEY, - name TEXT NOT NULL, - version TEXT NOT NULL)""" - do! write cmd - match! tableExists "theme_template" with - | true -> () - | false -> - log.LogInformation "Creating theme_template table..." - cmd.CommandText <- """ - CREATE TABLE theme_template ( - theme_id TEXT NOT NULL REFERENCES theme (id), - name TEXT NOT NULL, - template TEXT NOT NULL, - PRIMARY KEY (theme_id, name))""" - do! write cmd - match! tableExists "theme_asset" with - | true -> () - | false -> - log.LogInformation "Creating theme_asset table..." - cmd.CommandText <- """ - CREATE TABLE theme_asset ( - theme_id TEXT NOT NULL REFERENCES theme (id), - path TEXT NOT NULL, - updated_on TEXT NOT NULL, - data BLOB NOT NULL, - PRIMARY KEY (theme_id, path))""" - do! write cmd - - // Web log tables - match! tableExists "web_log" with - | true -> () - | false -> - log.LogInformation "Creating web_log table..." - cmd.CommandText <- """ - CREATE TABLE web_log ( - id TEXT 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 INTEGER NOT NULL DEFAULT 0, - uploads TEXT NOT NULL, - is_feed_enabled INTEGER NOT NULL DEFAULT 0, - feed_name TEXT NOT NULL, - items_in_feed INTEGER, - is_category_enabled INTEGER NOT NULL DEFAULT 0, - is_tag_enabled INTEGER NOT NULL DEFAULT 0, - copyright TEXT); - CREATE INDEX web_log_theme_idx ON web_log (theme_id)""" - do! write cmd - match! tableExists "web_log_feed" with - | true -> () - | false -> - log.LogInformation "Creating web_log_feed table..." - cmd.CommandText <- """ - CREATE TABLE web_log_feed ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - source TEXT NOT NULL, - path TEXT NOT NULL); - CREATE INDEX web_log_feed_web_log_idx ON web_log_feed (web_log_id)""" - do! write cmd - match! tableExists "web_log_feed_podcast" with - | true -> () - | false -> - log.LogInformation "Creating web_log_feed_podcast table..." - cmd.CommandText <- """ - CREATE TABLE web_log_feed_podcast ( - feed_id TEXT PRIMARY KEY REFERENCES web_log_feed (id), - title TEXT NOT NULL, - subtitle TEXT, - items_in_feed INTEGER NOT NULL, - summary TEXT NOT NULL, - displayed_author TEXT NOT NULL, - email TEXT NOT NULL, - image_url TEXT NOT NULL, - apple_category TEXT NOT NULL, - apple_subcategory TEXT, - explicit TEXT NOT NULL, - default_media_type TEXT, - media_base_url TEXT, - podcast_guid TEXT, - funding_url TEXT, - funding_text TEXT, - medium TEXT)""" - do! write cmd - - // Category table - match! tableExists "category" with - | true -> () - | false -> - log.LogInformation "Creating category table..." - cmd.CommandText <- """ - CREATE TABLE category ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - name TEXT NOT NULL, - slug TEXT NOT NULL, - description TEXT, - parent_id TEXT); - CREATE INDEX category_web_log_idx ON category (web_log_id)""" - do! write cmd - - // Web log user table - match! tableExists "web_log_user" with - | true -> () - | false -> - log.LogInformation "Creating web_log_user table..." - cmd.CommandText <- """ - CREATE TABLE web_log_user ( - id TEXT 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, - salt TEXT NOT NULL, - url TEXT, - access_level TEXT NOT NULL, - created_on TEXT NOT NULL, - last_seen_on TEXT); - CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id); - CREATE INDEX web_log_user_email_idx ON web_log_user (web_log_id, email)""" - do! write cmd - - // Page tables - match! tableExists "page" with - | true -> () - | false -> - log.LogInformation "Creating page table..." - cmd.CommandText <- """ - CREATE TABLE page ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - author_id TEXT NOT NULL REFERENCES web_log_user (id), - title TEXT NOT NULL, - permalink TEXT NOT NULL, - published_on TEXT NOT NULL, - updated_on TEXT NOT NULL, - is_in_page_list INTEGER NOT NULL DEFAULT 0, - template TEXT, - page_text TEXT NOT NULL); - CREATE INDEX page_web_log_idx ON page (web_log_id); - CREATE INDEX page_author_idx ON page (author_id); - CREATE INDEX page_permalink_idx ON page (web_log_id, permalink)""" - do! write cmd - match! tableExists "page_meta" with - | true -> () - | false -> - log.LogInformation "Creating page_meta table..." - cmd.CommandText <- """ - CREATE TABLE page_meta ( - page_id TEXT NOT NULL REFERENCES page (id), - name TEXT NOT NULL, - value TEXT NOT NULL, - PRIMARY KEY (page_id, name, value))""" - do! write cmd - match! tableExists "page_permalink" with - | true -> () - | false -> - log.LogInformation "Creating page_permalink table..." - cmd.CommandText <- """ - CREATE TABLE page_permalink ( - page_id TEXT NOT NULL REFERENCES page (id), - permalink TEXT NOT NULL, - PRIMARY KEY (page_id, permalink))""" - do! write cmd - match! tableExists "page_revision" with - | true -> () - | false -> - log.LogInformation "Creating page_revision table..." - cmd.CommandText <- """ - CREATE TABLE page_revision ( - page_id TEXT NOT NULL REFERENCES page (id), - as_of TEXT NOT NULL, - revision_text TEXT NOT NULL, - PRIMARY KEY (page_id, as_of))""" - do! write cmd - - // Post tables - match! tableExists "post" with - | true -> () - | false -> - log.LogInformation "Creating post table..." - cmd.CommandText <- """ - CREATE TABLE post ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - author_id TEXT NOT NULL REFERENCES web_log_user (id), - status TEXT NOT NULL, - title TEXT NOT NULL, - permalink TEXT NOT NULL, - published_on TEXT, - updated_on TEXT NOT NULL, - template TEXT, - post_text TEXT NOT NULL); - CREATE INDEX post_web_log_idx ON post (web_log_id); - CREATE INDEX post_author_idx ON post (author_id); - CREATE INDEX post_status_idx ON post (web_log_id, status, updated_on); - CREATE INDEX post_permalink_idx ON post (web_log_id, permalink)""" - do! write cmd - match! tableExists "post_category" with - | true -> () - | false -> - log.LogInformation "Creating post_category table..." - cmd.CommandText <- """ - CREATE TABLE post_category ( - post_id TEXT NOT NULL REFERENCES post (id), - category_id TEXT NOT NULL REFERENCES category (id), - PRIMARY KEY (post_id, category_id)); - CREATE INDEX post_category_category_idx ON post_category (category_id)""" - do! write cmd - match! tableExists "post_episode" with - | true -> () - | false -> - log.LogInformation "Creating post_episode table..." - cmd.CommandText <- """ - CREATE TABLE post_episode ( - post_id TEXT PRIMARY KEY REFERENCES post(id), - media TEXT NOT NULL, - length INTEGER NOT NULL, - duration TEXT, - media_type TEXT, - image_url TEXT, - subtitle TEXT, - explicit TEXT, - chapter_file TEXT, - chapter_type TEXT, - transcript_url TEXT, - transcript_type TEXT, - transcript_lang TEXT, - transcript_captions INTEGER, - season_number INTEGER, - season_description TEXT, - episode_number TEXT, - episode_description TEXT)""" - do! write cmd - match! tableExists "post_tag" with - | true -> () - | false -> - log.LogInformation "Creating post_tag table..." - cmd.CommandText <- """ - CREATE TABLE post_tag ( - post_id TEXT NOT NULL REFERENCES post (id), - tag TEXT NOT NULL, - PRIMARY KEY (post_id, tag))""" - do! write cmd - match! tableExists "post_meta" with - | true -> () - | false -> - log.LogInformation "Creating post_meta table..." - cmd.CommandText <- """ - CREATE TABLE post_meta ( - post_id TEXT NOT NULL REFERENCES post (id), - name TEXT NOT NULL, - value TEXT NOT NULL, - PRIMARY KEY (post_id, name, value))""" - do! write cmd - match! tableExists "post_permalink" with - | true -> () - | false -> - log.LogInformation "Creating post_permalink table..." - cmd.CommandText <- """ - CREATE TABLE post_permalink ( - post_id TEXT NOT NULL REFERENCES post (id), - permalink TEXT NOT NULL, - PRIMARY KEY (post_id, permalink))""" - do! write cmd - match! tableExists "post_revision" with - | true -> () - | false -> - log.LogInformation "Creating post_revision table..." - cmd.CommandText <- """ - CREATE TABLE post_revision ( - post_id TEXT NOT NULL REFERENCES post (id), - as_of TEXT NOT NULL, - revision_text TEXT NOT NULL, - PRIMARY KEY (post_id, as_of))""" - do! write cmd - match! tableExists "post_comment" with - | true -> () - | false -> - log.LogInformation "Creating post_comment table..." - cmd.CommandText <- """ - CREATE TABLE post_comment ( - id TEXT 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 TEXT NOT NULL, - comment_text TEXT NOT NULL); - CREATE INDEX post_comment_post_idx ON post_comment (post_id)""" - do! write cmd - - // Tag map table - match! tableExists "tag_map" with - | true -> () - | false -> - log.LogInformation "Creating tag_map table..." - cmd.CommandText <- """ - CREATE TABLE tag_map ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - tag TEXT NOT NULL, - url_value TEXT NOT NULL); - CREATE INDEX tag_map_web_log_idx ON tag_map (web_log_id)""" - do! write cmd - - // Uploaded file table - match! tableExists "upload" with - | true -> () - | false -> - log.LogInformation "Creating upload table..." - cmd.CommandText <- """ - CREATE TABLE upload ( - id TEXT PRIMARY KEY, - web_log_id TEXT NOT NULL REFERENCES web_log (id), - path TEXT NOT NULL, - updated_on TEXT NOT NULL, - data BLOB NOT NULL); - CREATE INDEX upload_web_log_idx ON upload (web_log_id); - CREATE INDEX upload_path_idx ON upload (web_log_id, path)""" - do! write cmd + 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 } diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs index f225a49..59ad5dc 100644 --- a/src/MyWebLog.Data/Utils.fs +++ b/src/MyWebLog.Data/Utils.fs @@ -5,6 +5,9 @@ module internal MyWebLog.Data.Utils open MyWebLog open MyWebLog.ViewModels +/// The current database version +let currentDbVersion = "v2-rc2" + /// Create a category hierarchy from the given list of categories let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq { for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do @@ -20,3 +23,36 @@ let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames) } +/// Get lists of items removed from and added to the given lists +let diffLists<'T, 'U when 'U : equality> oldItems newItems (f : 'T -> 'U) = + let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other)) + List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems + +/// Find meta items added and removed +let diffMetaItems (oldItems : MetaItem list) newItems = + diffLists oldItems newItems (fun item -> $"{item.Name}|{item.Value}") + +/// Find the permalinks added and removed +let diffPermalinks oldLinks newLinks = + diffLists oldLinks newLinks Permalink.toString + +/// Find the revisions added and removed +let diffRevisions oldRevs newRevs = + diffLists oldRevs newRevs (fun (rev : Revision) -> $"{rev.AsOf.ToUnixTimeTicks ()}|{MarkupText.toString rev.Text}") + +open MyWebLog.Converters +open Newtonsoft.Json + +/// Serialize an object to JSON +let serialize<'T> ser (item : 'T) = + JsonConvert.SerializeObject (item, Json.settings ser) + +/// Deserialize a JSON string +let deserialize<'T> (ser : JsonSerializer) value = + JsonConvert.DeserializeObject<'T> (value, Json.settings ser) + +open Microsoft.Extensions.Logging + +/// Log a migration step +let logMigrationStep<'T> (log : ILogger<'T>) migration message = + log.LogInformation $"Migrating %s{migration}: %s{message}" diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index be25d27..87b9a1c 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -2,6 +2,7 @@ open System open MyWebLog +open NodaTime /// A category under which a post may be identified [] @@ -64,7 +65,7 @@ type Comment = Status : CommentStatus /// When the comment was posted - PostedOn : DateTime + PostedOn : Instant /// The text of the comment Text : string @@ -82,7 +83,7 @@ module Comment = Email = "" Url = None Status = Pending - PostedOn = DateTime.UtcNow + PostedOn = Noda.epoch Text = "" } @@ -106,10 +107,10 @@ type Page = Permalink : Permalink /// When this page was published - PublishedOn : DateTime + PublishedOn : Instant /// When this page was last updated - UpdatedOn : DateTime + UpdatedOn : Instant /// Whether this page shows as part of the web log's navigation IsInPageList : bool @@ -140,8 +141,8 @@ module Page = AuthorId = WebLogUserId.empty Title = "" Permalink = Permalink.empty - PublishedOn = DateTime.MinValue - UpdatedOn = DateTime.MinValue + PublishedOn = Noda.epoch + UpdatedOn = Noda.epoch IsInPageList = false Template = None Text = "" @@ -173,10 +174,10 @@ type Post = Permalink : Permalink /// The instant on which the post was originally published - PublishedOn : DateTime option + PublishedOn : Instant option /// The instant on which the post was last updated - UpdatedOn : DateTime + UpdatedOn : Instant /// The template to use in displaying the post Template : string option @@ -215,7 +216,7 @@ module Post = Title = "" Permalink = Permalink.empty PublishedOn = None - UpdatedOn = DateTime.MinValue + UpdatedOn = Noda.epoch Text = "" Template = None CategoryIds = [] @@ -288,7 +289,7 @@ type ThemeAsset = Id : ThemeAssetId /// The updated date (set from the file date from the ZIP archive) - UpdatedOn : DateTime + UpdatedOn : Instant /// The data for the asset Data : byte[] @@ -300,7 +301,7 @@ module ThemeAsset = /// An empty theme asset let empty = { Id = ThemeAssetId (ThemeId "", "") - UpdatedOn = DateTime.MinValue + UpdatedOn = Noda.epoch Data = [||] } @@ -317,7 +318,7 @@ type Upload = Path : Permalink /// The updated date/time for this upload - UpdatedOn : DateTime + UpdatedOn : Instant /// The data for the upload Data : byte[] @@ -331,7 +332,7 @@ module Upload = { Id = UploadId.empty WebLogId = WebLogId.empty Path = Permalink.empty - UpdatedOn = DateTime.MinValue + UpdatedOn = Noda.epoch Data = [||] } @@ -410,10 +411,11 @@ module WebLog = let _, leadPath = hostAndPath webLog $"{leadPath}/{Permalink.toString permalink}" - /// Convert a UTC date/time to the web log's local date/time - let localTime webLog (date : DateTime) = - TimeZoneInfo.ConvertTimeFromUtc - (DateTime (date.Ticks, DateTimeKind.Utc), TimeZoneInfo.FindSystemTimeZoneById webLog.TimeZone) + /// Convert an Instant (UTC reference) to the web log's local date/time + let localTime webLog (date : Instant) = + match DateTimeZoneProviders.Tzdb[webLog.TimeZone] with + | null -> date.ToDateTimeUtc () + | tz -> date.InZone(tz).ToDateTimeUnspecified () /// A user of the web log @@ -440,9 +442,6 @@ type WebLogUser = /// The hash of the user's password PasswordHash : string - /// Salt used to calculate the user's password hash - Salt : Guid - /// The URL of the user's personal site Url : string option @@ -450,10 +449,10 @@ type WebLogUser = AccessLevel : AccessLevel /// When the user was created - CreatedOn : DateTime + CreatedOn : Instant /// When the user last logged on - LastSeenOn : DateTime option + LastSeenOn : Instant option } /// Functions to support web log users @@ -468,10 +467,9 @@ module WebLogUser = LastName = "" PreferredName = "" PasswordHash = "" - Salt = Guid.Empty Url = None AccessLevel = Author - CreatedOn = DateTime.UnixEpoch + CreatedOn = Noda.epoch LastSeenOn = None } diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index 3414816..49fa066 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -7,9 +7,10 @@ - + + diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index e73a4fb..4753583 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -1,6 +1,7 @@ namespace MyWebLog open System +open NodaTime /// Support functions for domain definition [] @@ -12,6 +13,29 @@ module private Helpers = Convert.ToBase64String(Guid.NewGuid().ToByteArray ()).Replace('/', '_').Replace('+', '-').Substring (0, 22) +/// Functions to support NodaTime manipulation +module Noda = + + /// The clock to use when getting "now" (will make mutable for testing) + let clock : IClock = SystemClock.Instance + + /// The Unix epoch + let epoch = Instant.FromUnixTimeSeconds 0L + + + /// Truncate an instant to remove fractional seconds + let toSecondsPrecision (value : Instant) = + Instant.FromUnixTimeSeconds (value.ToUnixTimeSeconds ()) + + /// The current Instant, with fractional seconds truncated + let now () = + toSecondsPrecision (clock.GetCurrentInstant ()) + + /// Convert a date/time to an Instant with whole seconds + let fromDateTime (dt : DateTime) = + toSecondsPrecision (Instant.FromDateTimeUtc (DateTime (dt.Ticks, DateTimeKind.Utc))) + + /// A user's access level type AccessLevel = /// The user may create and publish posts and edit the ones they have created @@ -137,6 +161,8 @@ module ExplicitRating = | x -> raise (invalidArg "rating" $"{x} is not a valid explicit rating") +open NodaTime.Text + /// A podcast episode type Episode = { /// The URL to the media file for the episode (may be permalink) @@ -146,7 +172,7 @@ type Episode = Length : int64 /// The duration of the episode - Duration : TimeSpan option + Duration : Duration option /// The media type of the file (overrides podcast default if present) MediaType : string option @@ -214,6 +240,10 @@ module Episode = EpisodeNumber = None EpisodeDescription = None } + + /// Format a duration for an episode + let formatDuration ep = + ep.Duration |> Option.map (DurationPattern.CreateWithInvariantCulture("H:mm:ss").Format) open Markdig @@ -269,12 +299,11 @@ module MetaItem = let empty = { Name = ""; Value = "" } - /// A revision of a page or post [] type Revision = { /// When this revision was saved - AsOf : DateTime + AsOf : Instant /// The text of the revision Text : MarkupText @@ -285,7 +314,7 @@ module Revision = /// An empty revision let empty = - { AsOf = DateTime.UtcNow + { AsOf = Noda.epoch Text = Html "" } diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 8dbc854..f7d204f 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -2,6 +2,7 @@ open System open MyWebLog +open NodaTime /// Helper functions for view models [] @@ -138,8 +139,8 @@ type DisplayPage = AuthorId = WebLogUserId.toString page.AuthorId Title = page.Title Permalink = Permalink.toString page.Permalink - PublishedOn = page.PublishedOn - UpdatedOn = page.UpdatedOn + PublishedOn = WebLog.localTime webLog page.PublishedOn + UpdatedOn = WebLog.localTime webLog page.UpdatedOn IsInPageList = page.IsInPageList IsDefault = pageId = webLog.DefaultPage Text = "" @@ -154,8 +155,8 @@ type DisplayPage = AuthorId = WebLogUserId.toString page.AuthorId Title = page.Title Permalink = Permalink.toString page.Permalink - PublishedOn = page.PublishedOn - UpdatedOn = page.UpdatedOn + PublishedOn = WebLog.localTime webLog page.PublishedOn + UpdatedOn = WebLog.localTime webLog page.UpdatedOn IsInPageList = page.IsInPageList IsDefault = pageId = webLog.DefaultPage Text = addBaseToRelativeUrls extra page.Text @@ -179,7 +180,7 @@ with /// Create a display revision from an actual revision static member fromRevision webLog (rev : Revision) = - { AsOf = rev.AsOf + { AsOf = rev.AsOf.ToDateTimeUtc () AsOfLocal = WebLog.localTime webLog rev.AsOf Format = MarkupText.sourceType rev.Text } @@ -703,7 +704,7 @@ type EditPostModel = match post.Revisions |> List.sortByDescending (fun r -> r.AsOf) |> List.tryHead with | Some rev -> rev | None -> Revision.empty - let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.empty ] } else post + let post = if post.Metadata |> List.isEmpty then { post with Metadata = [ MetaItem.empty ] } else post let episode = defaultArg post.Episode Episode.empty { PostId = PostId.toString post.Id Title = post.Title @@ -723,7 +724,7 @@ type EditPostModel = IsEpisode = Option.isSome post.Episode Media = episode.Media Length = episode.Length - Duration = defaultArg (episode.Duration |> Option.map (fun it -> it.ToString """hh\:mm\:ss""")) "" + Duration = defaultArg (Episode.formatDuration episode) "" MediaType = defaultArg episode.MediaType "" ImageUrl = defaultArg episode.ImageUrl "" Subtitle = defaultArg episode.Subtitle "" @@ -781,7 +782,8 @@ type EditPostModel = Some { Media = this.Media Length = this.Length - Duration = noneIfBlank this.Duration |> Option.map TimeSpan.Parse + Duration = noneIfBlank this.Duration + |> Option.map (TimeSpan.Parse >> Duration.FromTimeSpan) MediaType = noneIfBlank this.MediaType ImageUrl = noneIfBlank this.ImageUrl Subtitle = noneIfBlank this.Subtitle diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index 5042f55..2c4e74b 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -56,7 +56,6 @@ module Extensions = defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false - open System.Collections.Concurrent /// diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index b4ece20..30ebac4 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -5,6 +5,7 @@ open System.Threading.Tasks open Giraffe open MyWebLog open MyWebLog.ViewModels +open NodaTime /// ~~ DASHBOARDS ~~ module Dashboard = @@ -12,23 +13,22 @@ module Dashboard = // GET /admin/dashboard let user : HttpHandler = requireAccess Author >=> fun next ctx -> task { let getCount (f : WebLogId -> Task) = f ctx.WebLog.Id - let data = ctx.Data - let posts = getCount (data.Post.CountByStatus Published) - let drafts = getCount (data.Post.CountByStatus Draft) - let pages = getCount data.Page.CountAll - let listed = getCount data.Page.CountListed - let cats = getCount data.Category.CountAll - let topCats = getCount data.Category.CountTopLevel - let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats) + let data = ctx.Data + let! posts = getCount (data.Post.CountByStatus Published) + let! drafts = getCount (data.Post.CountByStatus Draft) + let! pages = getCount data.Page.CountAll + let! listed = getCount data.Page.CountListed + let! cats = getCount data.Category.CountAll + let! topCats = getCount data.Category.CountTopLevel return! hashForPage "Dashboard" |> addToHash ViewContext.Model { - Posts = posts.Result - Drafts = drafts.Result - Pages = pages.Result - ListedPages = listed.Result - Categories = cats.Result - TopLevelCategories = topCats.Result + Posts = posts + Drafts = drafts + Pages = pages + ListedPages = listed + Categories = cats + TopLevelCategories = topCats } |> adminView "dashboard" next ctx } @@ -344,7 +344,8 @@ module Theme = do! asset.Open().CopyToAsync stream do! data.ThemeAsset.Save { Id = ThemeAssetId (themeId, assetName) - UpdatedOn = asset.LastWriteTime.DateTime + UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime) + .InZoneLeniently(DateTimeZone.Utc).ToInstant () Data = stream.ToArray () } } diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 7efec6b..7db1dd9 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -95,8 +95,8 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[ let item = SyndicationItem ( Id = WebLog.absoluteUrl webLog post.Permalink, Title = TextSyndicationContent.CreateHtmlContent post.Title, - PublishDate = DateTimeOffset post.PublishedOn.Value, - LastUpdatedTime = DateTimeOffset post.UpdatedOn, + PublishDate = post.PublishedOn.Value.ToDateTimeOffset (), + LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset (), Content = TextSyndicationContent.CreatePlaintextContent plainText) item.AddPermalink (Uri item.Id) @@ -163,8 +163,8 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.DisplayedAuthor) item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit) episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it)) - episode.Duration - |> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it.ToString """hh\:mm\:ss""")) + Episode.formatDuration episode + |> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it)) match episode.ChapterFile with | Some chapters -> @@ -381,7 +381,7 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg addNamespace feed "content" Namespace.content setTitleAndDescription feedType webLog cats feed - feed.LastUpdatedTime <- (List.head posts).UpdatedOn |> DateTimeOffset + feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset () feed.Generator <- ctx.Generator feed.Items <- posts |> Seq.ofList |> Seq.map toItem feed.Language <- "en" diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 77b6241..ee7075c 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -419,10 +419,11 @@ let getCategoryIds slug ctx = open System open System.Globalization +open NodaTime /// Parse a date/time to UTC let parseToUtc (date : string) = - DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal) + Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal)) open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.Logging diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 8869cd8..5dee988 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -139,15 +139,13 @@ let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun | _, None -> return! Error.notFound next ctx } -open System - // POST /admin/page/{id}/revision/{revision-date}/restore let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! findPageRevision pgId revDate ctx with | Some pg, Some rev when canEdit pg.AuthorId ctx -> do! ctx.Data.Page.Update { pg with - Revisions = { rev with AsOf = DateTime.UtcNow } + Revisions = { rev with AsOf = Noda.now () } :: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" } @@ -173,7 +171,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let! model = ctx.BindFormAsync () let data = ctx.Data - let now = DateTime.UtcNow + let now = Noda.now () let tryPage = if model.IsNew then { Page.empty with diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index f79bfbe..c39dc86 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -52,9 +52,9 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data : let! olderPost, newerPost = match listType with | SinglePost -> - let post = List.head posts - let dateTime = defaultArg post.PublishedOn post.UpdatedOn - data.Post.FindSurroundingPosts webLog.Id dateTime + let post = List.head posts + let target = defaultArg post.PublishedOn post.UpdatedOn + data.Post.FindSurroundingPosts webLog.Id target | _ -> Task.FromResult (None, None) let newerLink = match listType, pageNbr with @@ -350,7 +350,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f | Some post, Some rev when canEdit post.AuthorId ctx -> do! ctx.Data.Post.Update { post with - Revisions = { rev with AsOf = DateTime.UtcNow } + Revisions = { rev with AsOf = Noda.now () } :: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" } @@ -376,7 +376,6 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let! model = ctx.BindFormAsync () let data = ctx.Data - let now = DateTime.UtcNow let tryPost = if model.IsNew then { Post.empty with @@ -389,7 +388,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { | Some post when canEdit post.AuthorId ctx -> let priorCats = post.CategoryIds let updatedPost = - model.UpdatePost post now + model.UpdatePost post (Noda.now ()) |> function | post -> if model.SetPublished then diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 1239c0c..e664a9d 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -94,7 +94,7 @@ module Asset = | Some asset -> match Upload.checkModified asset.UpdatedOn ctx with | Some threeOhFour -> return! threeOhFour next ctx - | None -> return! Upload.sendFile asset.UpdatedOn path asset.Data next ctx + | None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc ()) path asset.Data next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index 3755484..c1c840d 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -29,15 +29,17 @@ module private Helpers = // ~~ SERVING UPLOADS ~~ +open System.Globalization open Giraffe open Microsoft.AspNetCore.Http +open NodaTime /// Determine if the file has been modified since the date/time specified by the If-Modified-Since header let checkModified since (ctx : HttpContext) : HttpHandler option = match ctx.Request.Headers.IfModifiedSince with | it when it.Count < 1 -> None - | it when since > DateTime.Parse it[0] -> None - | _ -> Some (setStatusCode 304 >=> setBodyFromString "Not Modified") + | it when since > Instant.FromDateTimeUtc (DateTime.Parse (it[0], null, DateTimeStyles.AdjustToUniversal)) -> None + | _ -> Some (setStatusCode 304) open Microsoft.AspNetCore.Http.Headers @@ -73,7 +75,7 @@ let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { | Some upload -> match checkModified upload.UpdatedOn ctx with | Some threeOhFour -> return! threeOhFour next ctx - | None -> return! sendFile upload.UpdatedOn path upload.Data next ctx + | None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc ()) path upload.Data next ctx | None -> return! Error.notFound next ctx else return! Error.notFound next ctx @@ -143,7 +145,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let upload = Seq.head ctx.Request.Form.Files let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), Path.GetExtension(upload.FileName).ToLowerInvariant ()) - let localNow = WebLog.localTime ctx.WebLog DateTime.Now + let now = Noda.now () + let localNow = WebLog.localTime ctx.WebLog now let year = localNow.ToString "yyyy" let month = localNow.ToString "MM" let! form = ctx.BindFormAsync () @@ -156,7 +159,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { { Id = UploadId.create () WebLogId = ctx.WebLog.Id Path = Permalink $"{year}/{month}/{fileName}" - UpdatedOn = DateTime.UtcNow + UpdatedOn = now Data = stream.ToArray () } do! ctx.Data.Upload.Add file diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 608d2b3..6a67a61 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -2,19 +2,32 @@ module MyWebLog.Handlers.User open System -open System.Security.Cryptography -open System.Text +open Microsoft.AspNetCore.Http +open Microsoft.AspNetCore.Identity +open MyWebLog +open NodaTime // ~~ LOG ON / LOG OFF ~~ -/// Hash a password for a given user -let hashedPassword (plainText : string) (email : string) (salt : Guid) = - let allSalt = Array.concat [ salt.ToByteArray (); Encoding.UTF8.GetBytes email ] - use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048) - Convert.ToBase64String (alg.GetBytes 64) +/// Create a password hash a password for a given user +let createPasswordHash user password = + PasswordHasher().HashPassword (user, password) + +/// Verify whether a password is valid +let verifyPassword user password (ctx : HttpContext) = backgroundTask { + match user with + | Some usr -> + let hasher = PasswordHasher () + match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with + | PasswordVerificationResult.Success -> return Ok () + | PasswordVerificationResult.SuccessRehashNeeded -> + do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword (usr, password) } + return Ok () + | _ -> return Error "Log on attempt unsuccessful" + | None -> return Error "Log on attempt unsuccessful" +} open Giraffe -open MyWebLog open MyWebLog.ViewModels // GET /user/log-on @@ -35,10 +48,12 @@ open Microsoft.AspNetCore.Authentication.Cookies // POST /user/log-on let doLogOn : HttpHandler = fun next ctx -> task { - let! model = ctx.BindFormAsync () - let data = ctx.Data - match! data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id with - | Some user when user.PasswordHash = hashedPassword model.Password user.Email user.Salt -> + let! model = ctx.BindFormAsync () + let data = ctx.Data + let! tryUser = data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id + match! verifyPassword tryUser model.Password ctx with + | Ok _ -> + let user = tryUser.Value let claims = seq { Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.Id) Claim (ClaimTypes.Name, $"{user.FirstName} {user.LastName}") @@ -59,8 +74,8 @@ let doLogOn : HttpHandler = fun next ctx -> task { match model.ReturnTo with | Some url -> redirectTo false url next ctx | None -> redirectToGet "admin/dashboard" next ctx - | _ -> - do! addMessage ctx { UserMessage.error with Message = "Log on attempt unsuccessful" } + | Error msg -> + do! addMessage ctx { UserMessage.error with Message = msg } return! logOn model.ReturnTo next ctx } @@ -147,7 +162,9 @@ let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandl |> addToHash ViewContext.Model model |> addToHash "access_level" (AccessLevel.toString user.AccessLevel) |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) - |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch)) + |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog + (defaultArg user.LastSeenOn (Instant.FromUnixTimeSeconds 0))) + |> adminView "my-info" next ctx @@ -164,19 +181,13 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { let data = ctx.Data match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with | Some user when model.NewPassword = model.NewPasswordConfirm -> - let pw, salt = - if model.NewPassword = "" then - user.PasswordHash, user.Salt - else - let newSalt = Guid.NewGuid () - hashedPassword model.NewPassword user.Email newSalt, newSalt + let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword let user = { user with FirstName = model.FirstName LastName = model.LastName PreferredName = model.PreferredName PasswordHash = pw - Salt = salt } do! data.WebLogUser.Update user let pwMsg = if model.NewPassword = "" then "" else " and updated your password" @@ -198,9 +209,9 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let tryUser = if model.IsNew then { WebLogUser.empty with - Id = WebLogUserId.create () - WebLogId = ctx.WebLog.Id - CreatedOn = DateTime.UtcNow + Id = WebLogUserId.create () + WebLogId = ctx.WebLog.Id + CreatedOn = Noda.now () } |> someTask else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id match! tryUser with @@ -211,9 +222,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { else let toUpdate = if model.Password = "" then updatedUser - else - let salt = Guid.NewGuid () - { updatedUser with PasswordHash = hashedPassword model.Password model.Email salt; Salt = salt } + else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password } do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate do! addMessage ctx { UserMessage.success with @@ -227,4 +236,3 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { next ctx | None -> return! Error.notFound next ctx } - diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index c620721..544de4f 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -4,6 +4,7 @@ open System open System.IO open Microsoft.Extensions.DependencyInjection open MyWebLog.Data +open NodaTime /// Create the web log information let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { @@ -41,22 +42,19 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { } // Create the admin user - let salt = Guid.NewGuid () - let now = DateTime.UtcNow - - do! data.WebLogUser.Add - { WebLogUser.empty with - Id = userId - WebLogId = webLogId - Email = args[3] - FirstName = "Admin" - LastName = "User" - PreferredName = "Admin" - PasswordHash = Handlers.User.hashedPassword args[4] args[3] salt - Salt = salt - AccessLevel = accessLevel - CreatedOn = now - } + let now = Noda.now () + let user = + { WebLogUser.empty with + Id = userId + WebLogId = webLogId + Email = args[3] + FirstName = "Admin" + LastName = "User" + PreferredName = "Admin" + AccessLevel = accessLevel + CreatedOn = now + } + do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] } // Create the default home page do! data.Page.Add @@ -70,8 +68,8 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { UpdatedOn = now Text = "

This is your default home page.

" Revisions = [ - { AsOf = now - Text = Html "

This is your default home page.

" + { AsOf = now + Text = Html "

This is your default home page.

" } ] } @@ -155,7 +153,6 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task { /// Back up a web log's data module Backup = - open System.Threading.Tasks open MyWebLog.Converters open Newtonsoft.Json @@ -165,7 +162,7 @@ module Backup = Id : ThemeAssetId /// The updated date for this asset - UpdatedOn : DateTime + UpdatedOn : Instant /// The data for this asset, base-64 encoded Data : string @@ -197,7 +194,7 @@ module Backup = Path : Permalink /// The date/time this upload was last updated (file time) - UpdatedOn : DateTime + UpdatedOn : Instant /// The data for the upload, base-64 encoded Data : string @@ -251,10 +248,9 @@ module Backup = Uploads : EncodedUpload list } - /// Create a JSON serializer (uses RethinkDB data implementation's JSON converters) + /// Create a JSON serializer let private getSerializer prettyOutput = - let serializer = JsonSerializer.CreateDefault () - Json.all () |> Seq.iter serializer.Converters.Add + let serializer = Json.configure (JsonSerializer.CreateDefault ()) if prettyOutput then serializer.Formatting <- Formatting.Indented serializer @@ -382,7 +378,8 @@ module Backup = printfn "" printfn "- Importing theme..." do! data.Theme.Save restore.Theme - let! _ = restore.Assets |> List.map (EncodedAsset.toAsset >> data.ThemeAsset.Save) |> Task.WhenAll + restore.Assets + |> List.iter (EncodedAsset.toAsset >> data.ThemeAsset.Save >> Async.AwaitTask >> Async.RunSynchronously) // Restore web log data @@ -393,19 +390,20 @@ module Backup = do! data.WebLogUser.Restore restore.Users printfn "- Restoring categories and tag mappings..." - do! data.TagMap.Restore restore.TagMappings - do! data.Category.Restore restore.Categories + if not (List.isEmpty restore.TagMappings) then do! data.TagMap.Restore restore.TagMappings + if not (List.isEmpty restore.Categories) then do! data.Category.Restore restore.Categories printfn "- Restoring pages..." - do! data.Page.Restore restore.Pages + if not (List.isEmpty restore.Pages) then do! data.Page.Restore restore.Pages printfn "- Restoring posts..." - do! data.Post.Restore restore.Posts + if not (List.isEmpty restore.Posts) then do! data.Post.Restore restore.Posts // TODO: comments not yet implemented printfn "- Restoring uploads..." - do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload) + if not (List.isEmpty restore.Uploads) then + do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload) displayStats "Restored for <>NAME<>:" restore.WebLog restore } @@ -490,3 +488,22 @@ let upgradeUser (args : string[]) (sp : IServiceProvider) = task { | 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService ()) | _ -> 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 ()) + | _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]" +} diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 5eca40c..a9fecf4 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -29,11 +29,14 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) open System open Microsoft.Extensions.DependencyInjection open MyWebLog.Data +open Newtonsoft.Json +open Npgsql /// Logic to obtain a data connection and implementation based on configured values module DataImplementation = open MyWebLog.Converters + // open Npgsql.Logging open RethinkDb.Driver.FSharp open RethinkDb.Driver.Net @@ -43,23 +46,29 @@ module DataImplementation = let await it = (Async.AwaitTask >> Async.RunSynchronously) it let connStr name = config.GetConnectionString name let hasConnStr name = (connStr >> isNull >> not) name - let createSQLite connStr = + let createSQLite connStr : IData = let log = sp.GetRequiredService> () let conn = new SqliteConnection (connStr) log.LogInformation $"Using SQLite database {conn.DataSource}" await (SQLiteData.setUpConnection conn) - SQLiteData (conn, log) + SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ())) if hasConnStr "SQLite" then - upcast createSQLite (connStr "SQLite") + createSQLite (connStr "SQLite") elif hasConnStr "RethinkDB" then - let log = sp.GetRequiredService> () - Json.all () |> Seq.iter Converter.Serializer.Converters.Add + let log = sp.GetRequiredService> () + let _ = Json.configure Converter.Serializer let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB") let conn = await (rethinkCfg.CreateConnectionAsync log) - upcast RethinkDbData (conn, rethinkCfg, log) + RethinkDbData (conn, rethinkCfg, log) + elif hasConnStr "PostgreSQL" then + let log = sp.GetRequiredService> () + // NpgsqlLogManager.Provider <- ConsoleLoggingProvider NpgsqlLogLevel.Debug + let conn = new NpgsqlConnection (connStr "PostgreSQL") + log.LogInformation $"Using PostgreSQL database {conn.Host}:{conn.Port}/{conn.Database}" + PostgresData (conn, log, Json.configure (JsonSerializer.CreateDefault ())) else - upcast createSQLite "Data Source=./myweblog.db;Cache=Shared" + createSQLite "Data Source=./myweblog.db;Cache=Shared" open System.Threading.Tasks @@ -76,6 +85,7 @@ let showHelp () = printfn "init Initializes a new web log" printfn "load-theme Load a theme" printfn "restore Restore a JSON file backup (prompt before overwriting)" + printfn "set-password Set a password for a specific user" printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator" printfn " " printfn "For more information on a particular command, run it with no options." @@ -88,6 +98,7 @@ open Giraffe.EndpointRouting open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.HttpOverrides +open Microsoft.Extensions.Caching.Distributed open NeoSmart.Caching.Sqlite open RethinkDB.DistributedCache @@ -108,8 +119,9 @@ let rec main args = let _ = builder.Services.AddAuthorization () let _ = builder.Services.AddAntiforgery () - let sp = builder.Services.BuildServiceProvider () + let sp = builder.Services.BuildServiceProvider () let data = DataImplementation.get sp + let _ = builder.Services.AddSingleton data.Serializer task { do! data.StartUp () @@ -121,23 +133,36 @@ let rec main args = match data with | :? RethinkDbData as rethink -> // A RethinkDB connection is designed to work as a singleton - builder.Services.AddSingleton data |> ignore - builder.Services.AddDistributedRethinkDBCache (fun opts -> - opts.TableName <- "Session" - opts.Connection <- rethink.Conn) - |> ignore + let _ = builder.Services.AddSingleton data + let _ = + builder.Services.AddDistributedRethinkDBCache (fun opts -> + opts.TableName <- "Session" + opts.Connection <- rethink.Conn) + () | :? SQLiteData as sql -> // ADO.NET connections are designed to work as per-request instantiation let cfg = sp.GetRequiredService () - builder.Services.AddScoped (fun sp -> - let conn = new SqliteConnection (sql.Conn.ConnectionString) - SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously - conn) - |> ignore - builder.Services.AddScoped () |> ignore + let _ = + builder.Services.AddScoped (fun sp -> + let conn = new SqliteConnection (sql.Conn.ConnectionString) + SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously + conn) + let _ = builder.Services.AddScoped () |> ignore // Use SQLite for caching as well let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" - builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) |> ignore + let _ = builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath) + () + | :? PostgresData -> + // ADO.NET connections are designed to work as per-request instantiation + let cfg = sp.GetRequiredService () + let _ = + builder.Services.AddScoped (fun sp -> + new NpgsqlConnection (cfg.GetConnectionString "PostgreSQL")) + let _ = builder.Services.AddScoped () + let _ = + builder.Services.AddSingleton (fun sp -> + Postgres.DistributedCache (cfg.GetConnectionString "PostgreSQL") :> IDistributedCache) + () | _ -> () let _ = builder.Services.AddSession(fun opts -> @@ -159,6 +184,7 @@ let rec main args = | Some it when it = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services | Some it when it = "do-restore" -> Maintenance.Backup.restoreFromBackup args app.Services | Some it when it = "upgrade-user" -> Maintenance.upgradeUser args app.Services + | Some it when it = "set-password" -> Maintenance.setPassword args app.Services | Some it when it = "help" -> showHelp () | Some it -> printfn $"""Unrecognized command "{it}" - valid commands are:""" diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index 6c0b98c..62fa309 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -1,5 +1,5 @@ { - "Generator": "myWebLog 2.0-rc1", + "Generator": "myWebLog 2.0-rc2", "Logging": { "LogLevel": { "MyWebLog.Handlers": "Information" diff --git a/src/admin-theme/version.txt b/src/admin-theme/version.txt index 18c98a2..80104df 100644 --- a/src/admin-theme/version.txt +++ b/src/admin-theme/version.txt @@ -1,2 +1,2 @@ myWebLog Admin -2.0.0-rc1 \ No newline at end of file +2.0.0-rc2 \ No newline at end of file diff --git a/src/default-theme/version.txt b/src/default-theme/version.txt index 74f4501..9757c99 100644 --- a/src/default-theme/version.txt +++ b/src/default-theme/version.txt @@ -1,2 +1,2 @@ myWebLog Default Theme -2.0.0-rc1 \ No newline at end of file +2.0.0-rc2 \ No newline at end of file