From 7b29dbff7e43e87741476f47df17ad1582b16546 Mon Sep 17 00:00:00 2001 From: "Somhairle H. Marisol" Date: Mon, 21 Sep 2026 00:58:15 +0800 Subject: feat(pipeline): add runnable artifact pipeline increment [Change Nature] - This commit adds the first runnable increment of the F# artifact pipeline: CLI, server, frontend bundle, stage fixture, and tests. It is feature work, not a bug fix. [New Capability] - CLI `run` executes the three-step Blender fixture through the process bridge and writes GLBs, step logs, events, and a manifest; `verify` validates a manifest without Blender. - Server exposes run start, run-scoped SSE, artifact manifest/file routes, and serves the Fable frontend from its build output. - Frontend starts runs, follows run-scoped SSE progress, and links the artifact manifest on completion. [Implementation] - Shared layer holds domain, run state, replay, and artifact contracts; Modeling holds the pipeline, 120s bridge timeout, and result-file protocol; stage/blender/fixture.py owns geometry in Python (bpy owns geometry, F# owns orchestration). - Fable bundle is regenerated into public/ and copied by the server project; solution includes all projects with warnings-as-errors. - README documents build, Fable, server, interpreter/env, fixture limitations, and current verification status. [Impact] - Verified: 40/40 solution tests pass; Release build 0 warnings/errors; real CLI run with bpy 5.0.1 produced 3 GLBs, 3 logs, and a verify-clean manifest; isolated-port server smoke flow succeeded. - Not yet verified: browser end-to-end behavior and production fidelity. Artifacts and caches are gitignored. --- src/SomhairlesDream.Cli/Arguments.fs | 91 ++++ src/SomhairlesDream.Cli/Program.fs | 51 +++ src/SomhairlesDream.Cli/SomhairlesDream.Cli.fsproj | 16 + src/SomhairlesDream.Frontend/App.fs | 338 +++++++++++++++ src/SomhairlesDream.Frontend/Bindings.fs | 109 +++++ .../SomhairlesDream.Frontend.fsproj | 18 + src/SomhairlesDream.Modeling/BlenderBridge.fs | 204 +++++++++ src/SomhairlesDream.Modeling/Definitions.fs | 31 ++ src/SomhairlesDream.Modeling/Pipeline.fs | 469 +++++++++++++++++++++ src/SomhairlesDream.Modeling/Placeholder.fs | 4 + .../SomhairlesDream.Modeling.fsproj | 15 + src/SomhairlesDream.Server/ArtifactRunApi.fs | 161 +++++++ .../ArtifactRunCoordinator.fs | 141 +++++++ src/SomhairlesDream.Server/Program.fs | 97 +++++ .../SomhairlesDream.Server.fsproj | 21 + src/SomhairlesDream.Server/Store.fs | 259 ++++++++++++ src/SomhairlesDream.Shared/Artifact.fs | 218 ++++++++++ src/SomhairlesDream.Shared/Domain.fs | 102 +++++ src/SomhairlesDream.Shared/Replay.fs | 107 +++++ .../SomhairlesDream.Shared.fsproj | 12 + 20 files changed, 2464 insertions(+) create mode 100644 src/SomhairlesDream.Cli/Arguments.fs create mode 100644 src/SomhairlesDream.Cli/Program.fs create mode 100644 src/SomhairlesDream.Cli/SomhairlesDream.Cli.fsproj create mode 100644 src/SomhairlesDream.Frontend/App.fs create mode 100644 src/SomhairlesDream.Frontend/Bindings.fs create mode 100644 src/SomhairlesDream.Frontend/SomhairlesDream.Frontend.fsproj create mode 100644 src/SomhairlesDream.Modeling/BlenderBridge.fs create mode 100644 src/SomhairlesDream.Modeling/Definitions.fs create mode 100644 src/SomhairlesDream.Modeling/Pipeline.fs create mode 100644 src/SomhairlesDream.Modeling/Placeholder.fs create mode 100644 src/SomhairlesDream.Modeling/SomhairlesDream.Modeling.fsproj create mode 100644 src/SomhairlesDream.Server/ArtifactRunApi.fs create mode 100644 src/SomhairlesDream.Server/ArtifactRunCoordinator.fs create mode 100644 src/SomhairlesDream.Server/Program.fs create mode 100644 src/SomhairlesDream.Server/SomhairlesDream.Server.fsproj create mode 100644 src/SomhairlesDream.Server/Store.fs create mode 100644 src/SomhairlesDream.Shared/Artifact.fs create mode 100644 src/SomhairlesDream.Shared/Domain.fs create mode 100644 src/SomhairlesDream.Shared/Replay.fs create mode 100644 src/SomhairlesDream.Shared/SomhairlesDream.Shared.fsproj (limited to 'src') diff --git a/src/SomhairlesDream.Cli/Arguments.fs b/src/SomhairlesDream.Cli/Arguments.fs new file mode 100644 index 0000000..2de96be --- /dev/null +++ b/src/SomhairlesDream.Cli/Arguments.fs @@ -0,0 +1,91 @@ +namespace SomhairlesDream.Cli + +open System +open SomhairlesDream.Shared + +[] +type RunOptions = + { Ids: RunIds + OutputRoot: string + StageRoot: string + Python: string + Render: bool } + +type Command = + | Run of RunOptions + | Verify of string + | Help + +module Arguments = + let usage = + "usage: dotnet run --project src/SomhairlesDream.Cli -- run [options]\n" + + " dotnet run --project src/SomhairlesDream.Cli -- verify " + + let private defaultPython () = + let configured = Environment.GetEnvironmentVariable("SOMHAIRLES_BPYTHON") + if String.IsNullOrWhiteSpace(configured) then "python3" else configured + + let private defaults () = + { Ids = + { ProjectId = "heritage-001" + RunId = "run-001" + BaseId = "base-000" + TargetId = "target-003" } + OutputRoot = ".artifacts" + StageRoot = "stage" + Python = defaultPython () + Render = false } + + let private requiredValue (args: string array) (index: int) (optionName: string) = + if index + 1 >= args.Length || String.IsNullOrWhiteSpace(args[index + 1]) then + Error $"{optionName} requires a value" + else + Ok args[index + 1] + + let private setValue optionName value (options: RunOptions) = + match optionName with + | "--project-id" -> Ok { options with Ids = { options.Ids with ProjectId = value } } + | "--run-id" -> Ok { options with Ids = { options.Ids with RunId = value } } + | "--base-id" -> Ok { options with Ids = { options.Ids with BaseId = value } } + | "--target-id" -> Ok { options with Ids = { options.Ids with TargetId = value } } + | "--output-root" -> Ok { options with OutputRoot = value } + | "--stage-root" -> Ok { options with StageRoot = value } + | "--python" -> Ok { options with Python = value } + | _ -> Error $"unknown option: {optionName}" + + let private validateRunOptions (options: RunOptions) = + [| options.Ids.ProjectId; options.Ids.RunId; options.Ids.BaseId; options.Ids.TargetId |] + |> Array.tryFind (Ids.validateResourceId >> Result.isError) + |> function + | Some value -> Error $"invalid resource id: {value}" + | None -> Ok(Run options) + + let private parseRun (args: string array) = + let rec loop (index: int) (options: RunOptions) = + if index >= args.Length then + validateRunOptions options + else + match args[index] with + | "--render" -> loop (index + 1) { options with Render = true } + | "--help" -> Ok Help + | optionName -> + match requiredValue args index optionName with + | Error message -> Error message + | Ok value -> + match setValue optionName value options with + | Error message -> Error message + | Ok updated -> loop (index + 2) updated + + loop 0 (defaults ()) + + let parse (args: string array) = + match args with + | [||] + | [| "--help" |] + | [| "help" |] -> Ok Help + | [| "verify" |] -> Error "verify requires a manifest path" + | [| "verify"; path |] when not (String.IsNullOrWhiteSpace(path)) -> Ok(Verify path) + | [| "verify"; _ |] -> Error "verify requires a manifest path" + | values when values.Length > 2 && values[0] = "verify" -> Error "verify accepts exactly one manifest path" + | values when values.Length > 0 && values[0] = "run" -> parseRun (values |> Array.skip 1) + | _ -> Error usage diff --git a/src/SomhairlesDream.Cli/Program.fs b/src/SomhairlesDream.Cli/Program.fs new file mode 100644 index 0000000..0d9ed1c --- /dev/null +++ b/src/SomhairlesDream.Cli/Program.fs @@ -0,0 +1,51 @@ +namespace SomhairlesDream.Cli + +open System +open System.IO +open SomhairlesDream.Modeling + +module Program = + let private bridgeFailure (message: string) = + message.StartsWith("blender bridge:", StringComparison.OrdinalIgnoreCase) + + let private run options = + let bridge = BlenderProcessBridge(options.Python, options.StageRoot) :> IArtifactBridge + + let pipelineOptions : PipelineOptions = + { ArtifactRoot = options.OutputRoot + Ids = options.Ids + Render = options.Render + Bridge = bridge + Clock = fun () -> DateTimeOffset.UtcNow + OnEvent = ignore } + + match Pipeline.run pipelineOptions with + | Ok _ -> + let manifestPath = Path.Combine(options.OutputRoot, options.Ids.ProjectId, options.Ids.RunId, "manifest.json") + printfn "%s" (Path.GetFullPath(manifestPath)) + 0 + | Error message -> + eprintfn "%s" message + if bridgeFailure message then 3 else 4 + + let private verify path = + match ArtifactVerifier.verify path with + | Ok _ -> + printfn "%s" (Path.GetFullPath(path)) + 0 + | Error message -> + eprintfn "%s" message + 4 + + [] + let main argv = + match Arguments.parse argv with + | Ok Help -> + printfn "%s" Arguments.usage + 0 + | Ok(Run options) -> run options + | Ok(Verify path) -> verify path + | Error message -> + eprintfn "%s" message + eprintfn "%s" Arguments.usage + 2 diff --git a/src/SomhairlesDream.Cli/SomhairlesDream.Cli.fsproj b/src/SomhairlesDream.Cli/SomhairlesDream.Cli.fsproj new file mode 100644 index 0000000..6c72658 --- /dev/null +++ b/src/SomhairlesDream.Cli/SomhairlesDream.Cli.fsproj @@ -0,0 +1,16 @@ + + + net8.0 + SomhairlesDream.Cli + SomhairlesDream.Cli + Exe + + + + + + + + + + diff --git a/src/SomhairlesDream.Frontend/App.fs b/src/SomhairlesDream.Frontend/App.fs new file mode 100644 index 0000000..835dfa9 --- /dev/null +++ b/src/SomhairlesDream.Frontend/App.fs @@ -0,0 +1,338 @@ +module SomhairlesDream.Frontend.App + +open System +open Browser.Dom +open Browser.Types +open Fable.Core +open Fable.Core.JsInterop +open SomhairlesDream.Frontend.Bindings +open SomhairlesDream.Shared + +[] +type SnapshotPayload = + abstract projectId: string with get + abstract runId: string with get + abstract status: string with get + abstract currentStepIndex: int with get + abstract totalSteps: int with get + abstract lastHeartbeatAt: string with get + abstract updatedAt: string with get + abstract message: string with get + abstract manifestUrl: string with get + abstract error: string with get + abstract isStale: bool with get + +type RunSelection = + { ProjectId: string + RunId: string + BaseId: string + TargetId: string + Render: bool } + +type ViewState = + { Renderer: ThreeRenderer + Scene: ThreeNode + Camera: ThreeNode + Group: ThreeNode + Canvas: HTMLCanvasElement } + +let frames = Replay.frames () +let mutable viewState: ViewState option = None +let mutable selectedFrame = frames[0] +let mutable replayTimer: int option = None +let mutable replayIndex = 0 +let mutable eventSource: EventSource option = None + +let element id = document.getElementById(id) + +let setText id value = + (element id).textContent <- value + +let setWidth id value = + (element id).setAttribute("style", sprintf "width: %s" value) + +let setStatusClass (status: string) = + let host = element "status-chip" + [| "idle"; "queued"; "running"; "succeeded"; "failed"; "stale" |] + |> Array.iter (fun name -> host.classList.remove($"status-{name}")) + host.classList.add($"status-{status}") + host.setAttribute("data-status", status) + +let statusName (payload: SnapshotPayload) = + if payload.isStale then + "stale" + else + match payload.status with + | "complete" -> "succeeded" + | "idle" + | "queued" + | "running" + | "failed" as status -> status + | _ -> "unknown" + +let statusLabel (payload: SnapshotPayload) = + match payload.status, payload.isStale with + | _, true -> "心跳超时" + | "idle", _ -> "待机" + | "queued", _ -> "排队中" + | "running", _ -> "运行中" + | "complete", _ -> "已完成" + | "failed", _ -> "失败" + | _ -> "未知状态" + +let addMesh (view: ViewState) (frame: ReplayFrame) = + let geometry = createBufferGeometry () + let positions = MeshData.positionData frame.Mesh + let indices = MeshData.triangleIndices frame.Mesh + geometry.setAttribute("position", createFloat32BufferAttribute(positions, 3)) |> ignore + geometry.setIndex(createUint32BufferAttribute indices) |> ignore + geometry.computeVertexNormals() + + let color = + match frame.Version with + | 1 -> "#d7a948" + | 2 -> "#efe4c4" + | _ -> "#a7c7c0" + + let material = + createMeshStandardMaterial ( + createObj + [ "color" ==> color + "roughness" ==> 0.36 + "metalness" ==> 0.72 ] + ) + + let mesh = createMesh(geometry, material) + view.Group.add(mesh) + +let renderFrame (frame: ReplayFrame) = + selectedFrame <- frame + + match viewState with + | None -> () + | Some view -> + view.Group.clear() + addMesh view frame + view.Renderer.render(view.Scene, view.Camera) + +let resizeView (view: ViewState) = + let width = max 1.0 (float view.Canvas.clientWidth) + let height = max 1.0 (float view.Canvas.clientHeight) + view.Renderer.setSize(width, height, false) + renderFrame selectedFrame + +let initializeView () = + let canvas = document.getElementById("viewport-canvas") :?> HTMLCanvasElement + let width = max 1.0 (float canvas.clientWidth) + let height = max 1.0 (float canvas.clientHeight) + let renderer = + createRenderer ( + createObj + [ "canvas" ==> canvas + "antialias" ==> true + "alpha" ==> true ] + ) + + renderer.setPixelRatio(window.devicePixelRatio) + renderer.setSize(width, height, false) + let scene = createScene() + scene.background <- createColor("#11171a") + let camera = createPerspectiveCamera(34.0, width / height, 0.1, 100.0) + camera.position.set(6.4, 4.6, 7.2) |> ignore + camera.lookAt(0.0, 1.2, 0.0) + let group = createGroup() + scene.add(group) + scene.add(createAmbientLight("#f0e6c8", 1.9)) + let keyLight = createDirectionalLight("#f2c76b", 2.8) + keyLight.position.set(4.0, 7.0, 5.0) |> ignore + scene.add(keyLight) + + let view = + { Renderer = renderer + Scene = scene + Camera = camera + Group = group + Canvas = canvas } + + viewState <- Some view + renderFrame selectedFrame + window.addEventListener("resize", fun _ -> resizeView view) + + let rec animate (_: float) = + group.rotation.y <- group.rotation.y + 0.003 + renderer.render(scene, camera) + requestAnimationFrame animate |> ignore + + requestAnimationFrame animate |> ignore + +let fallbackView () = + setText "viewport-note" "WebGL 视图待命 · 已保留重建数据" + (element "viewport-panel").classList.add("viewport-fallback") + +let showFrameMetadata (frame: ReplayFrame) = + setText "mesh-label" frame.Label + setText "timeline-current" (sprintf "V%02d · %s" frame.Version frame.Label) + +let setManifestLink (payload: SnapshotPayload) = + let link = element "artifact-manifest-link" + + match payload.manifestUrl with + | value when String.IsNullOrWhiteSpace(value) -> + link.removeAttribute("href") + link.classList.add("is-hidden") + | value -> + link.setAttribute("href", value) + link.classList.remove("is-hidden") + +let updateState (payload: SnapshotPayload) = + let status = statusName payload + setStatusClass status + setText "status-label" (statusLabel payload) + + let message = + if payload.status = "failed" && not (String.IsNullOrWhiteSpace(payload.error)) then + payload.error + else + payload.message + + setText "run-message" message + setText "project-id" payload.projectId + setText "run-id" payload.runId + + let currentVersion = max 0 (payload.currentStepIndex + 1) + setText "target-version" (sprintf "V%02d" payload.totalSteps) + setText "current-version" (sprintf "V%02d" currentVersion) + setText "version-readout" (sprintf "%02d / %02d" currentVersion payload.totalSteps) + setText "updated-at" payload.updatedAt + + let progress = + if payload.totalSteps <= 0 then 0.0 + else min 100.0 (float currentVersion / float payload.totalSteps * 100.0) + + setWidth "progress-fill" (sprintf "%.0f%%" progress) + + let frame = + frames + |> Array.tryFind (fun candidate -> candidate.Version = currentVersion) + |> Option.defaultValue selectedFrame + + setManifestLink payload + showFrameMetadata frame + renderFrame frame + +let updateStreamState message = + setText "stream-state" message + +let toggleReplay () = + match replayTimer with + | Some handle -> + clearInterval handle + replayTimer <- None + setText "replay-button" "重建演示" + setText "replay-state" "演示已暂停" + | None -> + replayIndex <- 0 + setText "replay-button" "暂停重建" + setText "replay-state" "重建中 · 几何逐帧替换" + + let tick () = + if replayIndex >= frames.Length then + match replayTimer with + | Some handle -> clearInterval handle + | None -> () + + replayTimer <- None + setText "replay-button" "重建演示" + setText "replay-state" "重建完成 · 几何已更新" + else + let frame = frames[replayIndex] + showFrameMetadata frame + renderFrame frame + setText "replay-state" (sprintf "重建中 · V%02d %s" frame.Version frame.Label) + replayIndex <- replayIndex + 1 + + tick () + replayTimer <- Some(setInterval tick 900) + +let disconnectFromServer () = + match eventSource with + | Some source -> + source.close() + eventSource <- None + | None -> () + +let connectToServer (selection: RunSelection) = + disconnectFromServer () + let projectId = JS.encodeURIComponent selection.ProjectId + let runId = JS.encodeURIComponent selection.RunId + let source = createEventSource (sprintf "/api/runs/events?projectId=%s&runId=%s" projectId runId) + eventSource <- Some source + + source.onmessage <- fun event -> + let payload = JS.JSON.parse(event.data) :?> SnapshotPayload + updateState payload + updateStreamState "实时链路 · SSE 已连接" + + source.onerror <- fun _ -> updateStreamState "实时链路 · 等待自动重连" + +let inputValue id = + (element id :?> HtmlInput).value + +let selectedRun () = + { ProjectId = inputValue "project-id-input" + RunId = inputValue "run-id-input" + BaseId = inputValue "base-id-input" + TargetId = inputValue "target-id-input" + Render = (element "run-render-input" :?> HtmlInput).``checked`` } + +let startRun (selection: RunSelection) = + let requestBody = + createObj + [ "projectId" ==> selection.ProjectId + "runId" ==> selection.RunId + "baseId" ==> selection.BaseId + "targetId" ==> selection.TargetId + "render" ==> selection.Render ] + + let requestOptions = + createObj + [ "method" ==> "POST" + "headers" ==> createObj [ "Content-Type" ==> "application/json" ] + "body" ==> JS.JSON.stringify requestBody ] + + setText "run-message" "正在启动设计运行" + updateStreamState "实时链路 · 等待服务端确认" + + async { + try + let! response = fetch ("/api/runs/start", requestOptions) |> Async.AwaitPromise + + if response.ok then + let! value = response.json() |> Async.AwaitPromise + let payload = value :?> SnapshotPayload + updateState payload + connectToServer selection + updateStreamState "实时链路 · SSE 已连接" + else + setText "run-message" (sprintf "启动失败 · HTTP %d" response.status) + updateStreamState "实时链路 · 启动失败" + with _ -> + setText "run-message" "启动失败 · 无法连接服务端" + updateStreamState "实时链路 · 连接失败" + } + |> Async.StartImmediate + +let boot () = + showFrameMetadata frames[0] + + try + initializeView () + with _ -> + fallbackView () + + (element "replay-button").addEventListener("click", fun _ -> toggleReplay ()) + (element "run-controls").addEventListener("submit", fun event -> + event.preventDefault() + startRun (selectedRun ())) + +boot () diff --git a/src/SomhairlesDream.Frontend/Bindings.fs b/src/SomhairlesDream.Frontend/Bindings.fs new file mode 100644 index 0000000..dc75d7d --- /dev/null +++ b/src/SomhairlesDream.Frontend/Bindings.fs @@ -0,0 +1,109 @@ +module SomhairlesDream.Frontend.Bindings + +open Fable.Core + +[] +type ThreeVector = + abstract set: x: float * y: float * z: float -> ThreeVector + abstract x: float with get, set + abstract y: float with get, set + abstract z: float with get, set + +[] +type ThreeNode = + abstract add: child: ThreeNode -> unit + abstract clear: unit -> unit + abstract lookAt: x: float * y: float * z: float -> unit + abstract position: ThreeVector with get + abstract rotation: ThreeVector with get + abstract background: obj with get, set + +[] +type ThreeRenderer = + abstract setPixelRatio: ratio: float -> unit + abstract setSize: width: float * height: float * updateStyle: bool -> unit + abstract render: scene: ThreeNode * camera: ThreeNode -> unit + +[] +type ThreeGeometry = + abstract setAttribute: name: string * attribute: obj -> ThreeGeometry + abstract setIndex: attribute: obj -> ThreeGeometry + abstract computeVertexNormals: unit -> unit + +[] +type ServerEvent = + abstract data: string with get + +[] +type EventSource = + abstract onerror: (obj -> unit) with get, set + abstract onmessage: (ServerEvent -> unit) with get, set + abstract close: unit -> unit + +[] +type FetchResponse = + abstract ok: bool with get + abstract status: int with get + abstract json: unit -> JS.Promise + +[] +type HtmlInput = + abstract value: string with get + abstract ``checked``: bool with get + +[] +let createScene () : ThreeNode = jsNative + +[] +let createGroup () : ThreeNode = jsNative + +[] +let createPerspectiveCamera (fieldOfView: float, aspect: float, nearPlane: float, farPlane: float) : ThreeNode = jsNative + +[] +let createRenderer (options: obj) : ThreeRenderer = jsNative + +[] +let createBufferGeometry () : ThreeGeometry = jsNative + +[] +let createFloat32BufferAttribute (values: float array, itemSize: int) : obj = jsNative + +[] +let createUint32BufferAttribute (values: int array) : obj = jsNative + +[] +let createColor (value: string) : obj = jsNative + +[] +let createBoxGeometry (width: float, height: float, depth: float) : obj = jsNative + +[] +let createMeshStandardMaterial (options: obj) : obj = jsNative + +[] +let createMesh (geometry: obj, material: obj) : ThreeNode = jsNative + +[] +let createAmbientLight (color: string, intensity: float) : ThreeNode = jsNative + +[] +let createDirectionalLight (color: string, intensity: float) : ThreeNode = jsNative + +[] +let createEventSource (url: string) : EventSource = jsNative + +[] +let fetch (url: string, options: obj) : JS.Promise = jsNative + +[] +let encodeURIComponent (value: string) : string = jsNative + +[] +let setInterval (callback: unit -> unit) (milliseconds: int) : int = jsNative + +[] +let clearInterval (handle: int) : unit = jsNative + +[] +let requestAnimationFrame (callback: float -> unit) : int = jsNative diff --git a/src/SomhairlesDream.Frontend/SomhairlesDream.Frontend.fsproj b/src/SomhairlesDream.Frontend/SomhairlesDream.Frontend.fsproj new file mode 100644 index 0000000..3ce6225 --- /dev/null +++ b/src/SomhairlesDream.Frontend/SomhairlesDream.Frontend.fsproj @@ -0,0 +1,18 @@ + + + net8.0 + false + Library + + + + + + + + + + + + + diff --git a/src/SomhairlesDream.Modeling/BlenderBridge.fs b/src/SomhairlesDream.Modeling/BlenderBridge.fs new file mode 100644 index 0000000..c0795e9 --- /dev/null +++ b/src/SomhairlesDream.Modeling/BlenderBridge.fs @@ -0,0 +1,204 @@ +namespace SomhairlesDream.Modeling + +open System +open System.Diagnostics +open System.IO +open System.Text.Json + +type BlenderProcessBridge(python: string, stageRoot: string, ?timeout: TimeSpan) = + let timeout = defaultArg timeout (TimeSpan.FromSeconds 120.) + + let bridgeError message = + if String.IsNullOrWhiteSpace(message) then + "blender bridge: process failed without diagnostics" + else + $"blender bridge: {message.Trim()}" + + let diagnostics (stderr: string) (stdout: string) = + let value = + if String.IsNullOrWhiteSpace(stderr) then stdout else stderr + + if String.IsNullOrWhiteSpace(value) then + "no process diagnostics" + elif value.Length > 2000 then + value.Substring(0, 2000) + else + value + + let strings (root: JsonElement) (name: string) = + let property = root.GetProperty(name) + + if property.ValueKind <> JsonValueKind.Array then + failwith $"'{name}' must be an array" + + let values = property.EnumerateArray() |> Seq.map (fun item -> item.GetString()) |> Seq.toArray + + if values |> Array.exists isNull then + failwith $"'{name}' contains a null value" + + values + + let utcTimestamp (root: JsonElement) (name: string) = + let value = root.GetProperty(name).GetDateTimeOffset() + + if value.Offset <> TimeSpan.Zero then + failwith $"'{name}' must be a UTC timestamp" + + value + + let parseResult (request: BridgeRequest) = + if not (File.Exists(request.ResultPath)) then + failwith $"fixture result file is missing: {request.ResultPath}" + + use document = JsonDocument.Parse(File.ReadAllText(request.ResultPath)) + let root = document.RootElement + + if not (root.GetProperty("ok").GetBoolean()) then + failwith "fixture returned ok=false" + + let renderPath = + let mutable property = Unchecked.defaultof + + if root.TryGetProperty("renderPath", &property) then + Some(property.GetString()) + else + None + + let renderedAt = + let mutable property = Unchecked.defaultof + + if root.TryGetProperty("renderedAt", &property) then + Some(utcTimestamp root "renderedAt") + else + None + + if request.RenderPath.IsSome <> renderPath.IsSome then + failwith "fixture render result did not match the request" + + if request.RenderPath.IsSome && request.RenderPath <> renderPath then + failwith "fixture returned an unexpected render path" + + { BlenderVersion = root.GetProperty("blenderVersion").GetString() + ExportedAt = utcTimestamp root "exportedAt" + ObjectIds = strings root "objectIds" + VerifiedObjectIds = strings root "verifiedObjectIds" + GlbBytes = root.GetProperty("glbBytes").GetInt64() + RenderPath = renderPath + RenderedAt = renderedAt } + + let writeProcessLog (path: string) (stdout: string) (stderr: string) = + match Path.GetDirectoryName(path) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + + let content = + String.concat + Environment.NewLine + [| "[stdout]" + stdout + "[stderr]" + stderr |] + + File.WriteAllText(path, content) + + member private _.StartInfo(request: BridgeRequest) = + let scriptPath = Path.GetFullPath(Path.Combine(stageRoot, "blender", "fixture.py")) + let info = ProcessStartInfo() + info.FileName <- python + info.UseShellExecute <- false + info.CreateNoWindow <- true + info.RedirectStandardOutput <- true + info.RedirectStandardError <- true + info.ArgumentList.Add(scriptPath) + info.ArgumentList.Add("--step-id") + info.ArgumentList.Add(request.Step.StepId) + info.ArgumentList.Add("--output") + info.ArgumentList.Add(Path.GetFullPath(request.GlbPath)) + info.ArgumentList.Add("--result-output") + info.ArgumentList.Add(Path.GetFullPath(request.ResultPath)) + + match request.RenderPath with + | Some path -> + info.ArgumentList.Add("--render-output") + info.ArgumentList.Add(Path.GetFullPath(path)) + | None -> () + + info + + interface IArtifactBridge with + member this.Export(request, heartbeat) = + try + let scriptPath = Path.GetFullPath(Path.Combine(stageRoot, "blender", "fixture.py")) + + if not (File.Exists(scriptPath)) then + Error(bridgeError $"fixture is missing: {scriptPath}") + else + match Path.GetDirectoryName(request.GlbPath) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + + match request.RenderPath with + | Some path -> + match Path.GetDirectoryName(path) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + | None -> () + + match Path.GetDirectoryName(request.ResultPath) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + + match Path.GetDirectoryName(request.LogPath) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + + if File.Exists(request.ResultPath) then + File.Delete(request.ResultPath) + + if File.Exists(request.LogPath) then + File.Delete(request.LogPath) + + use childProcess = new Process() + childProcess.StartInfo <- this.StartInfo(request) + + if not (childProcess.Start()) then + Error(bridgeError "process could not be started") + else + let stdoutTask = childProcess.StandardOutput.ReadToEndAsync() + let stderrTask = childProcess.StandardError.ReadToEndAsync() + let started = Stopwatch.StartNew() + let mutable timedOut = false + + while not childProcess.HasExited && not timedOut do + let remaining = timeout - started.Elapsed + + if remaining <= TimeSpan.Zero then + timedOut <- true + else + let waitMilliseconds = int (min 5000.0 remaining.TotalMilliseconds) + + if not (childProcess.WaitForExit(waitMilliseconds)) then + if childProcess.HasExited then + () + else + heartbeat () + + if timedOut && not childProcess.HasExited then + childProcess.Kill(true) + + childProcess.WaitForExit() + let stdout = stdoutTask.GetAwaiter().GetResult() + let stderr = stderrTask.GetAwaiter().GetResult() + writeProcessLog request.LogPath stdout stderr + + if timedOut then + Error(bridgeError $"process timed out after {timeout.TotalSeconds} seconds") + elif childProcess.ExitCode <> 0 then + Error(bridgeError $"process exited with code {childProcess.ExitCode}: {diagnostics stderr stdout}") + else + try + Ok(parseResult request) + with ex -> + Error(bridgeError $"invalid fixture result: {ex.Message}") + with ex -> + Error(bridgeError ex.Message) diff --git a/src/SomhairlesDream.Modeling/Definitions.fs b/src/SomhairlesDream.Modeling/Definitions.fs new file mode 100644 index 0000000..64e6bc6 --- /dev/null +++ b/src/SomhairlesDream.Modeling/Definitions.fs @@ -0,0 +1,31 @@ +namespace SomhairlesDream.Modeling + +open SomhairlesDream.Shared + +[] +type DesignStep = + { StepId: string + Index: int + ObjectIds: string array + Changes: ArtifactChange array } + +module Design = + let steps : DesignStep array = + [| { StepId = "01-foundation"; Index = 0 + ObjectIds = [| "heritage.foundation"; "heritage.deck" |] + Changes = + [| { ObjectId = "heritage.foundation"; Kind = "add"; Summary = "Add foundation slab" } + { ObjectId = "heritage.deck"; Kind = "add"; Summary = "Add raised deck" } |] } + { StepId = "02-frame"; Index = 1 + ObjectIds = + [| "heritage.foundation"; "heritage.deck"; "heritage.frame.left"; "heritage.frame.right"; "heritage.spine" |] + Changes = + [| { ObjectId = "heritage.frame.left"; Kind = "add"; Summary = "Add primary left frame" } + { ObjectId = "heritage.frame.right"; Kind = "add"; Summary = "Add primary right frame" } + { ObjectId = "heritage.spine"; Kind = "add"; Summary = "Add central spine" } |] } + { StepId = "03-cabin"; Index = 2 + ObjectIds = + [| "heritage.foundation"; "heritage.deck"; "heritage.frame.left"; "heritage.frame.right"; "heritage.spine"; "heritage.cabin"; "heritage.crossbeam" |] + Changes = + [| { ObjectId = "heritage.cabin"; Kind = "add"; Summary = "Add cabin volume" } + { ObjectId = "heritage.crossbeam"; Kind = "add"; Summary = "Add cabin crossbeam" } |] } |] diff --git a/src/SomhairlesDream.Modeling/Pipeline.fs b/src/SomhairlesDream.Modeling/Pipeline.fs new file mode 100644 index 0000000..3f1f105 --- /dev/null +++ b/src/SomhairlesDream.Modeling/Pipeline.fs @@ -0,0 +1,469 @@ +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 + +[] +type BridgeRequest = + { Step: DesignStep + GlbPath: string + RenderPath: string option + ResultPath: string + LogPath: string } + +[] +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 + +[] +type PipelineOptions = + { ArtifactRoot: string + Ids: RunIds + 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 + + emit (RunEvent.Start { Ids = ids; At = startedAt; TotalSteps = Design.steps.Length }) + + let artifacts = + [| for step in Design.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 = Design.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 + + 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.steps.Length then + Error "manifest step count does not match design" + else + let mutable failure: string option = None + + for expected, actual in Array.zip Design.steps 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}" diff --git a/src/SomhairlesDream.Modeling/Placeholder.fs b/src/SomhairlesDream.Modeling/Placeholder.fs new file mode 100644 index 0000000..b5e4368 --- /dev/null +++ b/src/SomhairlesDream.Modeling/Placeholder.fs @@ -0,0 +1,4 @@ +namespace SomhairlesDream.Modeling + +module Placeholder = + let ready = false diff --git a/src/SomhairlesDream.Modeling/SomhairlesDream.Modeling.fsproj b/src/SomhairlesDream.Modeling/SomhairlesDream.Modeling.fsproj new file mode 100644 index 0000000..cf9312e --- /dev/null +++ b/src/SomhairlesDream.Modeling/SomhairlesDream.Modeling.fsproj @@ -0,0 +1,15 @@ + + + net8.0 + SomhairlesDream.Modeling + SomhairlesDream.Modeling + + + + + + + + + + diff --git a/src/SomhairlesDream.Server/ArtifactRunApi.fs b/src/SomhairlesDream.Server/ArtifactRunApi.fs new file mode 100644 index 0000000..8d76ffc --- /dev/null +++ b/src/SomhairlesDream.Server/ArtifactRunApi.fs @@ -0,0 +1,161 @@ +namespace SomhairlesDream.Server + +open System +open System.IO +open System.Text.Json +open System.Threading.Tasks +open Microsoft.AspNetCore.Builder +open Microsoft.AspNetCore.Http +open SomhairlesDream.Shared + +[] +type RunStartRequest = + { ProjectId: string + RunId: string + BaseId: string + TargetId: string + Render: bool } + +type ArtifactRunApiOptions = + { Coordinator: ArtifactRunCoordinator + Clock: unit -> DateTimeOffset + JsonOptions: JsonSerializerOptions } + +module ArtifactRunApi = + let private json options value = Results.Json(value, options.JsonOptions) + + let private jsonWithStatus options statusCode value = + Results.Json(value, options.JsonOptions, statusCode = Nullable(statusCode)) + + let private error options statusCode message = + jsonWithStatus options statusCode {| error = message |} + + let private readStartRequest options (request: HttpRequest) = + task { + try + let! value = request.ReadFromJsonAsync(options.JsonOptions) + + if isNull (box value) then + return Error "request body must be a JSON object" + else + return Ok value + with + | :? JsonException as ex -> return Error $"invalid JSON: {ex.Message}" + } + + let private start options (context: HttpContext) : Task = + task { + let! request = readStartRequest options context.Request + + match request with + | Error message -> return error options 400 message + | Ok request -> + let ids : RunIds = + { ProjectId = request.ProjectId + RunId = request.RunId + BaseId = request.BaseId + TargetId = request.TargetId } + + match options.Coordinator.Start(ids, request.Render) with + | Ok(Accepted snapshot) -> return jsonWithStatus options 202 snapshot + | Ok(Conflict snapshot) -> return jsonWithStatus options 409 snapshot + | Error message when message = "run registry entry disappeared" -> + return error options 500 message + | Error message -> return error options 400 message + } + + let private queryValue (context: HttpContext) name = + let value = context.Request.Query[name].ToString() + + if String.IsNullOrWhiteSpace(value) then + None + else + Some value + + let private selector context = + match queryValue context "projectId", queryValue context "runId" with + | Some projectId, Some runId -> + match Ids.validateResourceId projectId, Ids.validateResourceId runId with + | Error message, _ -> Error $"invalid projectId: {message}" + | _, Error message -> Error $"invalid runId: {message}" + | Ok (), Ok () -> Ok(projectId, runId) + | None, _ -> Error "missing query parameter 'projectId'" + | _, None -> Error "missing query parameter 'runId'" + + let private manifest options (context: HttpContext) = + match selector context with + | Error message -> error options 400 message + | Ok(projectId, runId) -> + match options.Coordinator.Manifest(projectId, runId) with + | Ok value -> json options value + | Error RunNotFound -> error options 404 "run not found" + | Error(RunNotComplete snapshot) -> jsonWithStatus options 409 snapshot + | Error(InvalidManifest message) -> error options 500 message + | Error(InvalidArtifactPath message) -> error options 500 message + | Error ArtifactNotFound -> error options 500 "manifest not found" + + let private artifactContentType (path: string) = + match Path.GetExtension(path).ToLowerInvariant() with + | ".glb" -> "model/gltf-binary" + | ".json" -> "application/json" + | ".png" -> "image/png" + | ".log" -> "text/plain" + | _ -> "application/octet-stream" + + let private artifact options (context: HttpContext) = + match selector context, queryValue context "path" with + | Error message, _ -> error options 400 message + | _, None -> error options 400 "missing query parameter 'path'" + | Ok(projectId, runId), Some relativePath -> + match options.Coordinator.Artifact(projectId, runId, relativePath) with + | Ok path -> Results.File(path, artifactContentType path) + | Error RunNotFound -> error options 404 "run not found" + | Error(RunNotComplete snapshot) -> jsonWithStatus options 409 snapshot + | Error(InvalidArtifactPath message) -> error options 400 message + | Error ArtifactNotFound -> error options 404 "artifact not found" + | Error(InvalidManifest message) -> error options 500 message + + let private writeError options (context: HttpContext) statusCode message = + task { + context.Response.StatusCode <- statusCode + context.Response.ContentType <- "application/json" + let payload = JsonSerializer.Serialize({| error = message |}, options.JsonOptions) + do! context.Response.WriteAsync(payload) + } + + let private events options (context: HttpContext) : Task = + task { + match selector context with + | Error message -> do! writeError options context 400 message + | Ok(projectId, runId) -> + match options.Coordinator.Subscribe(projectId, runId) with + | None -> do! writeError options context 404 "run not found" + | Some subscription -> + use _lifetime = subscription :> IDisposable + context.Response.StatusCode <- 200 + context.Response.ContentType <- "text/event-stream" + context.Response.Headers.CacheControl <- "no-cache" + context.Response.Headers["X-Accel-Buffering"] <- "no" + + try + while not context.RequestAborted.IsCancellationRequested do + let! snapshot = subscription.Reader.ReadAsync(context.RequestAborted).AsTask() + let payload = JsonSerializer.Serialize(snapshot, options.JsonOptions) + do! context.Response.WriteAsync($"data: {payload}\n\n", context.RequestAborted) + do! context.Response.Body.FlushAsync(context.RequestAborted) + with + | :? OperationCanceledException -> () + } + + let register (app: WebApplication) options = + app.MapPost("/api/runs/start", Func>(fun context -> start options context)) + |> ignore + + app.MapGet("/api/runs/events", Func(fun context -> events options context)) + |> ignore + + app.MapGet("/api/artifacts/manifest", Func(fun context -> manifest options context)) + |> ignore + + app.MapGet("/api/artifacts/file", Func(fun context -> artifact options context)) + |> ignore diff --git a/src/SomhairlesDream.Server/ArtifactRunCoordinator.fs b/src/SomhairlesDream.Server/ArtifactRunCoordinator.fs new file mode 100644 index 0000000..78d5dee --- /dev/null +++ b/src/SomhairlesDream.Server/ArtifactRunCoordinator.fs @@ -0,0 +1,141 @@ +namespace SomhairlesDream.Server + +open System +open System.IO +open System.Threading.Tasks +open SomhairlesDream.Modeling +open SomhairlesDream.Shared + +type RunStartOutcome = + | Accepted of RunSnapshot + | Conflict of RunSnapshot + +type ArtifactLookupError = + | RunNotFound + | RunNotComplete of RunSnapshot + | InvalidArtifactPath of string + | ArtifactNotFound + | InvalidManifest of string + +type ArtifactRunCoordinator( + artifactRoot: string, + bridgeFactory: unit -> IArtifactBridge, + clock: unit -> DateTimeOffset, + staleAfter: TimeSpan +) = + let root = Path.GetFullPath(artifactRoot) + let registry = ArtifactRunRegistry(staleAfter, clock) + + let 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 runDirectory (projectId: string) (runId: string) = + Path.Combine(root, projectId, runId) + + let failIfNeeded (store: ArtifactRunStore) (ids: RunIds) message = + let snapshot = store.Snapshot() + + if snapshot.Status = "idle" || snapshot.Status = "running" then + store.Apply( + RunEvent.Fail + { Ids = ids + At = clock () + StepId = snapshot.CurrentStepId + Message = message } + ) + |> ignore + + let runPipeline (store: ArtifactRunStore) (ids: RunIds) render = + try + let options : PipelineOptions = + { ArtifactRoot = root + Ids = ids + Render = render + Bridge = bridgeFactory () + Clock = clock + OnEvent = + fun event -> + match store.Apply event with + | Ok _ -> () + | Error message -> invalidOp message } + + match Pipeline.run options with + | Ok _ -> () + | Error message -> failIfNeeded store ids message + with ex -> + failIfNeeded store ids ex.Message + + let safeArtifactPath (runDirectory: string) (relativePath: string) = + 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, normalized.Replace('/', Path.DirectorySeparatorChar))) + 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" + + member _.ArtifactRoot = root + + member _.Start(ids: RunIds, render: bool) : Result = + match validateIds ids with + | Error message -> Error message + | Ok () -> + match registry.TryCreate(ids) with + | Some store -> + Task.Run(fun () -> runPipeline store ids render) |> ignore + Ok(Accepted(store.Snapshot())) + | None -> + match registry.TryFind(ids.ProjectId, ids.RunId) with + | Some store -> Ok(Conflict(store.Observe(clock ()))) + | None -> Error "run registry entry disappeared" + + member _.TryFind(projectId: string, runId: string) = registry.TryFind(projectId, runId) + + member _.Subscribe(projectId: string, runId: string) = + registry.TryFind(projectId, runId) |> Option.map (fun store -> store.Subscribe()) + + member _.ObserveAll() = registry.ObserveAll(clock ()) + + member _.Manifest(projectId: string, runId: string) : Result = + match registry.TryFind(projectId, runId) with + | None -> Error RunNotFound + | Some store -> + let snapshot = store.Observe(clock ()) + + if snapshot.Status <> "complete" then + Error(RunNotComplete snapshot) + else + let path = Path.Combine(runDirectory projectId runId, "manifest.json") + + match ArtifactVerifier.verify path with + | Ok manifest -> Ok manifest + | Error message -> Error(InvalidManifest message) + + member _.Artifact(projectId: string, runId: string, relativePath: string) : Result = + match registry.TryFind(projectId, runId) with + | None -> Error RunNotFound + | Some store -> + let snapshot = store.Observe(clock ()) + + if snapshot.Status <> "complete" then + Error(RunNotComplete snapshot) + else + let directory = runDirectory projectId runId + + match safeArtifactPath directory relativePath with + | Error message -> Error(InvalidArtifactPath message) + | Ok path when not (File.Exists(path)) -> Error ArtifactNotFound + | Ok path -> Ok path diff --git a/src/SomhairlesDream.Server/Program.fs b/src/SomhairlesDream.Server/Program.fs new file mode 100644 index 0000000..53cfef6 --- /dev/null +++ b/src/SomhairlesDream.Server/Program.fs @@ -0,0 +1,97 @@ +open System +open System.IO +open System.Text.Json +open System.Threading +open System.Threading.Tasks +open Microsoft.AspNetCore.Builder +open Microsoft.AspNetCore.Hosting +open Microsoft.AspNetCore.Http +open Microsoft.Extensions.FileProviders +open Microsoft.Extensions.Hosting +open SomhairlesDream.Server +open SomhairlesDream.Shared + +let builder = WebApplication.CreateBuilder(Environment.GetCommandLineArgs() |> Array.skip 1) +let publicRoot = Path.Combine(AppContext.BaseDirectory, "public") +builder.Environment.WebRootPath <- publicRoot +builder.Environment.WebRootFileProvider <- new PhysicalFileProvider(publicRoot) + +let app = builder.Build() +let store = RunStore("heritage-001", "run-001", TimeSpan.FromMinutes 2.) +let jsonOptions = JsonSerializerOptions(JsonSerializerDefaults.Web) + +let environmentOrDefault name fallback = + match Environment.GetEnvironmentVariable(name) with + | value when not (String.IsNullOrWhiteSpace(value)) -> value + | _ -> fallback + +let artifactRoot = environmentOrDefault "SOMHAIRLES_ARTIFACT_ROOT" (Path.Combine(Environment.CurrentDirectory, ".artifacts")) +let stageRoot = environmentOrDefault "SOMHAIRLES_STAGE_ROOT" (Path.Combine(Environment.CurrentDirectory, "stage")) +let python = environmentOrDefault "SOMHAIRLES_BPYTHON" "python3" +let artifactClock () = DateTimeOffset.UtcNow +let coordinator = + ArtifactRunCoordinator( + artifactRoot, + (fun () -> SomhairlesDream.Modeling.BlenderProcessBridge(python, stageRoot, TimeSpan.FromSeconds 120.) :> SomhairlesDream.Modeling.IArtifactBridge), + artifactClock, + TimeSpan.FromMinutes 2. + ) + +let json value = Results.Json(value, jsonOptions) + +let events (context: HttpContext) : Task = + (task { + context.Response.ContentType <- "text/event-stream" + context.Response.Headers.CacheControl <- "no-cache" + + let reader = store.Subscribe() + + try + while not context.RequestAborted.IsCancellationRequested do + let! snapshot = reader.ReadAsync(context.RequestAborted).AsTask() + let payload = JsonSerializer.Serialize(snapshot, jsonOptions) + do! context.Response.WriteAsync($"data: {payload}\n\n", context.RequestAborted) + do! context.Response.Body.FlushAsync(context.RequestAborted) + with + | :? OperationCanceledException -> () + } :> Task) + +app.UseDefaultFiles() |> ignore +app.UseStaticFiles() |> ignore + +app.MapGet("/health", Func(fun () -> Results.Ok({| status = "ok" |}))) |> ignore + +ArtifactRunApi.register + app + { Coordinator = coordinator + Clock = artifactClock + JsonOptions = jsonOptions } + +let observeRuns = + Task.Run( + Func(fun () -> + task { + try + while not app.Lifetime.ApplicationStopping.IsCancellationRequested do + coordinator.ObserveAll() |> ignore + do! Task.Delay(TimeSpan.FromSeconds 1., app.Lifetime.ApplicationStopping) + with + | :? OperationCanceledException -> () + } :> Task) + ) + +app.MapGet( + "/api/state", + Func(fun () -> store.Observe(DateTimeOffset.UtcNow) |> json) +) +|> ignore + +app.MapPost( + "/api/runs/heartbeat", + Func(fun () -> store.Heartbeat(DateTimeOffset.UtcNow) |> json) +) +|> ignore + +app.MapGet("/api/events", Func(events)) |> ignore + +app.Run() diff --git a/src/SomhairlesDream.Server/SomhairlesDream.Server.fsproj b/src/SomhairlesDream.Server/SomhairlesDream.Server.fsproj new file mode 100644 index 0000000..17c159d --- /dev/null +++ b/src/SomhairlesDream.Server/SomhairlesDream.Server.fsproj @@ -0,0 +1,21 @@ + + + net8.0 + SomhairlesDream.Server + SomhairlesDream.Server + Exe + + + + + + + + + + + + + + + diff --git a/src/SomhairlesDream.Server/Store.fs b/src/SomhairlesDream.Server/Store.fs new file mode 100644 index 0000000..b4a2293 --- /dev/null +++ b/src/SomhairlesDream.Server/Store.fs @@ -0,0 +1,259 @@ +namespace SomhairlesDream.Server + +open System +open System.Collections.Generic +open System.Threading.Channels +open SomhairlesDream.Shared + +type RunStore(projectId: string, runId: string, staleAfter: TimeSpan) = + let gate = obj () + let mutable state = RunState.initial projectId runId DateTimeOffset.UtcNow + let subscribers = ResizeArray>() + + let update transition = + lock gate (fun () -> + state <- transition state + for subscriber in subscribers do + subscriber.Writer.TryWrite(state) |> ignore + state) + + member _.Snapshot() = lock gate (fun () -> state) + + member _.Start(now: DateTimeOffset) = update (RunState.start now) + + member _.Heartbeat(now: DateTimeOffset) = update (RunState.heartbeat now) + + member _.Observe(now: DateTimeOffset) = update (RunState.statusAt staleAfter now) + + member _.Publish(now: DateTimeOffset, mesh: MeshSnapshot) = update (RunState.publish now mesh) + + member _.Subscribe() : ChannelReader = + let channel = Channel.CreateUnbounded() + + lock gate (fun () -> + channel.Writer.TryWrite(state) |> ignore + subscribers.Add(channel) + channel.Reader) + +type ArtifactRunSubscription(reader: ChannelReader, dispose: unit -> unit) = + let mutable disposed = false + + member _.Reader = reader + + member _.Dispose() = + if not disposed then + disposed <- true + dispose () + + interface IDisposable with + member this.Dispose() = this.Dispose() + +type ArtifactRunStore(ids: RunIds, staleAfter: TimeSpan, initialAt: DateTimeOffset) = + let gate = obj () + let subscribers = ResizeArray>() + let mutable state : RunSnapshot = + { ProjectId = ids.ProjectId + RunId = ids.RunId + BaseId = ids.BaseId + TargetId = ids.TargetId + Status = "idle" + CurrentStepId = None + CurrentStepIndex = -1 + TotalSteps = 0 + LastHeartbeatAt = None + UpdatedAt = initialAt + Message = "waiting for design run" + ManifestPath = None + ManifestUrl = None + Error = None + IsStale = false } + + let publish next = + for subscriber in subscribers do + subscriber.Writer.TryWrite(next) |> ignore + + let eventIds = function + | RunEvent.Start value -> value.Ids + | RunEvent.Heartbeat value -> value.Ids + | RunEvent.Checkpoint value -> value.Ids + | RunEvent.Complete value -> value.Ids + | RunEvent.Fail value -> value.Ids + + let eventName = function + | RunEvent.Start _ -> "start" + | RunEvent.Heartbeat _ -> "heartbeat" + | RunEvent.Checkpoint _ -> "checkpoint" + | RunEvent.Complete _ -> "complete" + | RunEvent.Fail _ -> "fail" + + let rejectIfNotRunning event = + if state.Status <> "running" then + Some $"cannot apply {eventName event} to run in status {state.Status}" + else + None + + let checkpointCount () = + if state.CurrentStepIndex < 0 then 0 else state.CurrentStepIndex + 1 + + let commit next = + state <- next + publish next + Ok next + + member _.Snapshot() = lock gate (fun () -> state) + + member _.Apply(event: RunEvent) : Result = + lock gate (fun () -> + if eventIds event <> ids then + Error "run event identity does not match the selected run" + else + match event with + | RunEvent.Start value -> + if state.Status <> "idle" then + Error $"cannot apply start to run in status {state.Status}" + elif value.TotalSteps <= 0 then + Error "run must contain at least one step" + else + commit + { state with + Status = "running" + TotalSteps = value.TotalSteps + CurrentStepId = None + CurrentStepIndex = -1 + LastHeartbeatAt = Some value.At + UpdatedAt = value.At + Message = "design run started" + Error = None + IsStale = false } + | RunEvent.Heartbeat value -> + match rejectIfNotRunning event with + | Some message -> Error message + | None -> + commit + { state with + LastHeartbeatAt = Some value.At + UpdatedAt = value.At + Message = value.Message + IsStale = false } + | RunEvent.Checkpoint value -> + match rejectIfNotRunning event with + | Some message -> Error message + | None when value.TotalSteps <> state.TotalSteps -> + Error "checkpoint total steps do not match run" + | None when value.StepIndex < 0 || value.StepIndex >= state.TotalSteps -> + Error "checkpoint step index is outside the run" + | None when value.StepIndex <> checkpointCount () -> + Error "checkpoint step index is out of order" + | None -> + commit + { state with + CurrentStepId = Some value.StepId + CurrentStepIndex = value.StepIndex + LastHeartbeatAt = Some value.At + UpdatedAt = value.At + Message = value.Message + IsStale = false } + | RunEvent.Complete value -> + match rejectIfNotRunning event with + | Some message -> Error message + | None when checkpointCount () <> state.TotalSteps -> + Error "cannot complete run before every step is checkpointed" + | None -> + commit + { state with + Status = "complete" + CurrentStepId = None + LastHeartbeatAt = Some value.At + UpdatedAt = value.At + Message = "design run complete" + ManifestPath = Some value.ManifestPath + ManifestUrl = Some $"/api/artifacts/manifest?projectId={ids.ProjectId}&runId={ids.RunId}" + Error = None + IsStale = false } + | RunEvent.Fail value -> + if state.Status <> "idle" && state.Status <> "running" then + Error $"cannot apply fail to run in status {state.Status}" + else + commit + { state with + Status = "failed" + CurrentStepId = value.StepId + LastHeartbeatAt = Some value.At + UpdatedAt = value.At + Message = value.Message + Error = Some value.Message + IsStale = false }) + + member _.Observe(now: DateTimeOffset) = + lock gate (fun () -> + let next = + match state.Status, state.LastHeartbeatAt with + | "running", Some heartbeat when now - heartbeat > staleAfter && not state.IsStale -> + Some + { state with + UpdatedAt = now + Message = "heartbeat timeout" + IsStale = true } + | "running", Some heartbeat when now - heartbeat <= staleAfter && state.IsStale -> + Some + { state with + UpdatedAt = now + Message = "heartbeat resumed" + IsStale = false } + | _ -> None + + match next with + | Some value -> + state <- value + publish value + value + | None -> state) + + member _.Subscribe() = + let channel = Channel.CreateUnbounded() + + lock gate (fun () -> + channel.Writer.TryWrite(state) |> ignore + subscribers.Add(channel)) + + new ArtifactRunSubscription( + channel.Reader, + fun () -> + lock gate (fun () -> + subscribers.Remove(channel) |> ignore + channel.Writer.TryComplete() |> ignore)) + +type ArtifactRunRegistry(staleAfter: TimeSpan, clock: unit -> DateTimeOffset) = + let gate = obj () + let runs = Dictionary() + + member _.TryCreate(ids: RunIds) = + lock gate (fun () -> + let key = ids.ProjectId, ids.RunId + + match runs.TryGetValue(key) with + | true, _ -> None + | false, _ -> + let store = ArtifactRunStore(ids, staleAfter, clock ()) + runs.Add(key, store) + Some store) + + member _.GetOrCreate(ids: RunIds) = + lock gate (fun () -> + let key = ids.ProjectId, ids.RunId + + match runs.TryGetValue(key) with + | true, store -> store + | false, _ -> + let store = ArtifactRunStore(ids, staleAfter, clock ()) + runs.Add(key, store) + store) + + member _.TryFind(projectId: string, runId: string) = + lock gate (fun () -> + match runs.TryGetValue((projectId, runId)) with + | true, store -> Some store + | false, _ -> None) + + member _.ObserveAll(now: DateTimeOffset) = + lock gate (fun () -> runs.Values |> Seq.map (fun store -> store.Observe(now)) |> Seq.toArray) diff --git a/src/SomhairlesDream.Shared/Artifact.fs b/src/SomhairlesDream.Shared/Artifact.fs new file mode 100644 index 0000000..d1cb4f0 --- /dev/null +++ b/src/SomhairlesDream.Shared/Artifact.fs @@ -0,0 +1,218 @@ +namespace SomhairlesDream.Shared + +open System +#if !FABLE_COMPILER +open System.Text.Json +open System.Text.Json.Nodes +#endif + +[] +type RunIds = + { ProjectId: string + RunId: string + BaseId: string + TargetId: string } + +module Ids = + open System.Text.RegularExpressions + + let private resourcePattern = Regex("^[a-z0-9](?:[a-z0-9-]{0,62}[a-z0-9])?$", RegexOptions.CultureInvariant) + let private objectPattern = Regex("^[a-z0-9]+(?:[._-][a-z0-9]+)*$", RegexOptions.CultureInvariant) + + let validateResourceId value = + if isNull value || not (resourcePattern.IsMatch(value)) then + Error "resource id must contain only lower-case letters, digits, and hyphens" + else + Ok () + + let validateObjectId value = + if isNull value || not (objectPattern.IsMatch(value)) then + Error "object id must use the dotted lower-case namespace" + else + Ok () + +[] +type RunStart = + { Ids: RunIds + At: DateTimeOffset + TotalSteps: int } + +[] +type RunHeartbeat = + { Ids: RunIds + At: DateTimeOffset + Message: string } + +[] +type RunCheckpoint = + { Ids: RunIds + At: DateTimeOffset + StepId: string + StepIndex: int + TotalSteps: int + Message: string + ArtifactPath: string } + +[] +type RunComplete = + { Ids: RunIds + At: DateTimeOffset + ManifestPath: string } + +[] +type RunFail = + { Ids: RunIds + At: DateTimeOffset + StepId: string option + Message: string } + +type RunEvent = + | Start of RunStart + | Heartbeat of RunHeartbeat + | Checkpoint of RunCheckpoint + | Complete of RunComplete + | Fail of RunFail + +[] +type RunEventWire = + { Kind: string + At: DateTimeOffset + ProjectId: string + RunId: string + BaseId: string + TargetId: string + TotalSteps: int option + StepId: string option + StepIndex: int option + Message: string option + ArtifactPath: string option + ManifestPath: string option } + +module RunEvent = + let private ids (value: RunIds) = + value.ProjectId, value.RunId, value.BaseId, value.TargetId + + let toWire event = + let kind, eventIds, at, totalSteps, stepId, stepIndex, message, artifactPath, manifestPath = + match event with + | Start value -> + "start", value.Ids, value.At, Some value.TotalSteps, None, None, None, None, None + | Heartbeat value -> + "heartbeat", value.Ids, value.At, None, None, None, Some value.Message, None, None + | Checkpoint value -> + "checkpoint", + value.Ids, + value.At, + Some value.TotalSteps, + Some value.StepId, + Some value.StepIndex, + Some value.Message, + Some value.ArtifactPath, + None + | Complete value -> + "complete", value.Ids, value.At, None, None, None, None, None, Some value.ManifestPath + | Fail value -> + "fail", value.Ids, value.At, None, value.StepId, None, Some value.Message, None, None + + let projectId, runId, baseId, targetId = ids eventIds + + { Kind = kind + At = at + ProjectId = projectId + RunId = runId + BaseId = baseId + TargetId = targetId + TotalSteps = totalSteps + StepId = stepId + StepIndex = stepIndex + Message = message + ArtifactPath = artifactPath + ManifestPath = manifestPath } + +#if !FABLE_COMPILER + let private addOptional (json: JsonObject) (name: string) value create = + match value with + | Some item -> json[name] <- create item + | None -> () + + let private jsonOptions () = + let options = JsonSerializerOptions() + options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase + options.WriteIndented <- false + options + + let toJson event = + let wire = toWire event + let json = JsonObject() + json["kind"] <- JsonValue.Create(wire.Kind) + json["at"] <- JsonValue.Create(wire.At) + json["projectId"] <- JsonValue.Create(wire.ProjectId) + json["runId"] <- JsonValue.Create(wire.RunId) + json["baseId"] <- JsonValue.Create(wire.BaseId) + json["targetId"] <- JsonValue.Create(wire.TargetId) + addOptional json "totalSteps" wire.TotalSteps (fun value -> JsonValue.Create(value)) + addOptional json "stepId" wire.StepId (fun value -> JsonValue.Create(value)) + addOptional json "stepIndex" wire.StepIndex (fun value -> JsonValue.Create(value)) + addOptional json "message" wire.Message (fun value -> JsonValue.Create(value)) + addOptional json "artifactPath" wire.ArtifactPath (fun value -> JsonValue.Create(value)) + addOptional json "manifestPath" wire.ManifestPath (fun value -> JsonValue.Create(value)) + json.ToJsonString(jsonOptions()) +#endif + +[] +type ArtifactChange = + { ObjectId: string + Kind: string + Summary: string } + +[] +type RenderArtifact = + { ArtifactPath: string + Sha256: string + Bytes: int64 + ExportedAt: DateTimeOffset } + +[] +type StepArtifact = + { StepId: string + StepIndex: int + ArtifactPath: string + LogPath: string + Sha256: string + Bytes: int64 + ExportedAt: DateTimeOffset + ObjectIds: string array + VerifiedObjectIds: string array + Changes: ArtifactChange array + Render: RenderArtifact option } + +[] +type ArtifactManifest = + { SchemaVersion: int + ProjectId: string + RunId: string + BaseId: string + TargetId: string + Status: string + StartedAt: DateTimeOffset + CompletedAt: DateTimeOffset + BlenderVersion: string + Steps: StepArtifact array } + +[] +type RunSnapshot = + { ProjectId: string + RunId: string + BaseId: string + TargetId: string + Status: string + CurrentStepId: string option + CurrentStepIndex: int + TotalSteps: int + LastHeartbeatAt: DateTimeOffset option + UpdatedAt: DateTimeOffset + Message: string + ManifestPath: string option + ManifestUrl: string option + Error: string option + IsStale: bool } diff --git a/src/SomhairlesDream.Shared/Domain.fs b/src/SomhairlesDream.Shared/Domain.fs new file mode 100644 index 0000000..fd229fa --- /dev/null +++ b/src/SomhairlesDream.Shared/Domain.fs @@ -0,0 +1,102 @@ +namespace SomhairlesDream.Shared + +open System + +[] +type RunStatus = + | Idle = 0 + | Queued = 1 + | Running = 2 + | Succeeded = 3 + | Failed = 4 + | Stale = 5 + +type Vector3 = + { X: float + Y: float + Z: float } + +type MeshSnapshot = + { Version: int + Label: string + Vertices: Vector3 array + Faces: int array array } + +type LiveSnapshot = + { ProjectId: string + RunId: string + Status: RunStatus + CurrentVersion: int + TargetVersion: int + HeartbeatAt: DateTimeOffset option + UpdatedAt: DateTimeOffset + Message: string + Mesh: MeshSnapshot option + NextDesignRunScheduled: bool } + +module MeshData = + let positionData (mesh: MeshSnapshot) = + mesh.Vertices + |> Array.collect (fun vertex -> [| vertex.X; vertex.Y; vertex.Z |]) + + let triangleIndices (mesh: MeshSnapshot) = + mesh.Faces + |> Array.collect (fun face -> + if face.Length < 3 then + [||] + else + [| for index in 1 .. face.Length - 2 do + yield face[0] + yield face[index] + yield face[index + 1] |]) + +module RunState = + let initial projectId runId now = + { ProjectId = projectId + RunId = runId + Status = RunStatus.Idle + CurrentVersion = 0 + TargetVersion = 0 + HeartbeatAt = None + UpdatedAt = now + Message = "等待设计运行" + Mesh = None + NextDesignRunScheduled = false } + + let start now state = + let targetVersion = state.TargetVersion + 1 + + { state with + Status = RunStatus.Running + TargetVersion = targetVersion + HeartbeatAt = Some now + UpdatedAt = now + Message = $"正在生成第 {targetVersion} 版几何" + NextDesignRunScheduled = false } + + let heartbeat now state = + if state.Status = RunStatus.Running then + { state with + HeartbeatAt = Some now + UpdatedAt = now } + else + state + + let statusAt timeout now state = + match state.HeartbeatAt with + | Some heartbeatAt when state.Status = RunStatus.Running && now - heartbeatAt > timeout -> + { state with + Status = RunStatus.Stale + UpdatedAt = now + Message = "心跳超时，等待重连" } + | _ -> state + + let publish now mesh state = + { state with + Status = RunStatus.Succeeded + CurrentVersion = mesh.Version + HeartbeatAt = Some now + UpdatedAt = now + Message = $"已发布{mesh.Label}" + Mesh = Some mesh + NextDesignRunScheduled = false } diff --git a/src/SomhairlesDream.Shared/Replay.fs b/src/SomhairlesDream.Shared/Replay.fs new file mode 100644 index 0000000..782e632 --- /dev/null +++ b/src/SomhairlesDream.Shared/Replay.fs @@ -0,0 +1,107 @@ +namespace SomhairlesDream.Shared + +type ReplayFrame = + { Version: int + Label: string + Mesh: MeshSnapshot } + +module Replay = + let private vertex x y z = + { X = x + Y = y + Z = z } + + let private frame version label vertices faces = + { Version = version + Label = label + Mesh = + { Version = version + Label = label + Vertices = vertices + Faces = faces } } + + let frames () = + [| frame + 1 + "重建起点" + [| vertex -2.0 0.0 -1.0 + vertex 2.0 0.0 -1.0 + vertex 2.0 0.0 1.0 + vertex -2.0 0.0 1.0 + vertex -1.0 2.0 -0.5 + vertex 1.0 2.0 -0.5 + vertex 1.0 2.0 0.5 + vertex -1.0 2.0 0.5 |] + [| [| 0; 1; 2 |] + [| 0; 2; 3 |] + [| 4; 6; 5 |] + [| 4; 7; 6 |] + [| 0; 4; 5 |] + [| 0; 5; 1 |] + [| 1; 5; 6 |] + [| 1; 6; 2 |] + [| 2; 6; 7 |] + [| 2; 7; 3 |] + [| 3; 7; 4 |] + [| 3; 4; 0 |] |] + frame + 2 + "主承力骨架" + [| vertex -2.5 0.0 -1.0 + vertex 2.5 0.0 -1.0 + vertex 2.5 0.0 1.0 + vertex -2.5 0.0 1.0 + vertex -1.5 2.2 -0.7 + vertex 1.5 2.2 -0.7 + vertex 1.5 2.2 0.7 + vertex -1.5 2.2 0.7 + vertex -0.45 0.0 -0.45 + vertex 0.45 0.0 -0.45 + vertex 0.45 3.0 0.45 + vertex -0.45 3.0 0.45 |] + [| [| 0; 1; 2 |] + [| 0; 2; 3 |] + [| 4; 6; 5 |] + [| 4; 7; 6 |] + [| 8; 9; 10 |] + [| 8; 10; 11 |] + [| 0; 4; 8 |] + [| 4; 11; 8 |] + [| 1; 9; 5 |] + [| 1; 5; 2 |] + [| 2; 5; 10 |] + [| 2; 10; 3 |] + [| 3; 10; 7 |] + [| 3; 7; 0 |] |] + frame + 3 + "舱段重构" + [| vertex -3.0 0.0 -1.3 + vertex 3.0 0.0 -1.3 + vertex 3.0 0.0 1.3 + vertex -3.0 0.0 1.3 + vertex -2.0 2.0 -1.0 + vertex 2.0 2.0 -1.0 + vertex 2.0 2.0 1.0 + vertex -2.0 2.0 1.0 + vertex -1.0 3.4 -0.65 + vertex 1.0 3.4 -0.65 + vertex 1.0 3.4 0.65 + vertex -1.0 3.4 0.65 + vertex -3.8 0.6 0.0 + vertex 3.8 0.6 0.0 |] + [| [| 0; 1; 2 |] + [| 0; 2; 3 |] + [| 4; 6; 5 |] + [| 4; 7; 6 |] + [| 8; 9; 10 |] + [| 8; 10; 11 |] + [| 0; 4; 8 |] + [| 0; 8; 12 |] + [| 1; 13; 5 |] + [| 1; 2; 13 |] + [| 2; 6; 10 |] + [| 2; 10; 13 |] + [| 3; 11; 7 |] + [| 3; 12; 11 |] + [| 3; 0; 12 |] |] |] diff --git a/src/SomhairlesDream.Shared/SomhairlesDream.Shared.fsproj b/src/SomhairlesDream.Shared/SomhairlesDream.Shared.fsproj new file mode 100644 index 0000000..7a7e853 --- /dev/null +++ b/src/SomhairlesDream.Shared/SomhairlesDream.Shared.fsproj @@ -0,0 +1,12 @@ + + + net8.0 + SomhairlesDream.Shared + SomhairlesDream.Shared + + + + + + + -- cgit v1.2.3