From c29bbc04ac27e3cccd98c3f42b19c164b8b20e1d Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Tue, 28 Jun 2022 17:34:18 -0400 Subject: [PATCH] WIP on uploads (#2) - Add data types and fields - Implement in both RethinkDB and SQLite - Add uploads to backup/restore - Add empty upload folder to project - Add indexes to SQLite tables (#15) --- src/MyWebLog.Data/Converters.fs | 50 +++-- src/MyWebLog.Data/Interfaces.fs | 19 ++ src/MyWebLog.Data/MyWebLog.Data.fsproj | 1 + src/MyWebLog.Data/RethinkDbData.fs | 58 ++++- src/MyWebLog.Data/SQLite/Helpers.fs | 15 ++ .../SQLite/SQLiteCategoryData.fs | 50 ++--- src/MyWebLog.Data/SQLite/SQLitePageData.fs | 96 ++++---- src/MyWebLog.Data/SQLite/SQLitePostData.fs | 204 +++++++++-------- src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs | 34 +-- src/MyWebLog.Data/SQLite/SQLiteUploadData.fs | 69 ++++++ src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs | 211 +++++++++--------- .../SQLite/SQLiteWebLogUserData.fs | 43 ++-- src/MyWebLog.Data/SQLiteData.fs | 136 ++++++----- src/MyWebLog.Domain/DataTypes.fs | 39 ++++ src/MyWebLog.Domain/SupportTypes.fs | 35 +++ src/MyWebLog/Handlers/Routes.fs | 39 +--- src/MyWebLog/Handlers/Upload.fs | 61 +++++ src/MyWebLog/Maintenance.fs | 67 +++++- src/MyWebLog/MyWebLog.fsproj | 3 +- src/MyWebLog/wwwroot/upload/.gitkeep | 0 20 files changed, 800 insertions(+), 430 deletions(-) create mode 100644 src/MyWebLog.Data/SQLite/SQLiteUploadData.fs create mode 100644 src/MyWebLog/Handlers/Upload.fs create mode 100644 src/MyWebLog/wwwroot/upload/.gitkeep diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index d16cd0a..cdbb807 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -99,7 +99,21 @@ module Json = writer.WriteValue (ThemeId.toString value) override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeId, _ : bool, _ : JsonSerializer) = (string >> ThemeId) reader.Value - + + type UploadDestinationConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : UploadDestination, _ : JsonSerializer) = + writer.WriteValue (UploadDestination.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : UploadDestination, _ : bool, _ : JsonSerializer) = + (string >> UploadDestination.parse) reader.Value + + type UploadIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : UploadId, _ : JsonSerializer) = + writer.WriteValue (UploadId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : UploadId, _ : bool, _ : JsonSerializer) = + (string >> UploadId) reader.Value + type WebLogIdConverter () = inherit JsonConverter () override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) = @@ -120,21 +134,23 @@ module Json = let all () : JsonConverter seq = seq { // Our converters - CategoryIdConverter () - CommentIdConverter () - CustomFeedIdConverter () - CustomFeedSourceConverter () - ExplicitRatingConverter () - MarkupTextConverter () - PermalinkConverter () - PageIdConverter () - PodcastMediumConverter () - PostIdConverter () - TagMapIdConverter () - ThemeAssetIdConverter () - ThemeIdConverter () - WebLogIdConverter () - WebLogUserIdConverter () + CategoryIdConverter () + CommentIdConverter () + CustomFeedIdConverter () + CustomFeedSourceConverter () + ExplicitRatingConverter () + MarkupTextConverter () + PermalinkConverter () + PageIdConverter () + PodcastMediumConverter () + PostIdConverter () + TagMapIdConverter () + ThemeAssetIdConverter () + ThemeIdConverter () + UploadDestinationConverter () + UploadIdConverter () + WebLogIdConverter () + WebLogUserIdConverter () // Handles DUs with no associated data, as well as option fields - CompactUnionJsonConverter () + CompactUnionJsonConverter () } diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index bb0bd1d..0129045 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -199,6 +199,22 @@ type IThemeAssetData = abstract member save : ThemeAsset -> Task +/// Functions to manipulate uploaded files +type IUploadData = + + /// Add an uploaded file + abstract member add : Upload -> Task + + /// Find an uploaded file by its path for the given web log + abstract member findByPath : string -> WebLogId -> Task + + /// Find all uploaded files for a web log + abstract member findByWebLog : WebLogId -> Task + + /// Restore uploaded files from a backup + abstract member restore : Upload list -> Task + + /// Functions to manipulate web logs type IWebLogData = @@ -270,6 +286,9 @@ type IData = /// Theme asset data functions abstract member ThemeAsset : IThemeAssetData + /// Uploaded file functions + abstract member Upload : IUploadData + /// Web log data functions abstract member WebLog : IWebLogData diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 88decc9..846ab8a 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -31,6 +31,7 @@ + diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index f42e277..f392c37 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -33,6 +33,9 @@ module private RethinkHelpers = /// The theme asset table let ThemeAsset = "ThemeAsset" + /// The uploaded file table + let Upload = "Upload" + /// The web log table let WebLog = "WebLog" @@ -40,7 +43,7 @@ module private RethinkHelpers = let WebLogUser = "WebLogUser" /// A list of all tables - let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ] + let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ] /// Shorthand for the ReQL starting point @@ -125,6 +128,15 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger r.Array (row["webLogId"], row["urlValue"]) :> obj) write; withRetryOnce; ignoreResult conn } + // Uploaded files need an index by web log ID and path, as that is how they are retrieved + if Table.Upload = table then + if not (indexes |> List.contains "webLogAndPath") then + log.LogInformation $"Creating index {table}.webLogAndPath..." + do! rethink { + withTable table + indexCreate "webLogAndPath" (fun row -> r.Array (row["webLogId"], row["path"]) :> obj) + write; withRetryOnce; ignoreResult conn + } // Users log on with e-mail if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then log.LogInformation $"Creating index {table}.logOn..." @@ -725,6 +737,41 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { + withTable Table.Upload + getAll [ r.Array (path, webLogId) ] "webLogAndPath" + resultCursor; withRetryCursorDefault; toList + } + |> tryFirst <| conn + + member _.findByWebLog webLogId = rethink { + withTable Table.Upload + between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) + [ Index "webLogAndPath" ] + resultCursor; withRetryCursorDefault; toList conn + } + + member _.restore uploads = backgroundTask { + // Files can be large; we'll do 5 at a time + for batch in uploads |> List.chunkBySize 5 do + do! rethink { + withTable Table.TagMap + insert batch + write; withRetryOnce; ignoreResult conn + } + } + } + member _.WebLog = { new IWebLogData with @@ -763,6 +810,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name) |> Seq.map (fun cat -> cat.id) @@ -125,10 +125,10 @@ type SQLiteCategoryData (conn : SqliteConnection) = | Some _ -> use cmd = conn.CreateCommand () // 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)""" + cmd.CommandText <- """ + DELETE FROM post_category + WHERE category_id = @id + AND post_id IN (SELECT id FROM post WHERE web_log_id = @webLogId)""" let catIdParameter = cmd.Parameters.AddWithValue ("@id", CategoryId.toString catId) cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore do! write cmd @@ -150,14 +150,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 66d6478..a6cd283 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePageData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePageData.fs @@ -139,14 +139,14 @@ type SQLitePageData (conn : SqliteConnection) = let add page = backgroundTask { use cmd = conn.CreateCommand () // The page itself - cmd.CommandText <- - """INSERT INTO page ( - id, web_log_id, author_id, title, permalink, published_on, updated_on, show_in_page_list, - template, page_text - ) VALUES ( - @id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @showInPageList, - @template, @text - )""" + cmd.CommandText <- """ + INSERT INTO page ( + id, web_log_id, author_id, title, permalink, published_on, updated_on, show_in_page_list, template, + page_text + ) VALUES ( + @id, @webLogId, @authorId, @title, @permalink, @publishedOn, @updatedOn, @showInPageList, @template, + @text + )""" addPageParameters cmd page do! write cmd do! updatePageMeta page.id [] page.metadata @@ -174,11 +174,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 show_in_page_list = @showInPageList""" + cmd.CommandText <- """ + SELECT COUNT(id) + FROM page + WHERE web_log_id = @webLogId + AND show_in_page_list = @showInPageList""" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@showInPageList", true) |> ignore return! count cmd @@ -211,11 +211,11 @@ 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_meta WHERE page_id = @id; + DELETE FROM page WHERE id = @id""" do! write cmd return true | None -> return false @@ -238,12 +238,12 @@ type SQLitePageData (conn : SqliteConnection) = /// 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 <- - """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 (""" + 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}, " @@ -274,12 +274,12 @@ 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 show_in_page_list = @showInPageList - ORDER BY LOWER(title)""" + cmd.CommandText <- """ + SELECT * + FROM page + WHERE web_log_id = @webLogId + AND show_in_page_list = @showInPageList + ORDER BY LOWER(title)""" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@showInPageList", true) |> ignore use! rdr = cmd.ExecuteReaderAsync () @@ -293,12 +293,12 @@ type SQLitePageData (conn : SqliteConnection) = /// 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) @@ -318,18 +318,18 @@ 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, - show_in_page_list = @showInPageList, - template = @template, - page_text = @text - WHERE id = @pageId - AND web_log_id = @webLogId""" + cmd.CommandText <- """ + UPDATE page + SET author_id = @authorId, + title = @title, + permalink = @permalink, + published_on = @publishedOn, + updated_on = @updatedOn, + show_in_page_list = @showInPageList, + template = @template, + page_text = @text + WHERE id = @pageId + AND web_log_id = @webLogId""" addPageParameters cmd page do! write cmd do! updatePageMeta page.id oldPage.metadata page.metadata diff --git a/src/MyWebLog.Data/SQLite/SQLitePostData.fs b/src/MyWebLog.Data/SQLite/SQLitePostData.fs index 972669a..a9e7718 100644 --- a/src/MyWebLog.Data/SQLite/SQLitePostData.fs +++ b/src/MyWebLog.Data/SQLite/SQLitePostData.fs @@ -146,26 +146,26 @@ type SQLitePostData (conn : SqliteConnection) = 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""" + 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 -> @@ -174,16 +174,16 @@ type SQLitePostData (conn : SqliteConnection) = 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 - )""" + 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 -> () @@ -278,14 +278,12 @@ 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 - ) VALUES ( - @id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, - @template, @text - )""" + cmd.CommandText <- """ + INSERT INTO post ( + id, web_log_id, author_id, status, title, permalink, published_on, updated_on, template, post_text + ) VALUES ( + @id, @webLogId, @authorId, @status, @title, @permalink, @publishedOn, @updatedOn, @template, @text + )""" addPostParameters cmd post do! write cmd do! updatePostCategories post.id [] post.categoryIds @@ -340,14 +338,14 @@ 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_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""" do! write cmd return true | None -> return false @@ -356,12 +354,12 @@ 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 <- - """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 (""" + 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}, " @@ -392,12 +390,12 @@ 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 <- - $"""{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 (""" + 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}, " @@ -420,11 +418,11 @@ 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 <- - $"""{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}""" + 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}""" addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () let! posts = @@ -437,12 +435,12 @@ 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 <- - $"""{selectPost} - WHERE p.web_log_id = @webLogId - AND p.status = @status - ORDER BY p.published_on DESC - LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}""" + 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}""" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) |> ignore use! rdr = cmd.ExecuteReaderAsync () @@ -456,14 +454,14 @@ 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 <- - $"""{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}""" + 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}""" addWebLogId cmd webLogId [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) cmd.Parameters.AddWithValue ("@tag", tag) @@ -479,13 +477,13 @@ type SQLitePostData (conn : SqliteConnection) = /// Find the next newest and oldest post from a publish date for the given web log let findSurroundingPosts webLogId (publishedOn : DateTime) = backgroundTask { use cmd = conn.CreateCommand () - 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""" + 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""" addWebLogId cmd webLogId [ cmd.Parameters.AddWithValue ("@status", PostStatus.toString Published) cmd.Parameters.AddWithValue ("@publishedOn", publishedOn) @@ -499,13 +497,13 @@ type SQLitePostData (conn : SqliteConnection) = return None } do! rdr.CloseAsync () - 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""" + 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""" use! rdr = cmd.ExecuteReaderAsync () let! newer = backgroundTask { if rdr.Read () then @@ -528,18 +526,18 @@ 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 + WHERE id = @id + AND web_log_id = @webLogId""" addPostParameters cmd post do! write cmd do! updatePostCategories post.id oldPost.categoryIds post.categoryIds diff --git a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs index c6ddcbf..6b8c1ac 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteTagMapData.fs @@ -50,11 +50,11 @@ 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 <- - """SELECT * - FROM tag_map - WHERE web_log_id = @webLogId - AND tag IN (""" + 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}, " @@ -71,19 +71,19 @@ 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 ( - id, web_log_id, tag, url_value - ) VALUES ( - @id, @webLogId, @tag, @urlValue - )""" + 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) diff --git a/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs new file mode 100644 index 0000000..beb275c --- /dev/null +++ b/src/MyWebLog.Data/SQLite/SQLiteUploadData.fs @@ -0,0 +1,69 @@ +namespace MyWebLog.Data.SQLite + +open System.IO +open Microsoft.Data.Sqlite +open MyWebLog +open MyWebLog.Data + +/// SQLite myWebLog web log data implementation +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 ("@dataLength", upload.data.Length) + ] |> ignore + + /// Save an uploaded file + let add upload = backgroundTask { + use cmd = conn.CreateCommand () + 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 + + cmd.CommandText <- "SELECT ROWID FROM upload WHERE id = @id" + let! rowId = cmd.ExecuteScalarAsync () + + use dataStream = new MemoryStream (upload.data) + use blobStream = new SqliteBlob (conn, "upload", "data", rowId :?> int64) + do! dataStream.CopyToAsync blobStream + } + + /// Find an uploaded file by its path for the given web log + let findByPath (path : string) webLogId = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT *, ROWID FROM upload WHERE web_log_id = @webLogId AND path = @path" + addWebLogId cmd webLogId + cmd.Parameters.AddWithValue ("@path", path) |> ignore + let! rdr = cmd.ExecuteReaderAsync () + return if rdr.Read () then Some (Map.toUpload rdr) else None + } + + /// Find all uploaded files for the given web log + let findByWebLog webLogId = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT *, ROWID FROM upload WHERE web_log_id = @webLogId" + addWebLogId cmd webLogId + let! rdr = cmd.ExecuteReaderAsync () + return toList Map.toUpload rdr + } + + /// Restore uploads from a backup + let restore uploads = backgroundTask { + for upload in uploads do do! add upload + } + + interface IUploadData with + member _.add upload = add upload + member _.findByPath path webLogId = findByPath path webLogId + member _.findByWebLog webLogId = findByWebLog webLogId + member _.restore uploads = restore uploads + \ No newline at end of file diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs index 2418721..8090cb6 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogData.fs @@ -27,6 +27,7 @@ type SQLiteWebLogData (conn : SqliteConnection) = 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 ("@postsPerPage", webLog.postsPerPage) @@ -34,6 +35,7 @@ type SQLiteWebLogData (conn : SqliteConnection) = 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 @@ -69,11 +71,11 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// 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 f.*, p.* + FROM web_log_feed f + LEFT JOIN web_log_feed_podcast p ON p.feed_id = f.id + WHERE f.web_log_id = @webLogId""" addWebLogId cmd webLog.id use! rdr = cmd.ExecuteReaderAsync () return toList Map.toCustomFeed rdr @@ -88,16 +90,16 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// 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, itunes_category, itunes_subcategory, explicit, default_media_type, - media_base_url, guid, funding_url, funding_text, medium - ) VALUES ( - @feedId, @title, @subtitle, @itemsInFeed, @summary, @displayedAuthor, @email, - @imageUrl, @iTunesCategory, @iTunesSubcategory, @explicit, @defaultMediaType, - @mediaBaseUrl, @guid, @fundingUrl, @fundingText, @medium - )""" + cmd.CommandText <- """ + INSERT INTO web_log_feed_podcast ( + feed_id, title, subtitle, items_in_feed, summary, displayed_author, email, image_url, + itunes_category, itunes_subcategory, explicit, default_media_type, media_base_url, guid, funding_url, + funding_text, medium + ) VALUES ( + @feedId, @title, @subtitle, @itemsInFeed, @summary, @displayedAuthor, @email, @imageUrl, + @iTunesCategory, @iTunesSubcategory, @explicit, @defaultMediaType, @mediaBaseUrl, @guid, @fundingUrl, + @fundingText, @medium + )""" addPodcastParameters cmd feedId podcast do! write cmd } @@ -115,9 +117,9 @@ 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_podcast WHERE feed_id = @id; + DELETE FROM web_log_feed WHERE id = @id""" cmd.Parameters["@id"].Value <- CustomFeedId.toString it.id do! write cmd }) @@ -126,12 +128,12 @@ 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 - ) VALUES ( - @id, @webLogId, @source, @path - )""" + cmd.CommandText <- """ + INSERT INTO web_log_feed ( + id, web_log_id, source, path + ) VALUES ( + @id, @webLogId, @source, @path + )""" cmd.Parameters.Clear () addCustomFeedParameters cmd webLog.id it do! write cmd @@ -143,12 +145,12 @@ type SQLiteWebLogData (conn : SqliteConnection) = |> 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 + WHERE id = @id + AND web_log_id = @webLogId""" cmd.Parameters.Clear () addCustomFeedParameters cmd webLog.id it do! write cmd @@ -156,25 +158,25 @@ type SQLiteWebLogData (conn : SqliteConnection) = 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, - itunes_category = @iTunesCategory, - itunes_subcategory = @iTunesSubcategory, - explicit = @explicit, - default_media_type = @defaultMediaType, - media_base_url = @mediaBaseUrl, - guid = @guid, - funding_url = @fundingUrl, - funding_text = @fundingText, - medium = @medium - WHERE feed_id = @feedId""" + 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, + itunes_category = @iTunesCategory, + itunes_subcategory = @iTunesSubcategory, + explicit = @explicit, + default_media_type = @defaultMediaType, + media_base_url = @mediaBaseUrl, + guid = @guid, + funding_url = @fundingUrl, + funding_text = @fundingText, + medium = @medium + WHERE feed_id = @feedId""" cmd.Parameters.Clear () addPodcastParameters cmd it.id podcast do! write cmd @@ -198,16 +200,14 @@ type SQLiteWebLogData (conn : SqliteConnection) = /// Add a web log let add webLog = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- - """INSERT INTO web_log ( - id, name, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, - auto_htmx, feed_enabled, feed_name, items_in_feed, category_enabled, tag_enabled, - copyright - ) VALUES ( - @id, @name, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, - @autoHtmx, @feedEnabled, @feedName, @itemsInFeed, @categoryEnabled, @tagEnabled, - @copyright - )""" + cmd.CommandText <- """ + INSERT INTO web_log ( + id, name, slug, subtitle, default_page, posts_per_page, theme_id, url_base, time_zone, auto_htmx, + uploads, feed_enabled, feed_name, items_in_feed, category_enabled, tag_enabled, copyright + ) VALUES ( + @id, @name, @slug, @subtitle, @defaultPage, @postsPerPage, @themeId, @urlBase, @timeZone, @autoHtmx, + @uploads, @feedEnabled, @feedName, @itemsInFeed, @categoryEnabled, @tagEnabled, @copyright + )""" addWebLogParameters cmd webLog do! write cmd do! updateCustomFeeds webLog @@ -232,25 +232,26 @@ 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 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_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""" do! write cmd } @@ -283,23 +284,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, - subtitle = @subtitle, - default_page = @defaultPage, - posts_per_page = @postsPerPage, - theme_id = @themeId, - url_base = @urlBase, - time_zone = @timeZone, - auto_htmx = @autoHtmx, - feed_enabled = @feedEnabled, - feed_name = @feedName, - items_in_feed = @itemsInFeed, - category_enabled = @categoryEnabled, - tag_enabled = @tagEnabled, - 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, + feed_enabled = @feedEnabled, + feed_name = @feedName, + items_in_feed = @itemsInFeed, + category_enabled = @categoryEnabled, + tag_enabled = @tagEnabled, + copyright = @copyright + WHERE id = @id""" addWebLogParameters cmd webLog do! write cmd } @@ -307,15 +310,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 feed_enabled = @feedEnabled, - feed_name = @feedName, - items_in_feed = @itemsInFeed, - category_enabled = @categoryEnabled, - tag_enabled = @tagEnabled, - copyright = @copyright - WHERE id = @id""" + cmd.CommandText <- """ + UPDATE web_log + SET feed_enabled = @feedEnabled, + feed_name = @feedName, + items_in_feed = @itemsInFeed, + category_enabled = @categoryEnabled, + tag_enabled = @tagEnabled, + copyright = @copyright + WHERE id = @id""" addWebLogRssParameters cmd webLog do! write cmd do! updateCustomFeeds webLog diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 8773068..019779f 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -28,14 +28,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, user_name, first_name, last_name, preferred_name, password_hash, salt, - url, authorization_level - ) VALUES ( - @id, @webLogId, @userName, @firstName, @lastName, @preferredName, @passwordHash, @salt, - @url, @authorizationLevel - )""" + cmd.CommandText <- """ + INSERT INTO web_log_user ( + id, web_log_id, user_name, first_name, last_name, preferred_name, password_hash, salt, url, + authorization_level + ) VALUES ( + @id, @webLogId, @userName, @firstName, @lastName, @preferredName, @passwordHash, @salt, @url, + @authorizationLevel + )""" addWebLogUserParameters cmd user do! write cmd } @@ -43,8 +43,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Find a user by their e-mail address for the given web log let findByEmail (email : string) webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- - "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND user_name = @userName" + cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND user_name = @userName" addWebLogId cmd webLogId cmd.Parameters.AddWithValue ("@userName", email) |> ignore use! rdr = cmd.ExecuteReaderAsync () @@ -95,18 +94,18 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = /// Update a user let update user = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- - """UPDATE web_log_user - SET user_name = @userName, - first_name = @firstName, - last_name = @lastName, - preferred_name = @preferredName, - password_hash = @passwordHash, - salt = @salt, - url = @url, - authorization_level = @authorizationLevel - WHERE id = @id - AND web_log_id = @webLogId""" + cmd.CommandText <- """ + UPDATE web_log_user + SET user_name = @userName, + first_name = @firstName, + last_name = @lastName, + preferred_name = @preferredName, + password_hash = @passwordHash, + salt = @salt, + url = @url, + authorization_level = @authorizationLevel + 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 fc4593e..aaa79a2 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -36,6 +36,7 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = member _.TagMap = SQLiteTagMapData conn member _.Theme = SQLiteThemeData conn member _.ThemeAsset = SQLiteThemeAssetData conn + member _.Upload = SQLiteUploadData conn member _.WebLog = SQLiteWebLogData conn member _.WebLogUser = SQLiteWebLogUserData conn @@ -48,8 +49,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating theme table..." - cmd.CommandText <- - """CREATE TABLE theme ( + cmd.CommandText <- """ + CREATE TABLE theme ( id TEXT PRIMARY KEY, name TEXT NOT NULL, version TEXT NOT NULL)""" @@ -58,8 +59,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating theme_template table..." - cmd.CommandText <- - """CREATE TABLE theme_template ( + cmd.CommandText <- """ + CREATE TABLE theme_template ( theme_id TEXT NOT NULL REFERENCES theme (id), name TEXT NOT NULL, template TEXT NOT NULL, @@ -69,8 +70,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating theme_asset table..." - cmd.CommandText <- - """CREATE TABLE theme_asset ( + cmd.CommandText <- """ + CREATE TABLE theme_asset ( theme_id TEXT NOT NULL REFERENCES theme (id), path TEXT NOT NULL, updated_on TEXT NOT NULL, @@ -83,10 +84,11 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating web_log table..." - cmd.CommandText <- - """CREATE TABLE web_log ( + 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, @@ -94,30 +96,33 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = url_base TEXT NOT NULL, time_zone TEXT NOT NULL, auto_htmx INTEGER NOT NULL DEFAULT 0, + uploads TEXT NOT NULL, feed_enabled INTEGER NOT NULL DEFAULT 0, feed_name TEXT NOT NULL, items_in_feed INTEGER, category_enabled INTEGER NOT NULL DEFAULT 0, tag_enabled INTEGER NOT NULL DEFAULT 0, - copyright TEXT)""" + 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 ( + 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)""" + 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 ( + cmd.CommandText <- """ + CREATE TABLE web_log_feed_podcast ( feed_id TEXT PRIMARY KEY REFERENCES web_log_feed (id), title TEXT NOT NULL, subtitle TEXT, @@ -142,14 +147,15 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating category table..." - cmd.CommandText <- - """CREATE TABLE category ( + 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)""" + parent_id TEXT); + CREATE INDEX category_web_log_idx ON category (web_log_id)""" do! write cmd // Web log user table @@ -157,8 +163,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating web_log_user table..." - cmd.CommandText <- - """CREATE TABLE web_log_user ( + cmd.CommandText <- """ + CREATE TABLE web_log_user ( id TEXT PRIMARY KEY, web_log_id TEXT NOT NULL REFERENCES web_log (id), user_name TEXT NOT NULL, @@ -168,7 +174,9 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = password_hash TEXT NOT NULL, salt TEXT NOT NULL, url TEXT, - authorization_level TEXT NOT NULL)""" + authorization_level TEXT NOT NULL); + CREATE INDEX web_log_user_web_log_idx ON web_log_user (web_log_id); + CREATE INDEX web_log_user_user_name_idx ON web_log_user (web_log_id, user_name)""" do! write cmd // Page tables @@ -176,8 +184,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating page table..." - cmd.CommandText <- - """CREATE TABLE page ( + 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), @@ -187,14 +195,17 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = updated_on TEXT NOT NULL, show_in_page_list INTEGER NOT NULL DEFAULT 0, template TEXT, - page_text TEXT NOT NULL)""" + 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 ( + cmd.CommandText <- """ + CREATE TABLE page_meta ( page_id TEXT NOT NULL REFERENCES page (id), name TEXT NOT NULL, value TEXT NOT NULL, @@ -204,8 +215,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating page_permalink table..." - cmd.CommandText <- - """CREATE TABLE page_permalink ( + cmd.CommandText <- """ + CREATE TABLE page_permalink ( page_id TEXT NOT NULL REFERENCES page (id), permalink TEXT NOT NULL, PRIMARY KEY (page_id, permalink))""" @@ -214,8 +225,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating page_revision table..." - cmd.CommandText <- - """CREATE TABLE page_revision ( + cmd.CommandText <- """ + CREATE TABLE page_revision ( page_id TEXT NOT NULL REFERENCES page (id), as_of TEXT NOT NULL, revision_text TEXT NOT NULL, @@ -227,8 +238,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post table..." - cmd.CommandText <- - """CREATE TABLE post ( + 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), @@ -238,24 +249,29 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = published_on TEXT, updated_on TEXT NOT NULL, template TEXT, - post_text TEXT NOT NULL)""" + 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 ( + 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))""" + 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 ( + cmd.CommandText <- """ + CREATE TABLE post_episode ( post_id TEXT PRIMARY KEY REFERENCES post(id), media TEXT NOT NULL, length INTEGER NOT NULL, @@ -279,8 +295,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post_tag table..." - cmd.CommandText <- - """CREATE TABLE post_tag ( + cmd.CommandText <- """ + CREATE TABLE post_tag ( post_id TEXT NOT NULL REFERENCES post (id), tag TEXT NOT NULL, PRIMARY KEY (post_id, tag))""" @@ -289,8 +305,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post_meta table..." - cmd.CommandText <- - """CREATE TABLE post_meta ( + cmd.CommandText <- """ + CREATE TABLE post_meta ( post_id TEXT NOT NULL REFERENCES post (id), name TEXT NOT NULL, value TEXT NOT NULL, @@ -300,8 +316,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post_permalink table..." - cmd.CommandText <- - """CREATE TABLE post_permalink ( + cmd.CommandText <- """ + CREATE TABLE post_permalink ( post_id TEXT NOT NULL REFERENCES post (id), permalink TEXT NOT NULL, PRIMARY KEY (post_id, permalink))""" @@ -310,8 +326,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post_revision table..." - cmd.CommandText <- - """CREATE TABLE post_revision ( + cmd.CommandText <- """ + CREATE TABLE post_revision ( post_id TEXT NOT NULL REFERENCES post (id), as_of TEXT NOT NULL, revision_text TEXT NOT NULL, @@ -321,8 +337,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating post_comment table..." - cmd.CommandText <- - """CREATE TABLE post_comment ( + cmd.CommandText <- """ + CREATE TABLE post_comment ( id TEXT PRIMARY KEY, post_id TEXT NOT NULL REFERENCES post(id), in_reply_to_id TEXT, @@ -331,7 +347,8 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = url TEXT, status TEXT NOT NULL, posted_on TEXT NOT NULL, - comment_text TEXT NOT NULL)""" + comment_text TEXT NOT NULL); + CREATE INDEX post_comment_post_idx ON post_comment (post_id)""" do! write cmd // Tag map table @@ -339,11 +356,28 @@ type SQLiteData (conn : SqliteConnection, log : ILogger) = | true -> () | false -> log.LogInformation "Creating tag_map table..." - cmd.CommandText <- - """CREATE TABLE tag_map ( + 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)""" + 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 } diff --git a/src/MyWebLog.Domain/DataTypes.fs b/src/MyWebLog.Domain/DataTypes.fs index 36c7873..39272bd 100644 --- a/src/MyWebLog.Domain/DataTypes.fs +++ b/src/MyWebLog.Domain/DataTypes.fs @@ -295,6 +295,37 @@ type ThemeAsset = } +/// An uploaded file +type Upload = + { /// The ID of the upload + id : UploadId + + /// The ID of the web log to which this upload belongs + webLogId : WebLogId + + /// The link at which this upload is served + path : Permalink + + /// The updated date/time for this upload + updatedOn : DateTime + + /// The data for the upload + data : byte[] + } + +/// Functions to support uploaded files +module Upload = + + /// An empty upload + let empty = { + id = UploadId.empty + webLogId = WebLogId.empty + path = Permalink.empty + updatedOn = DateTime.MinValue + data = [||] + } + + /// A web log [] type WebLog = @@ -304,6 +335,9 @@ type WebLog = /// The name of the web log name : string + /// The slug of the web log + slug : string + /// A subtitle for the web log subtitle : string option @@ -327,6 +361,9 @@ type WebLog = /// Whether to automatically load htmx autoHtmx : bool + + /// Where uploads are placed + uploads : UploadDestination } /// Functions to support web logs @@ -336,6 +373,7 @@ module WebLog = let empty = { id = WebLogId.empty name = "" + slug = "" subtitle = None defaultPage = "" postsPerPage = 10 @@ -344,6 +382,7 @@ module WebLog = timeZone = "" rss = RssOptions.empty autoHtmx = false + uploads = Database } /// Get the host (including scheme) and extra path from the URL base diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index 26c388e..f18ba6f 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -556,6 +556,41 @@ type ThemeTemplate = } +/// Where uploads should be placed +type UploadDestination = + | Database + | Disk + +/// Functions to support upload destinations +module UploadDestination = + + /// Convert an upload destination to its string representation + let toString = function Database -> "database" | Disk -> "disk" + + /// Parse an upload destination from its string representation + let parse value = + match value with + | "database" -> Database + | "disk" -> Disk + | it -> invalidOp $"{it} is not a valid upload destination" + + +/// An identifier for an upload +type UploadId = UploadId of string + +/// Functions to support upload IDs +module UploadId = + + /// An empty upload ID + let empty = UploadId "" + + /// Convert an upload ID to a string + let toString = function UploadId ui -> ui + + /// Create a new upload ID + let create () = UploadId (newId ()) + + /// An identifier for a web log type WebLogId = WebLogId of string diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 0bbbcb7..49cab08 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -93,44 +93,14 @@ module CatchAll = /// Serve theme assets module Asset = - open System - open Microsoft.AspNetCore.Http.Headers - open Microsoft.AspNetCore.StaticFiles - open Microsoft.Net.Http.Headers - - /// Determine if the asset has been modified since the date/time specified by the If-Modified-Since header - let private checkModified asset (ctx : HttpContext) : HttpHandler option = - match ctx.Request.Headers.IfModifiedSince with - | it when it.Count < 1 -> None - | it -> - if asset.updatedOn > DateTime.Parse it[0] then - None - else - Some (setStatusCode 304 >=> setBodyFromString "Not Modified") - - /// An instance of ASP.NET Core's file extension to MIME type converter - let private mimeMap = FileExtensionContentTypeProvider () - // GET /theme/{theme}/{**path} - let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task { + let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { let path = urlParts |> Seq.skip 1 |> Seq.head match! ctx.Data.ThemeAsset.findById (ThemeAssetId.ofString path) with | Some asset -> - match checkModified asset ctx with + match Upload.checkModified asset.updatedOn ctx with | Some threeOhFour -> return! threeOhFour next ctx - | None -> - let mimeType = - match mimeMap.TryGetContentType path with - | true, typ -> typ - | false, _ -> "application/octet-stream" - let headers = ResponseHeaders ctx.Response.Headers - headers.LastModified <- Some (DateTimeOffset asset.updatedOn) |> Option.toNullable - headers.ContentType <- MediaTypeHeaderValue mimeType - headers.CacheControl <- - let hdr = CacheControlHeaderValue() - hdr.MaxAge <- Some (TimeSpan.FromDays 30) |> Option.toNullable - hdr - return! setBody asset.data next ctx + | None -> return! Upload.sendFile asset.updatedOn path asset.data next ctx | None -> return! Error.notFound next ctx } @@ -210,7 +180,8 @@ let router : HttpHandler = choose [ GET_HEAD >=> routef "/page/%i" Post.pageOfPosts GET_HEAD >=> routef "/page/%i/" Post.redirectToPageOfPosts GET_HEAD >=> routexp "/tag/(.*)" Post.pageOfTaggedPosts - GET_HEAD >=> routexp "/themes/(.*)" Asset.serveAsset + GET_HEAD >=> routexp "/themes/(.*)" Asset.serve + GET_HEAD >=> routexp "/upload/(.*)" Upload.serve subRoute "/user" (choose [ GET_HEAD >=> choose [ route "/log-on" >=> User.logOn None diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs new file mode 100644 index 0000000..36f196b --- /dev/null +++ b/src/MyWebLog/Handlers/Upload.fs @@ -0,0 +1,61 @@ +/// Handlers to manipulate uploaded files +module MyWebLog.Handlers.Upload + +open System +open Giraffe +open Microsoft.AspNetCore.Http +open MyWebLog + +/// Helper functions for this module +[] +module private Helpers = + + open Microsoft.AspNetCore.StaticFiles + + /// A MIME type mapper instance to use when serving files from the database + let mimeMap = FileExtensionContentTypeProvider () + + +/// 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") + + +open Microsoft.AspNetCore.Http.Headers +open Microsoft.Net.Http.Headers + +/// Derive a MIME type based on the extension of the file +let deriveMimeType path = + match mimeMap.TryGetContentType path with true, typ -> typ | false, _ -> "application/octet-stream" + +/// Send a file, caching the response for 30 days +let sendFile updatedOn path data : HttpHandler = fun next ctx -> task { + let headers = ResponseHeaders ctx.Response.Headers + headers.LastModified <- Some (DateTimeOffset updatedOn) |> Option.toNullable + headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path + headers.CacheControl <- + let hdr = CacheControlHeaderValue() + hdr.MaxAge <- Some (TimeSpan.FromDays 30) |> Option.toNullable + hdr + return! setBody data next ctx +} + +// GET /upload/{web-log-slug}/{**path} +let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { + let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/' + let slug = Array.head parts + let path = String.Join ('/', parts |> Array.skip 1) + let webLog = ctx.WebLog + if slug = webLog.slug then + match! ctx.Data.Upload.findByPath path webLog.id with + | 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! Error.notFound next ctx + else + return! Error.notFound next ctx +} diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 6a0f718..1f4502c 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -2,6 +2,7 @@ module MyWebLog.Maintenance open System open System.IO +open System.Text.RegularExpressions open Microsoft.Extensions.DependencyInjection open MyWebLog.Data @@ -23,11 +24,13 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { let webLogId = WebLogId.create () let userId = WebLogUserId.create () let homePageId = PageId.create () + let slug = ((Regex """\s+""").Replace ((Regex "[^A-z0-9 ]").Replace (args[2], ""), "-")).ToLowerInvariant () do! data.WebLog.add { WebLog.empty with id = webLogId name = args[2] + slug = slug urlBase = args[1] defaultPage = PageId.toString homePageId timeZone = timeZone @@ -162,13 +165,48 @@ module Backup = } /// Create a theme asset from an encoded theme asset - static member fromAsset (asset : EncodedAsset) : ThemeAsset = - { id = asset.id - updatedOn = asset.updatedOn - data = Convert.FromBase64String asset.data + static member fromEncoded (encoded : EncodedAsset) : ThemeAsset = + { id = encoded.id + updatedOn = encoded.updatedOn + data = Convert.FromBase64String encoded.data } + /// An uploaded file, with the data base-64 encoded + type EncodedUpload = + { /// The ID of the upload + id : UploadId + + /// The ID of the web log to which the upload belongs + webLogId : WebLogId + + /// The path at which this upload is served + path : Permalink + + /// The date/time this upload was last updated (file time) + updatedOn : DateTime + + /// The data for the upload, base-64 encoded + data : string + } + /// Create an encoded uploaded file from the original uploaded file + static member fromUpload (upload : Upload) : EncodedUpload = + { id = upload.id + webLogId = upload.webLogId + path = upload.path + updatedOn = upload.updatedOn + data = Convert.ToBase64String upload.data + } + + /// Create an uploaded file from an encoded uploaded file + static member fromEncoded (encoded : EncodedUpload) : Upload = + { id = encoded.id + webLogId = encoded.webLogId + path = encoded.path + updatedOn = encoded.updatedOn + data = Convert.FromBase64String encoded.data + } + /// A unified archive for a web log type Archive = { /// The web log to which this archive belongs @@ -194,6 +232,9 @@ module Backup = /// The posts for this web log (containing only the most recent revision) posts : Post list + + /// The uploaded files for this web log + uploads : EncodedUpload list } /// Create a JSON serializer (uses RethinkDB data implementation's JSON converters) @@ -212,6 +253,7 @@ module Backup = let tagMapCount = List.length archive.tagMappings let pageCount = List.length archive.pages let postCount = List.length archive.posts + let uploadCount = List.length archive.uploads // Create a pluralized output based on the count let plural count ifOne ifMany = @@ -225,6 +267,7 @@ module Backup = printfn $""" - {tagMapCount} tag mapping{plural tagMapCount "" "s"}""" printfn $""" - {pageCount} page{plural pageCount "" "s"}""" printfn $""" - {postCount} post{plural postCount "" "s"}""" + printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}""" /// Create a backup archive let private createBackup webLog (fileName : string) prettyOutput (data : IData) = task { @@ -248,6 +291,9 @@ module Backup = printfn "- Exporting posts..." let! posts = data.Post.findFullByWebLog webLog.id + printfn "- Exporting uploads..." + let! uploads = data.Upload.findByWebLog webLog.id + printfn "- Writing archive..." let archive = { webLog = webLog @@ -256,8 +302,9 @@ module Backup = assets = assets |> List.map EncodedAsset.fromAsset categories = categories tagMappings = tagMaps - pages = pages |> List.map (fun p -> { p with revisions = List.truncate 1 p.revisions }) - posts = posts |> List.map (fun p -> { p with revisions = List.truncate 1 p.revisions }) + pages = pages |> List.map (fun p -> { p with revisions = List.truncate 1 p.revisions }) + posts = posts |> List.map (fun p -> { p with revisions = List.truncate 1 p.revisions }) + uploads = uploads |> List.map EncodedUpload.fromUpload } // Write the structure to the backup file @@ -284,6 +331,7 @@ module Backup = let newPageIds = archive.pages |> List.map (fun page -> page.id, PageId.create ()) |> dict let newPostIds = archive.posts |> List.map (fun post -> post.id, PostId.create ()) |> dict let newUserIds = archive.users |> List.map (fun user -> user.id, WebLogUserId.create ()) |> dict + let newUpIds = archive.uploads |> List.map (fun up -> up.id, UploadId.create ()) |> dict return { archive with webLog = { archive.webLog with id = newWebLogId; urlBase = Option.get newUrlBase } @@ -308,6 +356,8 @@ module Backup = authorId = newUserIds[post.authorId] categoryIds = post.categoryIds |> List.map (fun c -> newCatIds[c]) }) + uploads = archive.uploads + |> List.map (fun u -> { u with id = newUpIds[u.id]; webLogId = newWebLogId }) } | None -> return @@ -320,7 +370,7 @@ module Backup = printfn "" printfn "- Importing theme..." do! data.Theme.save restore.theme - let! _ = restore.assets |> List.map (EncodedAsset.fromAsset >> data.ThemeAsset.save) |> Task.WhenAll + let! _ = restore.assets |> List.map (EncodedAsset.fromEncoded >> data.ThemeAsset.save) |> Task.WhenAll // Restore web log data @@ -342,6 +392,9 @@ module Backup = // TODO: comments not yet implemented + printfn "- Restoring uploads..." + do! data.Upload.restore (restore.uploads |> List.map EncodedUpload.fromEncoded) + displayStats "Restored for {{NAME}}:" restore.webLog restore } diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 128f153..f993c63 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -18,6 +18,7 @@ + @@ -41,7 +42,7 @@ - + diff --git a/src/MyWebLog/wwwroot/upload/.gitkeep b/src/MyWebLog/wwwroot/upload/.gitkeep new file mode 100644 index 0000000..e69de29