path: root/src/SomhairlesDream.Modeling/Pipeline.fs

namespace SomhairlesDream.Modeling

open System
open System.IO
open System.Security.Cryptography
open System.Text
open System.Text.Json
open System.Text.Json.Nodes
open SomhairlesDream.Shared

[<CLIMutable>]
type BridgeRequest =
    { Step: DesignStep
      GlbPath: string
      RenderPath: string option
      ResultPath: string
      LogPath: string }

[<CLIMutable>]
type BridgeResult =
    { BlenderVersion: string
      ExportedAt: DateTimeOffset
      ObjectIds: string array
      VerifiedObjectIds: string array
      GlbBytes: int64
      RenderPath: string option
      RenderedAt: DateTimeOffset option }

type IArtifactBridge =
    abstract Export: request: BridgeRequest * heartbeat: (unit -> unit) -> Result<BridgeResult, string>

[<CLIMutable>]
type PipelineOptions =
    { ArtifactRoot: string
      Ids: RunIds
      Steps: DesignStep array
      Render: bool
      Bridge: IArtifactBridge
      Clock: unit -> DateTimeOffset
      OnEvent: RunEvent -> unit }

module private ArtifactFiles =
    let runDirectory (root: string) (ids: RunIds) = Path.Combine(root, ids.ProjectId, ids.RunId)

    let toSystemPath (relativePath: string) =
        relativePath.Replace('/', Path.DirectorySeparatorChar)

    let sha256 path =
        use stream = File.OpenRead(path)
        use sha = SHA256.Create()
        sha.ComputeHash(stream) |> Convert.ToHexString |> fun value -> value.ToLowerInvariant()

    let byteCount path = FileInfo(path).Length

module private ManifestJson =
    let private options () =
        let value = JsonSerializerOptions()
        value.WriteIndented <- true
        value

    let private stringArray (values: string array) =
        let result = JsonArray()

        for value in values do
            result.Add(JsonValue.Create(value))

        result :> JsonNode

    let private change (value: ArtifactChange) =
        let json = JsonObject()
        json["objectId"] <- JsonValue.Create(value.ObjectId)
        json["kind"] <- JsonValue.Create(value.Kind)
        json["summary"] <- JsonValue.Create(value.Summary)
        json :> JsonNode

    let private changes (values: ArtifactChange array) =
        let result = JsonArray()

        for value in values do
            result.Add(change value)

        result :> JsonNode

    let private render (value: RenderArtifact) =
        let json = JsonObject()
        json["artifactPath"] <- JsonValue.Create(value.ArtifactPath)
        json["sha256"] <- JsonValue.Create(value.Sha256)
        json["bytes"] <- JsonValue.Create(value.Bytes)
        json["exportedAt"] <- JsonValue.Create(value.ExportedAt)
        json :> JsonNode

    let private step (value: StepArtifact) =
        let json = JsonObject()
        json["stepId"] <- JsonValue.Create(value.StepId)
        json["stepIndex"] <- JsonValue.Create(value.StepIndex)
        json["artifactPath"] <- JsonValue.Create(value.ArtifactPath)
        json["logPath"] <- JsonValue.Create(value.LogPath)
        json["sha256"] <- JsonValue.Create(value.Sha256)
        json["bytes"] <- JsonValue.Create(value.Bytes)
        json["exportedAt"] <- JsonValue.Create(value.ExportedAt)
        json["objectIds"] <- stringArray value.ObjectIds
        json["verifiedObjectIds"] <- stringArray value.VerifiedObjectIds
        json["changes"] <- changes value.Changes

        match value.Render with
        | Some renderValue -> json["render"] <- render renderValue
        | None -> ()

        json :> JsonNode

    let serialize (manifest: ArtifactManifest) =
        let json = JsonObject()
        let steps = JsonArray()

        for value in manifest.Steps do
            steps.Add(step value)

        json["schemaVersion"] <- JsonValue.Create(manifest.SchemaVersion)
        json["projectId"] <- JsonValue.Create(manifest.ProjectId)
        json["runId"] <- JsonValue.Create(manifest.RunId)
        json["baseId"] <- JsonValue.Create(manifest.BaseId)
        json["targetId"] <- JsonValue.Create(manifest.TargetId)
        json["status"] <- JsonValue.Create(manifest.Status)
        json["startedAt"] <- JsonValue.Create(manifest.StartedAt)
        json["completedAt"] <- JsonValue.Create(manifest.CompletedAt)
        json["blenderVersion"] <- JsonValue.Create(manifest.BlenderVersion)
        json["steps"] <- steps
        json.ToJsonString(options())

module Pipeline =
    let private validateIds (ids: RunIds) =
        [| ids.ProjectId; ids.RunId; ids.BaseId; ids.TargetId |]
        |> Array.tryFind (Ids.validateResourceId >> Result.isError)
        |> function
            | Some invalid -> Error $"invalid resource id: {invalid}"
            | None -> Ok ()

    let private appendEvent (log: StreamWriter) (onEvent: RunEvent -> unit) event =
        log.WriteLine(RunEvent.toJson event)
        log.Flush()
        log.BaseStream.Flush()
        onEvent event

    let private writeManifest path manifest =
        let temporaryPath = path + ".tmp"
        let bytes = Encoding.UTF8.GetBytes(ManifestJson.serialize manifest)

        use stream = new FileStream(temporaryPath, FileMode.CreateNew, FileAccess.Write, FileShare.None, 4096, FileOptions.WriteThrough)
        stream.Write(bytes, 0, bytes.Length)
        stream.Flush(true)
        File.Move(temporaryPath, path)

    let private verifyBridgeResult (step: DesignStep) (request: BridgeRequest) (result: BridgeResult) =
        if not (File.Exists(request.GlbPath)) || ArtifactFiles.byteCount request.GlbPath = 0L then
            Error $"bridge did not produce a non-empty GLB for {step.StepId}"
        elif result.GlbBytes <> ArtifactFiles.byteCount request.GlbPath then
            Error $"bridge GLB byte count did not match for {step.StepId}"
        elif result.ExportedAt.Offset <> TimeSpan.Zero then
            Error $"bridge export timestamp was not UTC for {step.StepId}"
        elif result.RenderedAt |> Option.exists (fun value -> value.Offset <> TimeSpan.Zero) then
            Error $"bridge render timestamp was not UTC for {step.StepId}"
        elif request.RenderPath.IsSome <> result.RenderPath.IsSome then
            Error $"bridge render result did not match the request for {step.StepId}"
        elif request.RenderPath.IsSome && request.RenderPath <> result.RenderPath then
            Error $"bridge render path did not match the request for {step.StepId}"
        elif result.ObjectIds <> step.ObjectIds || result.VerifiedObjectIds <> step.ObjectIds then
            Error $"object ids did not match expected values for {step.StepId}"
        elif result.ObjectIds |> Array.exists (Ids.validateObjectId >> Result.isError) then
            Error $"bridge returned an invalid object id for {step.StepId}"
        else
            Ok ()

    let private renderArtifact runDirectory (step: DesignStep) path renderedAt =
        if not (File.Exists(path)) || ArtifactFiles.byteCount path = 0L then
            Error $"bridge did not produce a non-empty render for {step.StepId}"
        else
            let relativePath = $"steps/{step.StepId}.png"
            let destination = Path.Combine(runDirectory, ArtifactFiles.toSystemPath relativePath)
            File.Move(path, destination)

            Ok
                { ArtifactPath = relativePath
                  Sha256 = ArtifactFiles.sha256 destination
                  Bytes = ArtifactFiles.byteCount destination
                  ExportedAt = renderedAt }

    let run (options: PipelineOptions) =
        match validateIds options.Ids with
        | Error message -> Error message
        | Ok () ->
            let runDirectory = ArtifactFiles.runDirectory options.ArtifactRoot options.Ids

            if Directory.Exists(runDirectory) then
                Error "run directory already exists"
            else
                let stepsDirectory = Path.Combine(runDirectory, "steps")
                let logsDirectory = Path.Combine(runDirectory, "logs")
                let stagingDirectory = Path.Combine(runDirectory, ".staging")
                let eventsPath = Path.Combine(runDirectory, "events.ndjson")
                let manifestPath = Path.Combine(runDirectory, "manifest.json")
                let startedAt = options.Clock()
                let mutable currentStep: string option = None
                let mutable eventLog: StreamWriter option = None
                let mutable blenderVersion: string option = None

                try
                    Directory.CreateDirectory(runDirectory) |> ignore
                    Directory.CreateDirectory(stepsDirectory) |> ignore
                    Directory.CreateDirectory(logsDirectory) |> ignore
                    Directory.CreateDirectory(stagingDirectory) |> ignore

                    use log = new StreamWriter(File.Open(eventsPath, FileMode.CreateNew, FileAccess.Write, FileShare.Read), UTF8Encoding(false))
                    eventLog <- Some log

                    let emit event = appendEvent log options.OnEvent event
                    let ids = options.Ids

                    let steps = options.Steps

                    emit (RunEvent.Start { Ids = ids; At = startedAt; TotalSteps = steps.Length })

                    let artifacts =
                         [| for step in steps do
                               currentStep <- Some step.StepId
                               emit (RunEvent.Heartbeat { Ids = ids; At = options.Clock(); Message = $"starting {step.StepId}" })

                               let glbStagingPath = Path.GetFullPath(Path.Combine(stagingDirectory, $"{step.StepId}.glb"))
                               let renderStagingPath = Path.GetFullPath(Path.Combine(stagingDirectory, $"{step.StepId}.png"))
                               let resultStagingPath = Path.GetFullPath(Path.Combine(stagingDirectory, $"{step.StepId}.result.json"))
                               let logPath = Path.GetFullPath(Path.Combine(logsDirectory, $"{step.StepId}.log"))
                               let request =
                                   { Step = step
                                     GlbPath = glbStagingPath
                                     RenderPath = if options.Render then Some renderStagingPath else None
                                     ResultPath = resultStagingPath
                                     LogPath = logPath }

                               let bridgeResult =
                                   match options.Bridge.Export(request, fun () -> emit (RunEvent.Heartbeat { Ids = ids; At = options.Clock(); Message = $"heartbeat {step.StepId}" })) with
                                   | Ok value -> value
                                   | Error message -> failwith message

                               blenderVersion <- Some bridgeResult.BlenderVersion

                               match verifyBridgeResult step request bridgeResult with
                               | Ok () -> ()
                               | Error message -> failwith message

                               let relativePath = $"steps/{step.StepId}.glb"
                               let destination = Path.Combine(runDirectory, ArtifactFiles.toSystemPath relativePath)
                               File.Move(glbStagingPath, destination)

                               let render =
                                   if options.Render then
                                       let renderedAt = bridgeResult.RenderedAt |> Option.defaultValue bridgeResult.ExportedAt

                                       match renderArtifact runDirectory step renderStagingPath renderedAt with
                                       | Ok value -> Some value
                                       | Error message -> failwith message
                                   else
                                       None

                               let artifact =
                                   { StepId = step.StepId
                                     StepIndex = step.Index
                                     ArtifactPath = relativePath
                                     LogPath = $"logs/{step.StepId}.log"
                                     Sha256 = ArtifactFiles.sha256 destination
                                     Bytes = ArtifactFiles.byteCount destination
                                     ExportedAt = bridgeResult.ExportedAt
                                     ObjectIds = step.ObjectIds
                                     VerifiedObjectIds = bridgeResult.VerifiedObjectIds
                                     Changes = step.Changes
                                     Render = render }

                               let checkpoint =
                                   { Ids = ids
                                     At = options.Clock()
                                     StepId = step.StepId
                                     StepIndex = step.Index
                                     TotalSteps = steps.Length
                                     Message = "artifact verified"
                                     ArtifactPath = relativePath }

                               emit (RunEvent.Checkpoint checkpoint)
                               yield artifact |]

                    let completedAt = options.Clock()

                    let manifest =
                        { SchemaVersion = 1
                          ProjectId = ids.ProjectId
                          RunId = ids.RunId
                          BaseId = ids.BaseId
                          TargetId = ids.TargetId
                          Status = "complete"
                          StartedAt = startedAt
                          CompletedAt = completedAt
                          BlenderVersion = blenderVersion |> Option.defaultValue "unknown"
                          Steps = artifacts }

                    writeManifest manifestPath manifest
                    emit (RunEvent.Complete { Ids = ids; At = completedAt; ManifestPath = "manifest.json" })
                    currentStep <- None
                    if Directory.Exists(stagingDirectory) then
                        Directory.Delete(stagingDirectory, true)
                    Ok manifest
                with ex ->
                    match eventLog with
                    | Some log ->
                        try
                            appendEvent log options.OnEvent (RunEvent.Fail { Ids = options.Ids; At = options.Clock(); StepId = currentStep; Message = ex.Message })
                        with _ -> ()
                    | None -> ()

                    if Directory.Exists(stagingDirectory) then
                        Directory.Delete(stagingDirectory, true)

                    Error ex.Message

module ArtifactVerifier =
    let private stringProperty (value: JsonElement) (name: string) =
        let result = value.GetProperty(name).GetString()

        if isNull result then
            failwith $"manifest property '{name}' is null"
        else
            result

    let private parseRender (value: JsonElement) =
        let mutable renderValue = Unchecked.defaultof<JsonElement>

        if value.TryGetProperty("render", &renderValue) then
            Some
                { ArtifactPath = stringProperty renderValue "artifactPath"
                  Sha256 = stringProperty renderValue "sha256"
                  Bytes = renderValue.GetProperty("bytes").GetInt64()
                  ExportedAt = renderValue.GetProperty("exportedAt").GetDateTimeOffset() }
        else
            None

    let private parseStep (value: JsonElement) : StepArtifact =
        { StepId = stringProperty value "stepId"
          StepIndex = value.GetProperty("stepIndex").GetInt32()
          ArtifactPath = stringProperty value "artifactPath"
          LogPath = stringProperty value "logPath"
          Sha256 = stringProperty value "sha256"
          Bytes = value.GetProperty("bytes").GetInt64()
          ExportedAt = value.GetProperty("exportedAt").GetDateTimeOffset()
          ObjectIds = value.GetProperty("objectIds").EnumerateArray() |> Seq.map (fun item -> item.GetString()) |> Seq.toArray
          VerifiedObjectIds = value.GetProperty("verifiedObjectIds").EnumerateArray() |> Seq.map (fun item -> item.GetString()) |> Seq.toArray
          Changes =
              value.GetProperty("changes").EnumerateArray()
              |> Seq.map (fun item ->
                  { ObjectId = stringProperty item "objectId"
                    Kind = stringProperty item "kind"
                    Summary = stringProperty item "summary" })
              |> Seq.toArray
          Render = parseRender value }

    let private parseManifest (value: JsonElement) : ArtifactManifest =
        { SchemaVersion = value.GetProperty("schemaVersion").GetInt32()
          ProjectId = stringProperty value "projectId"
          RunId = stringProperty value "runId"
          BaseId = stringProperty value "baseId"
          TargetId = stringProperty value "targetId"
          Status = stringProperty value "status"
          StartedAt = value.GetProperty("startedAt").GetDateTimeOffset()
          CompletedAt = value.GetProperty("completedAt").GetDateTimeOffset()
          BlenderVersion = stringProperty value "blenderVersion"
          Steps = value.GetProperty("steps").EnumerateArray() |> Seq.map parseStep |> Seq.toArray }

    let private safePath runDirectory relativePath =
        if String.IsNullOrWhiteSpace(relativePath) || Path.IsPathRooted(relativePath) then
            Error "artifact path must be relative"
        else
            let normalized = relativePath.Replace('\\', '/')
            let segments = normalized.Split('/', StringSplitOptions.RemoveEmptyEntries)

            if segments |> Array.exists (fun segment -> segment = ".." || segment = ".") then
                Error "artifact path contains traversal"
            else
                let fullPath = Path.GetFullPath(Path.Combine(runDirectory, ArtifactFiles.toSystemPath normalized))
                let prefix = Path.GetFullPath(runDirectory).TrimEnd(Path.DirectorySeparatorChar) + string Path.DirectorySeparatorChar

                if fullPath.StartsWith(prefix, StringComparison.Ordinal) then
                    Ok fullPath
                else
                    Error "artifact path escapes run directory"

    let private verifyFile runDirectory expectedPath expectedHash expectedBytes =
        match safePath runDirectory expectedPath with
        | Error message -> Error message
        | Ok path when not (File.Exists(path)) -> Error $"artifact is missing: {expectedPath}"
        | Ok path when FileInfo(path).Length <> expectedBytes -> Error $"artifact byte count mismatch: {expectedPath}"
        | Ok path when ArtifactFiles.sha256 path <> expectedHash -> Error $"artifact hash mismatch: {expectedPath}"
        | Ok _ -> Ok ()

    let private verifyLogFile runDirectory expectedPath =
        match safePath runDirectory expectedPath with
        | Error message -> Error message
        | Ok path when not (File.Exists(path)) -> Error $"log is missing: {expectedPath}"
        | Ok path when FileInfo(path).Length = 0L -> Error $"log is empty: {expectedPath}"
        | Ok _ -> Ok ()

    let verify manifestPath =
        try
            if not (File.Exists(manifestPath)) then
                Error "manifest is missing"
            elif Path.GetFileName(manifestPath) <> "manifest.json" then
                Error "manifest path must be manifest.json"
            else
                use document = JsonDocument.Parse(File.ReadAllText(manifestPath))
                let manifest = parseManifest document.RootElement
                let runDirectory = Path.GetDirectoryName(Path.GetFullPath(manifestPath))
                let projectDirectory = Directory.GetParent(runDirectory).Name
                let runDirectoryName = DirectoryInfo(runDirectory).Name

                if manifest.SchemaVersion <> 1 then
                    Error "unsupported manifest schema"
                elif manifest.Status <> "complete" then
                    Error "manifest is not complete"
                elif manifest.ProjectId <> projectDirectory || manifest.RunId <> runDirectoryName then
                    Error "manifest identity does not match its directory"
                elif Ids.validateResourceId manifest.ProjectId |> Result.isError
                     || Ids.validateResourceId manifest.RunId |> Result.isError
                     || Ids.validateResourceId manifest.BaseId |> Result.isError
                     || Ids.validateResourceId manifest.TargetId |> Result.isError then
                    Error "manifest contains an invalid resource id"
                elif manifest.Steps.Length <> (Design.forProject manifest.ProjectId).Length then
                    Error "manifest step count does not match design"
                else
                    let mutable failure: string option = None

                    for expected, actual in Array.zip (Design.forProject manifest.ProjectId) manifest.Steps do
                        if failure.IsNone && actual.StepId <> expected.StepId then
                            failure <- Some $"manifest step id mismatch: {expected.StepId}"
                        elif failure.IsNone && actual.StepIndex <> expected.Index then
                            failure <- Some $"manifest step index mismatch: {expected.StepId}"
                        elif failure.IsNone && actual.ObjectIds <> expected.ObjectIds then
                            failure <- Some $"manifest source object ids mismatch: {expected.StepId}"
                        elif failure.IsNone && actual.VerifiedObjectIds <> expected.ObjectIds then
                            failure <- Some $"manifest verified object ids mismatch: {expected.StepId}"
                        elif failure.IsNone && actual.Changes <> expected.Changes then
                            failure <- Some $"manifest changes mismatch: {expected.StepId}"
                        elif failure.IsNone then
                            let expectedPath = $"steps/{expected.StepId}.glb"
                            let expectedLogPath = $"logs/{expected.StepId}.log"

                            if actual.ArtifactPath <> expectedPath then
                                failure <- Some $"manifest artifact path mismatch: {expected.StepId}"
                            elif actual.LogPath <> expectedLogPath then
                                failure <- Some $"manifest log path mismatch: {expected.StepId}"
                            else
                                match verifyLogFile runDirectory actual.LogPath with
                                | Error message -> failure <- Some message
                                | Ok () ->
                                    match verifyFile runDirectory actual.ArtifactPath actual.Sha256 actual.Bytes with
                                    | Error message -> failure <- Some message
                                    | Ok () ->
                                        match actual.Render with
                                        | Some render ->
                                            match verifyFile runDirectory render.ArtifactPath render.Sha256 render.Bytes with
                                            | Error message -> failure <- Some message
                                            | Ok () -> ()
                                        | None -> ()

                    match failure with
                    | Some message -> Error message
                    | None -> Ok manifest
        with ex ->
            Error $"invalid manifest: {ex.Message}"