WIP on legacy migration

This commit is contained in:
Daniel J. Summers 2023-01-31 11:39:30 -05:00
parent bdb51921b3
commit e5f76d4b1d
4 changed files with 130 additions and 12 deletions

View File

@ -204,6 +204,71 @@ let trySecurityByToken token = backgroundTask {
let legacy () = backgroundTask {
return!
dataSource ()
|> Sql.query $"SELECT * FROM {Table.Citizen} WHERE data ->> 'isLegacy' = 'true'"
|> Sql.query $"SELECT * FROM {Table.Citizen} WHERE data ->> 'isLegacy' = 'true' ORDER BY data ->> 'firstName'"
|> Sql.executeAsync toDocument<Citizen>
}
/// Get all current citizens with verified accounts but without a profile
let current () = backgroundTask {
return!
dataSource ()
|> Sql.query $"
SELECT c.*
FROM {Table.Citizen} c
INNER JOIN {Table.SecurityInfo} si ON si.id = c.id
WHERE c.data ->> 'isLegacy' = 'false'
AND si.data ->> 'accountLocked' = 'false'
AND NOT EXISTS (SELECT 1 FROM {Table.Profile} p WHERE p.id = c.id)"
|> Sql.executeAsync toDocument<Citizen>
}
let migrateLegacy currentId legacyId = backgroundTask {
let curId = CitizenId.toString currentId
let legId = CitizenId.toString legacyId
let connProps = dataSource ()
use conn = Sql.createConnection connProps
use! txn = conn.BeginTransactionAsync ()
try
// Add legacy data to current user
let! _ =
conn
|> Sql.existingConnection
|> Sql.query $"INSERT INTO {Table.Profile} SELECT @id, data FROM {Table.Profile} WHERE id = @oldId"
|> Sql.parameters [ "@id", Sql.string curId; "@oldId", Sql.string legId ]
|> Sql.executeNonQueryAsync
let! listings =
conn
|> Sql.existingConnection
|> Sql.query $"SELECT * FROM {Table.Listing} WHERE data ->> 'citizenId' = @oldId"
|> Sql.parameters [ "@oldId", Sql.string legId ]
|> Sql.executeAsync toDocument<Listing>
for listing in listings do
let newListing = { listing with Id = ListingId.create (); CitizenId = currentId }
do! saveDocument
Table.Listing (ListingId.toString newListing.Id) (Sql.existingConnection conn) (mkDoc newListing)
let! successes =
conn
|> Sql.existingConnection
|> Sql.query $"SELECT * FROM {Table.Success} WHERE data ->> 'citizenId' = @oldId"
|> Sql.parameters [ "@oldId", Sql.string legId ]
|> Sql.executeAsync toDocument<Success>
for success in successes do
let newSuccess = { success with Id = SuccessId.create (); CitizenId = currentId }
do! saveDocument
Table.Success (SuccessId.toString newSuccess.Id) (Sql.existingConnection conn) (mkDoc newSuccess)
// Delete legacy data
let! _ =
conn
|> Sql.existingConnection
|> Sql.query $"
DELETE FROM {Table.Success} WHERE data ->> 'citizenId' = @oldId;
DELETE FROM {Table.Listing} WHERE data ->> 'citizenId' = @oldId;
DELETE FROM {Table.Citizen} WHERE id = @oldId"
|> Sql.parameters [ "@oldId", Sql.string legId ]
|> Sql.executeNonQueryAsync
do! txn.CommitAsync ()
return Ok ""
with :? Npgsql.PostgresException as ex ->
do! txn.RollbackAsync ()
return Error ex.MessageText
}

View File

@ -151,3 +151,14 @@ type ResetPasswordForm =
/// The new password for the account
Password : string
}
// ~~~ LEGACY MIGRATION ~~ //
[<CLIMutable; NoComparison; NoEquality>]
type LegacyMigrationForm =
{ /// The ID of the current citizen
Id : string
/// The ID of the legacy citizen to be migrated
LegacyId : string
}

View File

@ -335,10 +335,22 @@ let soLong : HttpHandler = requireUser >=> fun next ctx ->
// ~~~ LEGACY MIGRATION ~~~ //
// GET: /citizen/legacy/list
let listLegacy : HttpHandler = Auth.requireAdmin >=> fun next ctx -> task {
let! users = Data.legacy ()
return! Views.listLegacy users |> render "Migrate Legacy Account" next ctx
// GET: /citizen/legacy
let legacy : HttpHandler = Auth.requireAdmin >=> fun next ctx -> task {
let! currentUsers = Data.current ()
let! legacyUsers = Data.legacy ()
return! Views.legacy currentUsers legacyUsers (csrf ctx) |> render "Migrate Legacy Account" next ctx
}
// POST: /citizen/legacy/migrate
let migrateLegacy : HttpHandler = Auth.requireAdmin >=> validateCsrf >=> fun next ctx -> task {
let! form = ctx.BindFormAsync<LegacyMigrationForm> ()
let currentId = CitizenId.ofString form.Id
let legacyId = CitizenId.ofString form.LegacyId
match! Data.migrateLegacy currentId legacyId with
| Ok _ -> do! addSuccess "Migration successful" ctx
| Error err -> do! addError err ctx
return! redirectToGet "/citizen/legacy" next ctx
}
open Giraffe.EndpointRouting
@ -358,7 +370,7 @@ let endpoints =
route "/register" register
routef "/reset-password/%s" resetPassword
route "/so-long" soLong
route "/legacy/list" listLegacy
route "/legacy" legacy
]
POST [
route "/delete" delete
@ -367,5 +379,6 @@ let endpoints =
route "/register" doRegistration
route "/reset-password" doResetPassword
route "/save-account" saveAccount
route "/legacy/migrate" migrateLegacy
]
]

View File

@ -396,20 +396,49 @@ let resetPassword (m : ResetPasswordForm) isHtmx csrf =
// ~~~ LEGACY MIGRATION ~~~ //
let listLegacy (m : Citizen list) =
[ table [ _class "table table-sm table-hover" ] [
let legacy (current : Citizen list) (legacy : Citizen list) csrf =
form [ _class "container"; _hxPost "/citizen/legacy/migrate" ] [
antiForgery csrf
let canProcess = not (List.isEmpty current)
div [ _class "row" ] [
if canProcess then
div [ _class "col-12 col-lg-6 col-xxl-4" ] [
div [ _class "form-floating" ] [
select [ _id "current"; _name "Id"; _class "form-control" ] [
option [ _value "" ] [ txt "&ndash; Select &ndash;" ]
yield!
current
|> List.sortBy Citizen.name
|> List.map (fun it ->
option [ _value (CitizenId.toString it.Id) ] [
str (Citizen.name it); txt " ("; str it.Email; txt ")"
])
]
label [ _for "current" ] [ txt "Current User" ]
]
]
else p [] [ txt "There are no current accounts to which legacy accounts can be migrated" ]
]
table [ _class "table table-sm table-hover" ] [
thead [] [
tr [] [
th [ _scope "col" ] [ txt "Action" ]
th [ _scope "col" ] [ txt "Select" ]
th [ _scope "col" ] [ txt "NAS Profile" ]
]
]
m |> List.map (fun it ->
legacy |> List.map (fun it ->
let theId = CitizenId.toString it.Id
tr [] [
td [] [ a [ _href $"/citizen/legacy/{CitizenId.toString it.Id}/associate" ] [ txt "Migrate" ] ]
td [] [ str it.Email ]
td [] [
if canProcess then
input [ _type "radio"; _id $"legacy_{theId}"; _name "LegacyId"; _value theId ]
else txt "&nbsp;"
]
td [] [ label [ _for $"legacy_{theId}" ] [ str it.Email ] ]
])
|> tbody []
]
submitButton "save" "Migrate Account"
]
|> List.singleton
|> pageWithTitle "Migrate Legacy Account"