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