namespace Gitea.Declarative open System open System.Collections.Generic open Microsoft.Extensions.Logging type AlignmentError<'a> = | UnexpectedlyPresent | DoesNotExist of desired : 'a | ConfigurationDiffers of desired : 'a * actual : 'a override this.ToString () = match this with | UnexpectedlyPresent -> "Found on Gitea, but was not in configuration." | DoesNotExist _ -> "Present in configuration, but absent on Gitea." | ConfigurationDiffers (desired, actual) -> $"Differs from config. Desired: {desired}. Actual: {actual}." [] module Gitea = let checkUsers (config : GiteaConfig) (client : GiteaClient.IGiteaClient) : Async>>> = async { let desiredUsers = config.Users let! actualUsers = List.getPaginated (fun page limit -> async { let! ct = Async.CancellationToken return! client.AdminGetAllUsers (page, limit, ct) |> Async.AwaitTask } ) let actualUsers = actualUsers |> Seq.map (fun u -> match u.Login with | None -> failwith "Gitea presented a user with no login!" | Some login -> User login, UserInfo.Render u ) |> Map.ofSeq let errors = actualUsers |> Map.toSeq |> Seq.choose (fun (user, actual) -> match Map.tryFind user desiredUsers with | None -> (user, AlignmentError.UnexpectedlyPresent) |> Some | Some desired -> if desired <> actual then (user, AlignmentError.ConfigurationDiffers (desired, actual)) |> Some else None ) |> Map.ofSeq let otherErrors = desiredUsers |> Map.toSeq |> Seq.choose (fun (user, desired) -> match Map.tryFind user actualUsers with | None -> (user, AlignmentError.DoesNotExist desired) |> Some | Some actual -> if desired <> actual then (user, AlignmentError.ConfigurationDiffers (desired, actual)) |> Some else None ) |> Map.ofSeq let together = Map.union (fun _ x _ -> x) errors otherErrors return if together.IsEmpty then Ok () else Error together } // TODO: check whether mirrors are out of sync e.g. in Public/Private status let checkRepos (logger : ILogger) (config : GiteaConfig) (client : GiteaClient.IGiteaClient) : Async>>>> = async { let! errors = config.Repos |> Map.toSeq |> Seq.map (fun (User user as u, desiredRepos) -> let desiredRepos = desiredRepos |> Map.map (fun _ v -> v.OverrideDefaults ()) async { let! repos = List.getPaginated (fun page count -> async { let! ct = Async.CancellationToken return! client.UserListRepos (user, page, count, ct) |> Async.AwaitTask } ) let! actualRepos = repos |> Seq.map (fun repo -> async { let! rendered = Repo.Render client repo match repo.Name with | None -> return failwith "Gitea presented us with a repo with no name!" | Some repoName -> return RepoName repoName, rendered } ) |> Async.Parallel let actualRepos = Map.ofArray actualRepos let errors1 = actualRepos |> Map.toSeq |> Seq.choose (fun (repo, actual) -> match Map.tryFind repo desiredRepos with | None -> Some (repo, AlignmentError.UnexpectedlyPresent) | Some desired -> if desired <> actual then (repo, AlignmentError.ConfigurationDiffers (desired, actual)) |> Some else None ) |> Map.ofSeq let errors2 = desiredRepos |> Map.toSeq |> Seq.choose (fun (repo, desired) -> match Map.tryFind repo actualRepos with | None -> if desired.Deleted = Some true then logger.LogInformation ( "The repo {User}:{Repo} is configured as Deleted, and is absent from the server. Remove this repo from configuration.", user, let (RepoName repo) = repo in repo ) None else Some (repo, AlignmentError.DoesNotExist desired) | Some actual -> if desired <> actual then (repo, AlignmentError.ConfigurationDiffers (desired, actual)) |> Some else None ) |> Map.ofSeq return u, Map.union (fun _ v _ -> v) errors1 errors2 } ) |> Async.Parallel let errors = errors |> Array.filter (fun (_, m) -> not m.IsEmpty) return if errors.Length = 0 then Ok () else Error (Map.ofArray errors) } let private createPushMirrorOption (target : Uri) (githubToken : string) : GiteaClient.CreatePushMirrorOption = { SyncOnCommit = Some true RemoteAddress = (target : Uri).ToString () |> Some RemoteUsername = Some githubToken RemotePassword = Some githubToken Interval = Some "8h0m0s" AdditionalProperties = Dictionary () } let reconcileDifferingConfiguration (logger : ILogger) (client : GiteaClient.IGiteaClient) (githubApiToken : string option) (user : string) (repoName : string) (desired : Repo) (actual : Repo) : Async = if desired.Deleted = Some true then async { logger.LogWarning ("Deleting repo {User}:{Repo}", user, repoName) let! ct = Async.CancellationToken return! Async.AwaitTask (client.RepoDelete (user, repoName, ct)) } else match desired.GitHub, actual.GitHub with | None, Some gitHub -> async { logger.LogCritical ( "Unable to reconcile the desire to move a repo from GitHub-based to Gitea-based. This feature is not exposed on the Gitea API. You must manually convert the following repo to a normal repository first: {User}:{Repo}.", user, repoName ) } | Some _, None -> async { logger.LogError ( "Unable to reconcile the desire to move a repo from Gitea-based to GitHub-based: {User}:{Repo}.", user, repoName ) } | Some desiredGitHub, Some actualGitHub -> async { let mutable hasChanged = false if desiredGitHub.Uri <> actualGitHub.Uri then logger.LogError ( "Refusing to migrate repo {User}:{Repo} to a different GitHub URL. Desired: {DesiredUrl}. Actual: {ActualUrl}.", user, repoName, desiredGitHub.Uri, actualGitHub.Uri ) let options : GiteaClient.EditRepoOption = { AdditionalProperties = Dictionary () AllowManualMerge = None AllowMergeCommits = None AllowRebase = None AllowRebaseExplicit = None AllowRebaseUpdate = None AllowSquashMerge = None Archived = None AutodetectManualMerge = None DefaultAllowMaintainerEdit = None DefaultBranch = None DefaultDeleteBranchAfterMerge = None DefaultMergeStyle = None EnablePrune = None ExternalTracker = None ExternalWiki = None HasIssues = None HasProjects = None HasPullRequests = None HasWiki = None IgnoreWhitespaceConflicts = None InternalTracker = None MirrorInterval = if desiredGitHub.MirrorInterval <> actualGitHub.MirrorInterval then logger.LogDebug ( "On {User}:{Repo}, setting {Property}", user, repoName, "MirrorInterval" ) hasChanged <- true Some desiredGitHub.MirrorInterval Name = None Private = None Template = None Website = None Description = if desired.Description <> actual.Description then logger.LogDebug ("On {User}:{Repo}, setting {Property}", user, repoName, "Description") hasChanged <- true Some desired.Description } if hasChanged then let! ct = Async.CancellationToken let! _result = client.RepoEdit (user, repoName, options, ct) |> Async.AwaitTask return () } | None, None -> async { let mutable hasChanged = false let desired' = match desired.Native with | None -> failwith $"Expected a native section of desired for {user}:{repoName} since there was no GitHub, but got None" | Some n -> n let actual' = match actual.Native with | None -> failwith $"Expected a native section of actual for {user}:{repoName} since there was no GitHub, but got None" | Some n -> n let setPropertyIfNecessary (desired : 'a option) (actual : 'a option) (propertyName : string) : 'a option = match desired, actual with | None, None -> None | None, Some v -> // This has been taken out of our management; do nothing. logger.LogDebug ( "On {User}:{Repo}, no longer managing {Property} property (value: {CurrentValue})", user, repoName, propertyName, v ) None | Some desired', _ -> if Some desired' <> actual then logger.LogDebug ("On {User}:{Repo}, will set {Property} property", user, repoName, propertyName) hasChanged <- true Some desired' let setProperty (desired : 'a) (actual : 'a) (propertyName : string) : 'a = if desired <> actual then logger.LogDebug ("On {User}:{Repo}, will set {Property} property", user, repoName, propertyName) hasChanged <- true desired let options : GiteaClient.EditRepoOption = { AdditionalProperties = Dictionary () AllowManualMerge = None AllowMergeCommits = setPropertyIfNecessary desired'.AllowMergeCommits actual'.AllowMergeCommits "AllowMergeCommits" AllowRebase = setPropertyIfNecessary desired'.AllowRebase actual'.AllowRebase "AllowRebase" AllowRebaseExplicit = setPropertyIfNecessary desired'.AllowRebaseExplicit actual'.AllowRebaseExplicit "AllowRebaseExplicit" AllowRebaseUpdate = setPropertyIfNecessary desired'.AllowRebaseUpdate actual'.AllowRebaseUpdate "AllowRebaseUpdate" AllowSquashMerge = setPropertyIfNecessary desired'.AllowSquashMerge actual'.AllowSquashMerge "AllowSquashMerge" Archived = None AutodetectManualMerge = None DefaultAllowMaintainerEdit = None DefaultBranch = setProperty desired'.DefaultBranch actual'.DefaultBranch "DefaultBranch" |> Some DefaultDeleteBranchAfterMerge = setPropertyIfNecessary desired'.DeleteBranchAfterMerge actual'.DeleteBranchAfterMerge "DeleteBranchAfterMerge" DefaultMergeStyle = setPropertyIfNecessary desired'.DefaultMergeStyle actual'.DefaultMergeStyle "DefaultMergeStyle" |> Option.map (fun ms -> (ms : MergeStyle).ToString ()) Description = setPropertyIfNecessary (Some desired.Description) (Some actual.Description) "Description" EnablePrune = None ExternalTracker = None ExternalWiki = None HasIssues = setPropertyIfNecessary desired'.HasIssues actual'.HasIssues "HasIssues" HasProjects = setPropertyIfNecessary desired'.HasProjects actual'.HasProjects "HasProjects" HasPullRequests = setPropertyIfNecessary desired'.HasPullRequests actual'.HasPullRequests "HasPullRequests" HasWiki = setPropertyIfNecessary desired'.HasWiki actual'.HasWiki "HasWiki" IgnoreWhitespaceConflicts = setPropertyIfNecessary desired'.IgnoreWhitespaceConflicts actual'.IgnoreWhitespaceConflicts "IgnoreWhitespaceConflicts" InternalTracker = None MirrorInterval = None Name = None Private = setPropertyIfNecessary desired'.Private actual'.Private "Private" Template = None Website = None } let! ct = Async.CancellationToken do! if hasChanged then logger.LogInformation ("Editing repo {User}:{Repo}", user, repoName) client.RepoEdit (user, repoName, options, ct) |> Async.AwaitTask |> Async.Ignore else async.Return () // Push mirrors do! let desired = desired'.Mirrors |> List.groupBy (fun m -> (m.GitHubAddress : Uri).ToString ()) |> Map.ofList let desired = desired |> Map.toSeq |> Seq.map (fun (name, pm) -> match pm with | [] -> failwith "LOGIC ERROR" | [ pm ] -> (pm.GitHubAddress : Uri).ToString () | _ -> failwith $"Config validation failed on repo %s{repoName}: multiple push mirrors configured for target %s{name}" ) |> Set.ofSeq let actual = actual'.Mirrors |> List.groupBy (fun m -> (m.GitHubAddress : Uri).ToString ()) |> Map.ofList // If any mirror target has multiple push mirrors for it, just delete them all before continuing. let deleteExisting = actual |> Map.toSeq |> Seq.choose (fun (k, vs) -> match vs with | [] -> failwith "LOGIC ERROR" | [ _ ] -> None | vs -> vs |> List.map (fun pm -> async { logger.LogWarning ( "Multiple push mirrors on repo {Owner}/{RepoName} for target {PushMirrorTarget} found. Deleting them all before recreating.", user, repoName, k ) let! ct = Async.CancellationToken // sigh, domain model - it's *such* a faff to represent this correctly though do! client.RepoDeletePushMirror (user, repoName, Option.get pm.RemoteName, ct) |> Async.AwaitTask } ) |> Async.Sequential |> Async.map (Array.iter id) |> Some ) |> Seq.toList let actual = match deleteExisting with | [] -> actual | _ -> Map.empty let distinctActual = actual.Keys |> Set.ofSeq let presentButNotDesired = Set.difference distinctActual desired let desiredButNotPresent = Set.difference desired distinctActual let deleteUndesired = presentButNotDesired |> Seq.map (fun toDelete -> logger.LogWarning ( "Deleting push mirror on repo {Owner}/{RepoName} for target {PushMirrorTarget}", user, repoName, toDelete ) let toDelete = actual.[toDelete] toDelete |> Seq.map (fun pm -> async { let! ct = Async.CancellationToken do! client.RepoDeletePushMirror (user, repoName, Option.get pm.RemoteName, ct) |> Async.AwaitTask } ) |> Async.Sequential |> Async.map (Array.iter id) ) |> Async.Sequential |> Async.map (Array.iter id) let addDesired = desiredButNotPresent |> Seq.map (fun toAdd -> match githubApiToken with | None -> async { logger.LogCritical ( "Cannot add push mirror for {User}:{Repo} due to lack of GitHub API token", user, repoName ) } | Some token -> async { logger.LogInformation ("Setting up push mirror on {User}:{Repo}", user, repoName) let! ct = Async.CancellationToken let pushMirrorOption = createPushMirrorOption (Uri toAdd) token let! _ = client.RepoAddPushMirror (user, repoName, pushMirrorOption, ct) |> Async.AwaitTask return () } ) |> Async.Sequential |> Async.map (Array.iter id) async { do! deleteExisting |> Async.Sequential |> Async.map (Array.iter id) do! deleteUndesired do! addDesired } // Collaborators do! let desiredButNotPresent = Set.difference desired'.Collaborators actual'.Collaborators let presentButNotDesired = Set.difference actual'.Collaborators desired'.Collaborators [| desiredButNotPresent |> Seq.map (fun desired -> async { logger.LogTrace ( "Setting collaborator {Collaborator} on repo {User}:{Repo}", desired, user, repoName ) let option : GiteaClient.AddCollaboratorOption = { AdditionalProperties = Dictionary () Permission = None } let! ct = Async.CancellationToken do! client.RepoAddCollaborator (user, repoName, desired, option, ct) |> Async.AwaitTask } ) |> Async.Parallel |> Async.map (Array.iter id) presentButNotDesired |> Seq.map (fun desired -> async { logger.LogTrace ( "Deleting collaborator {Collaborator} on repo {User}:{Repo}", desired, user, repoName ) let! ct = Async.CancellationToken do! client.RepoDeleteCollaborator (user, repoName, desired, ct) |> Async.AwaitTask } ) |> Async.Parallel |> Async.map (Array.iter id) |] |> Async.Parallel |> Async.map (Array.iter id) do! // TODO: lift this out to a function and then put it into the new-repo flow too // The current behaviour is kind of desirable, because it gives you a chance to push to // the protected branch before it becomes protected. let extraActualProtected = Set.difference actual'.ProtectedBranches desired'.ProtectedBranches let extraDesiredProtected = Set.difference desired'.ProtectedBranches actual'.ProtectedBranches Seq.append (Seq.map Choice1Of2 extraActualProtected) (Seq.map Choice2Of2 extraDesiredProtected) |> Seq.groupBy (fun b -> match b with | Choice1Of2 b -> b.BranchName | Choice2Of2 b -> b.BranchName ) |> Seq.map (fun (key, values) -> match Seq.toList values with | [] -> failwith "can't have appeared no times in a groupBy" | [ Choice1Of2 x ] -> // This is an extra rule; delete it async { logger.LogInformation ( "Deleting branch protection rule {BranchProtection} on {User}:{Repo}", x.BranchName, user, repoName ) let! ct = Async.CancellationToken let! _ = client.RepoDeleteBranchProtection (user, repoName, x.BranchName, ct) |> Async.AwaitTask return () } | [ Choice2Of2 y ] -> // This is an absent rule; add it async { logger.LogInformation ( "Creating branch protection rule {BranchProtection} on {User}:{Repo}", y.BranchName, user, repoName ) let s : GiteaClient.CreateBranchProtectionOption = { AdditionalProperties = Dictionary () ApprovalsWhitelistTeams = None ApprovalsWhitelistUsername = None BlockOnOfficialReviewRequests = None BlockOnOutdatedBranch = y.BlockOnOutdatedBranch BlockOnRejectedReviews = None BranchName = Some y.BranchName DismissStaleApprovals = None EnableApprovalsWhitelist = None EnableMergeWhitelist = None EnablePush = None EnablePushWhitelist = None EnableStatusCheck = None MergeWhitelistTeams = None MergeWhitelistUsernames = None ProtectedFilePatterns = None PushWhitelistDeployKeys = None PushWhitelistTeams = None PushWhitelistUsernames = None RequireSignedCommits = None RequiredApprovals = None RuleName = Some y.BranchName StatusCheckContexts = None UnprotectedFilePatterns = None } let! ct = Async.CancellationToken let! _ = client.RepoCreateBranchProtection (user, repoName, s, ct) |> Async.AwaitTask return () } | [ Choice1Of2 x ; Choice2Of2 y ] | [ Choice2Of2 y ; Choice1Of2 x ] -> // Need to reconcile the two; the Choice2Of2 is what we want to keep async { logger.LogInformation ( "Reconciling branch protection rule {BranchProtection} on {User}:{Repo}", y.BranchName, user, repoName ) let statusCheck, contents = match y.RequiredStatusChecks with | None -> false, None | Some checks -> true, Some checks let s : GiteaClient.EditBranchProtectionOption = { AdditionalProperties = Dictionary () ApprovalsWhitelistTeams = None ApprovalsWhitelistUsername = None BlockOnOfficialReviewRequests = None BlockOnOutdatedBranch = y.BlockOnOutdatedBranch BlockOnRejectedReviews = None DismissStaleApprovals = None EnableApprovalsWhitelist = None EnableMergeWhitelist = None EnablePush = None EnablePushWhitelist = None EnableStatusCheck = Some statusCheck MergeWhitelistTeams = None MergeWhitelistUsernames = None ProtectedFilePatterns = None PushWhitelistDeployKeys = None PushWhitelistTeams = None PushWhitelistUsernames = None RequireSignedCommits = None RequiredApprovals = None StatusCheckContexts = contents UnprotectedFilePatterns = None } let! ct = Async.CancellationToken let! _ = client.RepoEditBranchProtection (user, repoName, y.BranchName, s, ct) |> Async.AwaitTask return () } | [ Choice1Of2 _ ; Choice1Of2 _ ] | [ Choice2Of2 _ ; Choice2Of2 _ ] -> failwith "can't have the same choice appearing twice" | _ :: _ :: _ :: _ -> failwith "can't have appeared three times" ) |> Async.Parallel |> Async.map (Array.iter id) } let reconcileRepoErrors (logger : ILogger) (client : GiteaClient.IGiteaClient) (githubApiToken : string option) (m : Map>>) : Async = m |> Map.toSeq |> Seq.collect (fun (User user, errMap) -> errMap |> Map.toSeq |> Seq.map (fun (RepoName r, err) -> match err with | AlignmentError.DoesNotExist desired -> async { logger.LogDebug ("Creating {User}:{Repo}", user, r) match desired.GitHub, desired.Native with | None, None -> failwith $"You must supply exactly one of Native or GitHub for {user}:{r}." | Some _, Some _ -> failwith $"Repo {user}:{r} has both Native and GitHub set; you must set exactly one." | None, Some native -> let options : GiteaClient.CreateRepoOption = { AdditionalProperties = Dictionary () AutoInit = None DefaultBranch = Some native.DefaultBranch Description = Some desired.Description Gitignores = None IssueLabels = None License = None Name = r Private = native.Private Readme = None Template = None TrustModel = None } let! ct = Async.CancellationToken let! result = client.AdminCreateRepo (user, options, ct) |> Async.AwaitTask |> Async.Catch match result with | Choice2Of2 e -> raise (AggregateException ($"Error creating {user}:{r}", e)) | Choice1Of2 _ -> () match native.Mirrors, githubApiToken with | [], _ -> () | _ :: _, None -> failwith "Cannot push to GitHub mirror without an API key" | mirrors, Some token -> logger.LogInformation ("Setting up push mirror for {User}:{Repo}", user, r) let! actualMirrors = List.getPaginated (fun page count -> async { let! ct = Async.CancellationToken return! client.RepoListPushMirrors (user, r, page, count, ct) |> Async.AwaitTask } ) do! mirrors |> List.map (fun mirror -> let options : GiteaClient.CreatePushMirrorOption = { AdditionalProperties = Dictionary () Interval = Some "8h0m0s" RemoteAddress = (mirror.GitHubAddress : Uri).ToString () |> Some RemotePassword = Some token RemoteUsername = Some token SyncOnCommit = Some true } async { match actualMirrors |> List.tryFind (fun m -> m.RemoteAddress = options.RemoteAddress) with | None -> let! _ = client.RepoAddPushMirror (user, r, options) |> Async.AwaitTask () | Some existing -> if existing.SyncOnCommit <> Some true then failwith $"sync on commit should have been true for {user}:{r}" } ) |> Async.Sequential |> Async.map (Array.iter id) | Some github, None -> let options : GiteaClient.MigrateRepoOptions = { AdditionalProperties = Dictionary () AuthPassword = None AuthToken = githubApiToken AuthUsername = None CloneAddr = string github.Uri Issues = Some true Labels = Some true Lfs = Some true LfsEndpoint = None Milestones = Some true Mirror = Some true MirrorInterval = Some "8h0m0s" // TODO - migrate private status Private = None PullRequests = Some true Releases = Some true RepoName = r RepoOwner = Some user Service = None Uid = None Wiki = Some true Description = Some desired.Description } let! result = client.RepoMigrate options |> Async.AwaitTask |> Async.Catch match result with | Choice2Of2 e -> raise (AggregateException ($"Error migrating {user}:{r}", e)) | Choice1Of2 _ -> () logger.LogInformation ("Created repo {User}: {Repo}", user, r) let! newlyCreated = client.RepoGet (user, r) |> Async.AwaitTask let! newlyCreated = Repo.Render client newlyCreated do! reconcileDifferingConfiguration logger client githubApiToken user r desired newlyCreated return () } | AlignmentError.UnexpectedlyPresent -> async { logger.LogError ( "In the absence of the `deleted: true` configuration, refusing to delete unexpectedly present repo: {User}, {Repo}", user, r ) } | AlignmentError.ConfigurationDiffers (desired, actual) -> reconcileDifferingConfiguration logger client githubApiToken user r desired actual ) ) |> Async.Parallel |> fun a -> async.Bind (a, Array.iter id >> async.Return) let rec constructEditObject (log : ILogger) (user : string) (updates : UserInfoUpdate list) (body : GiteaClient.EditUserOption) : GiteaClient.EditUserOption = match updates with | [] -> body | h :: rest -> match h with | UserInfoUpdate.Admin (desired, actual) -> match desired, actual with | None, None -> body | None, Some _ -> log.LogDebug ("No longer managing property {Property} for user {User}", "Admin", user) body | Some desired, _ -> log.LogDebug ("Editing {User}, property {Property}", user, "Admin") { body with Admin = Some desired } | UserInfoUpdate.Email (desired, actual) -> log.LogDebug ("Editing {User}, property {Property}", user, "Email") { body with Email = Some desired } | UserInfoUpdate.Visibility (desired, actual) -> log.LogDebug ("Editing {User}, property {Property}", user, "Visibility") { body with Visibility = Some desired } | UserInfoUpdate.Website (desired, actual) -> // Per https://github.com/go-gitea/gitea/issues/17126, // the website parameter can't currently be edited. // This is a bug that is unlikely to be fixed. let actual = match actual with | None -> "" | Some uri -> uri.ToString () log.LogCritical ( "User {User} has conflicting website, desired {DesiredWebsite}, existing {ActualWebsite}, which a bug in Gitea means can't be reconciled via the API.", user, desired, actual ) body |> constructEditObject log user rest let reconcileUserErrors (log : ILogger) (getUserInput : string -> string) (client : GiteaClient.IGiteaClient) (m : Map>) = let userInputLock = obj () m |> Map.toSeq |> Seq.map (fun (User user, err) -> match err with | AlignmentError.DoesNotExist desired -> async { log.LogDebug ("Creating {User}", user) let rand = Random () let pwd = Array.init 15 (fun _ -> rand.Next (65, 65 + 25) |> byte) |> System.Text.Encoding.ASCII.GetString let options : GiteaClient.CreateUserOption = { AdditionalProperties = Dictionary () CreatedAt = None Email = desired.Email FullName = Some user LoginName = Some user MustChangePassword = Some true Password = pwd Restricted = None SendNotify = None SourceId = None Username = user Visibility = match desired.Visibility with | None -> Some "public" | Some v -> Some v } let! _ = client.AdminCreateUser options |> Async.AwaitTask lock userInputLock (fun () -> log.LogCritical ( "Created user {User} with password {Password}, which you must now change", user, pwd ) ) return () } | AlignmentError.UnexpectedlyPresent -> async { lock userInputLock (fun () -> let answer = UserInput.getDefaultNo getUserInput $"User %s{user} unexpectedly present. Remove?" if answer then client.AdminDeleteUser(user, false).Result else log.LogCritical ("Refusing to delete user {User}, who is unexpectedly present.", user) ) } | AlignmentError.ConfigurationDiffers (desired, actual) -> let updates = UserInfo.Resolve desired actual async { lock userInputLock (fun () -> let body : GiteaClient.EditUserOption = { AdditionalProperties = Dictionary () Active = None Admin = None AllowCreateOrganization = None AllowGitHook = None AllowImportLocal = None Description = None Email = None FullName = None Location = None LoginName = user MaxRepoCreation = None MustChangePassword = None Password = None ProhibitLogin = None Restricted = None SourceId = // Wouldn't it be lovely if *any* of this were documented? // I still have no idea what this does; it's optional when creating a user, // but mandatory when editing a user. 0 Visibility = None Website = None } let body = constructEditObject log user updates body client.AdminEditUser(user, body).Result |> ignore ) } ) |> Async.Parallel |> fun a -> async.Bind (a, Array.iter id >> async.Return) let toRefresh (client : GiteaClient.IGiteaClient) : Async>> = async { let! ct = Async.CancellationToken let! users = List.getPaginated (fun page limit -> client.AdminGetAllUsers (page, limit, ct) |> Async.AwaitTask) let! results = users |> Seq.map (fun user -> async { let loginName = match user.LoginName with | None -> failwith "Gitea returned a User with no login name!" | Some name -> name let! ct = Async.CancellationToken let! repos = List.getPaginated (fun page count -> client.UserListRepos (loginName, page, count, ct) |> Async.AwaitTask ) let! pushMirrorResults = repos |> Seq.map (fun r -> async { let repoName = match r.Name with | None -> failwith "Gitea returned a Repo with no name!" | Some name -> name let! ct = Async.CancellationToken let! mirrors = List.getPaginated (fun page count -> Async.AwaitTask ( client.RepoListPushMirrors (loginName, repoName, page, count, ct) ) ) return RepoName repoName, mirrors } ) |> Async.Parallel return User loginName, Map.ofArray pushMirrorResults } ) |> Async.Parallel return results |> Map.ofArray } let refreshAuth (logger : ILogger) (client : GiteaClient.IGiteaClient) (githubToken : string) (instructions : Map>) : Async = instructions |> Map.toSeq |> Seq.collect (fun (User user, repos) -> Map.toSeq repos |> Seq.map (fun (RepoName repoName, mirrors) -> mirrors |> Seq.map (fun mirror -> async { let remoteAddress = match mirror.RemoteAddress with | None -> failwith $"Gitea returned a mirror with no remote address, for repo %s{repoName}!" | Some remoteAddress -> remoteAddress let remoteName = match mirror.RemoteName with | None -> failwith $"Gitea returned a mirror with no remote name, for repo %s{repoName}!" | Some remoteAddress -> remoteAddress logger.LogInformation ( "Refreshing push mirror on {User}:{Repo} to {PushMirrorRemote}", user, repoName, remoteAddress ) let option = { createPushMirrorOption (Uri remoteAddress) githubToken with Interval = mirror.Interval SyncOnCommit = mirror.SyncOnCommit } let! ct = Async.CancellationToken let! newMirror = Async.AwaitTask (client.RepoAddPushMirror (user, repoName, option, ct)) let! deleteOldMirror = Async.AwaitTask (client.RepoDeletePushMirror (user, repoName, remoteName, ct)) return () } ) // Gitea will attempt to lock the repo config file for every push mirror, so these have to happen // serially, on pain of 500 Internal Server Error :facepalm: |> Async.Sequential |> Async.map (Array.iter id) ) ) |> Async.Parallel |> Async.map (Array.iter id)