From df18dd45418802d9bf62746bcedbd4aa1a43b3ee Mon Sep 17 00:00:00 2001 From: Kevin F Date: Tue, 18 Feb 2025 15:33:34 +0100 Subject: [PATCH 01/11] Move files :truck: --- src/Client/Client.fsproj | 5 ++--- src/Client/Host.fs | 17 ----------------- src/Client/Routing.fs | 18 ++++++++++++++++++ src/Client/{ => Util}/ARCtrl.Helper.fs | 0 src/Client/{ => Util}/Helper.fs | 0 5 files changed, 20 insertions(+), 20 deletions(-) delete mode 100644 src/Client/Host.fs rename src/Client/{ => Util}/ARCtrl.Helper.fs (100%) rename src/Client/{ => Util}/Helper.fs (100%) diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index d103fc91..eda4a112 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -9,16 +9,15 @@ - - + + - diff --git a/src/Client/Host.fs b/src/Client/Host.fs deleted file mode 100644 index 33fd146f..00000000 --- a/src/Client/Host.fs +++ /dev/null @@ -1,17 +0,0 @@ -[] -module Host - -[] -type Swatehost = -| Browser -| Excel -| ARCitect -with - static member ofQueryParam (queryInteger: int option) = - match queryInteger with - | Some 1 -> Swatehost.ARCitect - | Some 2 -> Swatehost.Excel - | _ -> Browser - - member this.IsStandalone = - this = Swatehost.Browser || this = Swatehost.ARCitect \ No newline at end of file diff --git a/src/Client/Routing.fs b/src/Client/Routing.fs index 86ca1e87..6e86f948 100644 --- a/src/Client/Routing.fs +++ b/src/Client/Routing.fs @@ -3,6 +3,24 @@ module Routing open Elmish.UrlParser open Feliz +[] +module Host = + + [] + type Swatehost = + | Browser + | Excel + | ARCitect + with + static member ofQueryParam (queryInteger: int option) = + match queryInteger with + | Some 1 -> Swatehost.ARCitect + | Some 2 -> Swatehost.Excel + | _ -> Browser + + member this.IsStandalone = + this = Swatehost.Browser || this = Swatehost.ARCitect + [] type SidebarPage = | BuildingBlock diff --git a/src/Client/ARCtrl.Helper.fs b/src/Client/Util/ARCtrl.Helper.fs similarity index 100% rename from src/Client/ARCtrl.Helper.fs rename to src/Client/Util/ARCtrl.Helper.fs diff --git a/src/Client/Helper.fs b/src/Client/Util/Helper.fs similarity index 100% rename from src/Client/Helper.fs rename to src/Client/Util/Helper.fs From 56b9e37432cd81dc9eed1acbf8c40652ce9db000 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Tue, 18 Feb 2025 15:36:36 +0100 Subject: [PATCH 02/11] Add new message interop logic --- src/Client/Client.fsproj | 1 + src/Client/Util/MessageInterop.fs | 275 ++++++++++++++++++++++++++++++ 2 files changed, 276 insertions(+) create mode 100644 src/Client/Util/MessageInterop.fs diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index eda4a112..0a8316eb 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -10,6 +10,7 @@ + diff --git a/src/Client/Util/MessageInterop.fs b/src/Client/Util/MessageInterop.fs new file mode 100644 index 00000000..90914cea --- /dev/null +++ b/src/Client/Util/MessageInterop.fs @@ -0,0 +1,275 @@ +module MessageInterop + +open System +open FSharp.Reflection +open Fable.Core +open System.Collections.Generic +open Fable.Core.JsInterop + +type private IMessagePayload = {| + /// must be set to true to target correct event handler + swate: bool + /// if action started, set to api name + /// This functions as additional fail save: + /// 1. If api is set, the message is a request. + /// 2. If PendingRequests contains the requestId, the message is a request. + /// Only if both conditions are met, Swate sends a response. + api: string option + requestId: string option + data: obj option + error: string option +|} + +type PendingRequests = Dictionary unit) * (exn -> unit)> + +type InteropOptions = { + Target: Browser.Types.Window + GenericErrorHandler: exn -> unit +} + +open System +open Fable.Core +open Fable.SimpleJson +open Browser.Types + +module private Helper = + + let private sendMsgWithResponse (pendingRequestsDictionary: PendingRequests) (target: Browser.Types.Window) (payload: IMessagePayload) = + Promise.create (fun resolve reject -> + // create timeout for response + let timeout = + Fable.Core.JS.setTimeout + (fun () -> + pendingRequestsDictionary.Remove(payload.requestId.Value) |> ignore + reject (new TimeoutException("Request timed out")) + ) + 5000 + pendingRequestsDictionary.Add(payload.requestId.Value, (resolve, reject)) + target.postMessage(payload, "*") + ) + + let rec getReturnType typ = + if Reflection.FSharpType.IsFunction typ then + let _, res = Reflection.FSharpType.GetFunctionElements typ + getReturnType res + elif typ.IsGenericType then + typ.GetGenericArguments () |> Array.head + else + typ + + let proxyCall (target: Browser.Types.Window) (func: RecordField) pendingRequestsDictionary = + let funcArgs : (TypeInfo [ ]) = + match func.FieldType with + | TypeInfo.Func getArgs -> getArgs() + | _ -> failwithf "MessageInterop-Error: Field %s does not have a valid definiton" func.FieldName + + let argumentCount = (Array.length funcArgs) - 1 + let returnTypeAsync = Array.last funcArgs + + let funcNeedParameters = + match funcArgs with + | [| TypeInfo.Async _ |] -> false + | [| TypeInfo.Promise _ |] -> false + | [| TypeInfo.Unit; TypeInfo.Async _ |] -> false + | otherwise -> true + + let executeRequest = + let returnType = + match returnTypeAsync with + | TypeInfo.Promise getPromiseTypeArgument -> getPromiseTypeArgument() + | _ -> failwithf "MessageInterop-Error:: Expected field %s to have a return type of Async<'t> or Task<'t>" func.FieldName + + fun requestBody -> sendMsgWithResponse pendingRequestsDictionary target requestBody + + fun arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 -> + let inputArguments = + if funcNeedParameters + then Array.take argumentCount [| box arg0;box arg1;box arg2;box arg3; box arg4; box arg5; box arg6; box arg7 |] + else [| |] + + let requestBody: IMessagePayload = + {| swate = true; api = Some func.FieldName; data = Some inputArguments; requestId = Some (System.Guid.NewGuid().ToString()); error = None |} + + executeRequest requestBody + +module MessageInterop = + + let createApi() : InteropOptions = { + Target = Browser.Dom.window.parent + GenericErrorHandler = fun exn -> Browser.Dom.console.log($"Proxy Error: {exn.Message}") + } + + let withErrorHandler errorHandler options : InteropOptions = { options with GenericErrorHandler = errorHandler } + + let withTarget target options : InteropOptions = { options with Target = target } + +type MessageInterop() = + + // Function to generate a new instance dynamically + static member buildOutProxy (target: Browser.Types.Window, resolvedType: Type, pendingRequestsDictionary: PendingRequests) : 'T = + + if not (FSharpType.IsRecord resolvedType) then + failwithf "MessageInterop-Error: Provided type is not a record. %s" resolvedType.FullName + + let schemaType = createTypeInfo resolvedType + match schemaType with + | TypeInfo.Record getFields -> + let (fields, recordType) = getFields() + let recordFields = [| + for field in fields do + let normalize n = + let fn = Helper.proxyCall target field pendingRequestsDictionary + // this match case comes from Fable.Remoting + // https://github.com/Zaid-Ajaj/Fable.Remoting/blob/9bf4dab1987abad342c671cb4ff1a8a7e0e846d0/Fable.Remoting.Client/Remoting.fs#L58 + // I cannot trigger any case other than 1 arguments, as all record type arguments are parsed into a tuple + match n with + | 0 -> + box (fn null null null null null null null null) + | 1 -> + box (fun a -> + fn a null null null null null null null) + | 2 -> + let proxyF a b = fn a b null null null null null null + unbox (System.Func<_,_,_> proxyF) + | 3 -> + let proxyF a b c = fn a b c null null null null null + unbox (System.Func<_,_,_,_> proxyF) + | 4 -> + let proxyF a b c d = fn a b c d null null null null + unbox (System.Func<_,_,_,_,_> proxyF) + | 5 -> + let proxyF a b c d e = fn a b c d e null null null + unbox (System.Func<_,_,_,_,_,_> proxyF) + | 6 -> + let proxyF a b c d e f = fn a b c d e f null null + unbox (System.Func<_,_,_,_,_,_,_> proxyF) + | 7 -> + let proxyF a b c d e f g = fn a b c d e f g null + unbox (System.Func<_,_,_,_,_,_,_,_> proxyF) + | 8 -> + let proxyF a b c d e f g h = fn a b c d e f g h + unbox (System.Func<_,_,_,_,_,_,_,_,_> proxyF) + | _ -> + failwithf "MessageInterop-Error: Cannot generate proxy function for %s. Only up to 8 arguments are supported. Consider using a record type as input" field.FieldName + + let argumentCount = + match field.FieldType with + | TypeInfo.Async _ -> 0 + | TypeInfo.Promise _ -> 0 + | TypeInfo.Func getArgs -> Array.length (getArgs()) - 1 + | _ -> 0 + + normalize argumentCount + |] + + let proxy = FSharpValue.MakeRecord(recordType, recordFields) + unbox<'T> proxy + | _ -> + failwithf "MessageInterop-Error: Cannot build proxy. Exepected type %s to be a valid protocol definition which is a record of functions" resolvedType.FullName + + static member buildInProxy(recordType, recordTypeType: Type, target: Browser.Types.Window, handleGenericError, pendingRequestsDictionary: PendingRequests) = + + let schemaType = createTypeInfo recordTypeType + match schemaType with + | TypeInfo.Record getFields -> + let (fields, _) = getFields() + for field in fields do + let funcArgs : (TypeInfo [ ]) = + match field.FieldType with + | TypeInfo.Async _ -> [| field.FieldType |] + | TypeInfo.Promise _ -> [| field.FieldType |] + | TypeInfo.Func getArgs -> getArgs() + | _ -> failwithf "MessageInterop-Error: Field %s does not have a valid definiton" field.FieldName + let returnTypeAsync = Array.last funcArgs + match returnTypeAsync with + | TypeInfo.Promise _ -> () + | _ -> failwith "MessageInterop-Error: Only Promise return types are supported for incoming messages" + | _ -> + () + + let verifyMsg (e: Browser.Types.MessageEvent) = + let content = e.data :?> IMessagePayload + if content.swate then + Some content + else + None + + let getEventHandlerByName (inst: 'A) (s:string) = + let fields = Microsoft.FSharp.Reflection.FSharpType.GetRecordFields(recordTypeType) + match fields |> Array.tryFind(fun t -> t.Name = s) with + | Some pi -> Some(pi.GetValue(inst)) + | None -> None + + let runApiFromName (apiHandler: 'E) (apiName: string) (data: 'A) = + let func = getEventHandlerByName apiHandler apiName + match func with + | Some f -> + let f: 'A -> JS.Promise = !!f + f data + | None -> + failwith $"MessageInterop-Error: No such API function found in Incoming API: {apiName}" + + // TODO: support async functions + let resolveIncMessage (apiHandler: 'E) (content: IMessagePayload) = + match content.api with + | Some api -> + promise { + let! payload = + try + promise { + let! r = runApiFromName apiHandler api content.data + return {| content with data = Some r|} + } + with + | exn -> + let p: IMessagePayload = {| content with error = Some exn.Message; data = None|} + Promise.lift p + |> Promise.map (fun (payload: IMessagePayload) -> + let result: IMessagePayload = {| payload with api = None |} + result + ) + + target.postMessage(payload, "*") + } + |> Promise.start + | None -> + let payload: IMessagePayload = + {| content with error = Some "No API name given!"|} + target.postMessage(payload, "*") + + let handle = + fun (e: Browser.Types.Event) -> + let e = e :?> Browser.Types.MessageEvent + match verifyMsg e with + | Some content -> + if content.error.IsSome then + let exn = new Exception(content.error.Value) + match pendingRequestsDictionary.TryGetValue(content.requestId.Value) with + | true, (_, reject) -> + pendingRequestsDictionary.Remove(content.requestId.Value) |> ignore + reject exn + | _ -> + handleGenericError exn + elif content.requestId.IsSome then + match pendingRequestsDictionary.TryGetValue(content.requestId.Value) with + | true, (resolve, _) -> + log "[Swate] response from ARCitect" + pendingRequestsDictionary.Remove(content.requestId.Value) |> ignore + resolve content.data + | _ -> + log "[Swate] request from ARCitect" + resolveIncMessage recordType content + else + log "MessageInterop-Warning: Unhandled ARCitect msg" + | None -> + () + + Browser.Dom.window.addEventListener("message", handle) + fun () -> Browser.Dom.window.removeEventListener("message", handle) + + static member inline buildProxy<'o, 'i> (incomingMsgHandler: 'i) (options: InteropOptions) : 'o * (unit -> unit) = + let PendingRequests = PendingRequests() + let inType = typeof<'i> + let outType = typeof<'o> + MessageInterop.buildOutProxy(options.Target, outType, PendingRequests), + MessageInterop.buildInProxy(incomingMsgHandler, inType, options.Target, options.GenericErrorHandler, PendingRequests) From ef1a33be642eea3f5cc7d63101d1e9c578004bd1 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Thu, 20 Feb 2025 15:59:57 +0100 Subject: [PATCH 03/11] Update Interop logic #636 --- package-lock.json | 160 +++++++++++------- package.json | 1 + src/Client/ARCitect/ARCitect.fs | 64 ------- src/Client/ARCitect/Interop.fs | 53 ------ src/Client/App.fs | 25 ++- src/Client/Client.fsproj | 5 +- src/Client/Init.fs | 1 + src/Client/MainComponents/Navbar.fs | 6 +- src/Client/Messages.fs | 1 + src/Client/Model.fs | 1 + src/Client/Pages/FilePicker/FilePickerView.fs | 15 +- src/Client/Routing.fs | 18 -- src/Client/States/ARCitect.fs | 73 ++++++-- src/Client/States/Spreadsheet.fs | 1 - src/Client/Update.fs | 5 + src/Client/Update/ARCitectUpdate.fs | 102 +++++++++++ src/Client/Update/InterfaceUpdate.fs | 28 ++- src/Client/Update/SpreadsheetUpdate.fs | 34 ++-- src/Client/Util/ElmishHelper.fs | 13 ++ src/Client/Util/MessageInterop.fs | 160 ++++++++---------- src/Client/Util/SwateHost.fs | 18 ++ src/Client/Views/SidebarView.fs | 2 +- src/Client/tailwind.config.js | 3 + 23 files changed, 439 insertions(+), 350 deletions(-) delete mode 100644 src/Client/ARCitect/ARCitect.fs delete mode 100644 src/Client/ARCitect/Interop.fs create mode 100644 src/Client/Update/ARCitectUpdate.fs create mode 100644 src/Client/Util/ElmishHelper.fs create mode 100644 src/Client/Util/SwateHost.fs diff --git a/package-lock.json b/package-lock.json index 2d96cac8..64231997 100644 --- a/package-lock.json +++ b/package-lock.json @@ -11,6 +11,7 @@ "@nfdi4plants/exceljs": "^0.3.0", "@tailwindcss/container-queries": "^0.1.1", "cytoscape": "^3.27.0", + "flyonui": "^1.3.0", "isomorphic-fetch": "^3.0.0", "jsonschema": "^1.4.1", "pako": "^2.1.0", @@ -1470,6 +1471,16 @@ "node": ">=14" } }, + "node_modules/@popperjs/core": { + "version": "2.11.8", + "resolved": "https://registry.npmjs.org/@popperjs/core/-/core-2.11.8.tgz", + "integrity": "sha512-P1st0aksCrn9sGZhp8GMYwBnQsbvAWsZAX44oXNNvLHGqAOcoVxmjZiohstwQ7SqKnbR47akdNi+uleWD8+g6A==", + "license": "MIT", + "funding": { + "type": "opencollective", + "url": "https://opencollective.com/popperjs" + } + }, "node_modules/@rollup/plugin-inject": { "version": "5.0.5", "resolved": "https://registry.npmjs.org/@rollup/plugin-inject/-/plugin-inject-5.0.5.tgz", @@ -2174,14 +2185,14 @@ } }, "node_modules/@vitest/expect": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/expect/-/expect-2.1.6.tgz", - "integrity": "sha512-9M1UR9CAmrhJOMoSwVnPh2rELPKhYo0m/CSgqw9PyStpxtkwhmdM6XYlXGKeYyERY1N6EIuzkQ7e3Lm1WKCoUg==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/expect/-/expect-2.1.9.tgz", + "integrity": "sha512-UJCIkTBenHeKT1TTlKMJWy1laZewsRIzYighyYiJKZreqtdxSos/S1t+ktRMQWu2CKqaarrkeszJx1cgC5tGZw==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/spy": "2.1.6", - "@vitest/utils": "2.1.6", + "@vitest/spy": "2.1.9", + "@vitest/utils": "2.1.9", "chai": "^5.1.2", "tinyrainbow": "^1.2.0" }, @@ -2190,13 +2201,13 @@ } }, "node_modules/@vitest/mocker": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/mocker/-/mocker-2.1.6.tgz", - "integrity": "sha512-MHZp2Z+Q/A3am5oD4WSH04f9B0T7UvwEb+v5W0kCYMhtXGYbdyl2NUk1wdSMqGthmhpiThPDp/hEoVwu16+u1A==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/mocker/-/mocker-2.1.9.tgz", + "integrity": "sha512-tVL6uJgoUdi6icpxmdrn5YNo3g3Dxv+IHJBr0GXHaEdTcw3F+cPKnsXFhli6nO+f/6SDKPHEK1UN+k+TQv0Ehg==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/spy": "2.1.6", + "@vitest/spy": "2.1.9", "estree-walker": "^3.0.3", "magic-string": "^0.30.12" }, @@ -2205,7 +2216,7 @@ }, "peerDependencies": { "msw": "^2.4.9", - "vite": "^5.0.0 || ^6.0.0" + "vite": "^5.0.0" }, "peerDependenciesMeta": { "msw": { @@ -2227,9 +2238,9 @@ } }, "node_modules/@vitest/pretty-format": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/pretty-format/-/pretty-format-2.1.6.tgz", - "integrity": "sha512-exZyLcEnHgDMKc54TtHca4McV4sKT+NKAe9ix/yhd/qkYb/TP8HTyXRFDijV19qKqTZM0hPL4753zU/U8L/gAA==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/pretty-format/-/pretty-format-2.1.9.tgz", + "integrity": "sha512-KhRIdGV2U9HOUzxfiHmY8IFHTdqtOhIzCpd8WRdJiE7D/HUcZVD0EgQCVjm+Q9gkUXWgBvMmTtZgIG48wq7sOQ==", "dev": true, "license": "MIT", "dependencies": { @@ -2240,13 +2251,13 @@ } }, "node_modules/@vitest/runner": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/runner/-/runner-2.1.6.tgz", - "integrity": "sha512-SjkRGSFyrA82m5nz7To4CkRSEVWn/rwQISHoia/DB8c6IHIhaE/UNAo+7UfeaeJRE979XceGl00LNkIz09RFsA==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/runner/-/runner-2.1.9.tgz", + "integrity": "sha512-ZXSSqTFIrzduD63btIfEyOmNcBmQvgOVsPNPe0jYtESiXkhd8u2erDLnMxmGrDCwHCCHE7hxwRDCT3pt0esT4g==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/utils": "2.1.6", + "@vitest/utils": "2.1.9", "pathe": "^1.1.2" }, "funding": { @@ -2254,13 +2265,13 @@ } }, "node_modules/@vitest/snapshot": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/snapshot/-/snapshot-2.1.6.tgz", - "integrity": "sha512-5JTWHw8iS9l3v4/VSuthCndw1lN/hpPB+mlgn1BUhFbobeIUj1J1V/Bj2t2ovGEmkXLTckFjQddsxS5T6LuVWw==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/snapshot/-/snapshot-2.1.9.tgz", + "integrity": "sha512-oBO82rEjsxLNJincVhLhaxxZdEtV0EFHMK5Kmx5sJ6H9L183dHECjiefOAdnqpIgT5eZwT04PoggUnW88vOBNQ==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/pretty-format": "2.1.6", + "@vitest/pretty-format": "2.1.9", "magic-string": "^0.30.12", "pathe": "^1.1.2" }, @@ -2269,9 +2280,9 @@ } }, "node_modules/@vitest/spy": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/spy/-/spy-2.1.6.tgz", - "integrity": "sha512-oTFObV8bd4SDdRka5O+mSh5w9irgx5IetrD5i+OsUUsk/shsBoHifwCzy45SAORzAhtNiprUVaK3hSCCzZh1jQ==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/spy/-/spy-2.1.9.tgz", + "integrity": "sha512-E1B35FwzXXTs9FHNK6bDszs7mtydNi5MIfUWpceJ8Xbfb1gBMscAnwLbEu+B44ed6W3XjL9/ehLPHR1fkf1KLQ==", "dev": true, "license": "MIT", "dependencies": { @@ -2282,13 +2293,13 @@ } }, "node_modules/@vitest/utils": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/@vitest/utils/-/utils-2.1.6.tgz", - "integrity": "sha512-ixNkFy3k4vokOUTU2blIUvOgKq/N2PW8vKIjZZYsGJCMX69MRa9J2sKqX5hY/k5O5Gty3YJChepkqZ3KM9LyIQ==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/@vitest/utils/-/utils-2.1.9.tgz", + "integrity": "sha512-v0psaMSkNJ3A2NMrUEHFRzJtDPFn+/VWZ5WxImB21T9fjucJRmS7xCS3ppEnARb9y11OAzaD+P2Ps+b+BGX5iQ==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/pretty-format": "2.1.6", + "@vitest/pretty-format": "2.1.9", "loupe": "^3.1.2", "tinyrainbow": "^1.2.0" }, @@ -3145,9 +3156,9 @@ "license": "CC-BY-4.0" }, "node_modules/chai": { - "version": "5.1.2", - "resolved": "https://registry.npmjs.org/chai/-/chai-5.1.2.tgz", - "integrity": "sha512-aGtmf24DW6MLHHG5gCx4zaI3uBq3KRtxeVs0DjFH6Z0rDNbsvTxFASFvdj79pxjxZ8/5u3PIiN3IwEIQkiiuPw==", + "version": "5.2.0", + "resolved": "https://registry.npmjs.org/chai/-/chai-5.2.0.tgz", + "integrity": "sha512-mCuXncKXk5iCLhfhwTc0izo0gtEmpz5CtG2y8GiOINBlMVS6v8TMRc5TaLWKS6692m9+dVVfzgeVxR5UxWHTYw==", "dev": true, "license": "MIT", "dependencies": { @@ -3515,7 +3526,6 @@ "version": "0.8.0", "resolved": "https://registry.npmjs.org/css-selector-tokenizer/-/css-selector-tokenizer-0.8.0.tgz", "integrity": "sha512-Jd6Ig3/pe62/qe5SBPTN8h8LeUg/pT4lLgtavPf7updwwHpvFzxvOQBHYj2LZDMjUnBzgvIUSjRcf6oT5HzHFg==", - "dev": true, "license": "MIT", "dependencies": { "cssesc": "^3.0.0", @@ -3978,9 +3988,9 @@ } }, "node_modules/es-module-lexer": { - "version": "1.5.4", - "resolved": "https://registry.npmjs.org/es-module-lexer/-/es-module-lexer-1.5.4.tgz", - "integrity": "sha512-MVNK56NiMrOwitFB7cqDwq0CQutbw+0BvLshJSse0MUNU+y1FC3bUS/AQg7oUng+/wKrrki7JfmwtVHkVfPLlw==", + "version": "1.6.0", + "resolved": "https://registry.npmjs.org/es-module-lexer/-/es-module-lexer-1.6.0.tgz", + "integrity": "sha512-qqnD1yMU6tk/jnaMosogGySTZP8YtUgAffA9nMN+E/rjxcfRQ6IEk7IiozUjgxKoFHBGjTLnrHB/YC45r/59EQ==", "dev": true, "license": "MIT" }, @@ -4131,7 +4141,6 @@ "version": "1.1.2", "resolved": "https://registry.npmjs.org/fastparse/-/fastparse-1.1.2.tgz", "integrity": "sha512-483XLLxTVIwWK3QTrMGRqUfUpoOs/0hbQrl2oz4J0pAcm3A3bu84wxTFqGqkJzewCLdME38xJLJAxBABfQT8sQ==", - "dev": true, "license": "MIT" }, "node_modules/fastq": { @@ -4182,6 +4191,31 @@ "flat": "cli.js" } }, + "node_modules/flyonui": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/flyonui/-/flyonui-1.3.0.tgz", + "integrity": "sha512-JI8Wdnx1owf43o8Ykklk/BZiZd3YCut7bBoU3sACI9V2w5BEVrc+ResvrJj4HYi2saQ9cNtIOCt6ulyB8+RqDA==", + "license": "MIT", + "dependencies": { + "@popperjs/core": "^2.11.8", + "css-selector-tokenizer": "^0.8.0", + "culori": "^4.0.1", + "picocolors": "^1.1.1", + "postcss-js": "^4.0.1" + }, + "engines": { + "node": ">=16.9.0" + } + }, + "node_modules/flyonui/node_modules/culori": { + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/culori/-/culori-4.0.1.tgz", + "integrity": "sha512-LSnjA6HuIUOlkfKVbzi2OlToZE8OjFi667JWN9qNymXVXzGDmvuP60SSgC+e92sd7B7158f7Fy3Mb6rXS5EDPw==", + "license": "MIT", + "engines": { + "node": "^12.20.0 || ^14.13.1 || >=16.0.0" + } + }, "node_modules/for-each": { "version": "0.3.3", "resolved": "https://registry.npmjs.org/for-each/-/for-each-0.3.3.tgz", @@ -5284,9 +5318,9 @@ } }, "node_modules/loupe": { - "version": "3.1.2", - "resolved": "https://registry.npmjs.org/loupe/-/loupe-3.1.2.tgz", - "integrity": "sha512-23I4pFZHmAemUnz8WZXbYRSKYj801VDaNv9ETuMh7IrMc7VuVVSo+Z9iLE3ni30+U48iDWfi30d3twAXBYmnCg==", + "version": "3.1.3", + "resolved": "https://registry.npmjs.org/loupe/-/loupe-3.1.3.tgz", + "integrity": "sha512-kkIp7XSkP78ZxJEsSxW3712C6teJVoeHHwgo9zJ380de7IYyJ2ISlxojcH2pC5OFLewESmnRi/+XCDIEEVyoug==", "dev": true, "license": "MIT" }, @@ -7794,9 +7828,9 @@ } }, "node_modules/vite": { - "version": "5.4.11", - "resolved": "https://registry.npmjs.org/vite/-/vite-5.4.11.tgz", - "integrity": "sha512-c7jFQRklXua0mTzneGW9QVyxFjUgwcihC4bXEtujIo2ouWCe1Ajt/amn2PCxYnhYfd5k09JX3SB7OYWFKYqj8Q==", + "version": "5.4.14", + "resolved": "https://registry.npmjs.org/vite/-/vite-5.4.14.tgz", + "integrity": "sha512-EK5cY7Q1D8JNhSaPKVK4pwBFvaTmZxEnoKXLG/U9gmdDcihQGNzFlgIvaxezFR4glP1LsuiedwMBqCXH3wZccA==", "dev": true, "license": "MIT", "dependencies": { @@ -7854,9 +7888,9 @@ } }, "node_modules/vite-node": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/vite-node/-/vite-node-2.1.6.tgz", - "integrity": "sha512-DBfJY0n9JUwnyLxPSSUmEePT21j8JZp/sR9n+/gBwQU6DcQOioPdb8/pibWfXForbirSagZCilseYIwaL3f95A==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/vite-node/-/vite-node-2.1.9.tgz", + "integrity": "sha512-AM9aQ/IPrW/6ENLQg3AGY4K1N2TGZdR5e4gu/MmmR2xR3Ll1+dib+nook92g4TV3PXVyeyxdWwtaCAiUL0hMxA==", "dev": true, "license": "MIT", "dependencies": { @@ -7864,13 +7898,13 @@ "debug": "^4.3.7", "es-module-lexer": "^1.5.4", "pathe": "^1.1.2", - "vite": "^5.0.0 || ^6.0.0" + "vite": "^5.0.0" }, "bin": { "vite-node": "vite-node.mjs" }, "engines": { - "node": "^18.0.0 || ^20.0.0 || >=22.0.0" + "node": "^18.0.0 || >=20.0.0" }, "funding": { "url": "https://opencollective.com/vitest" @@ -7894,19 +7928,19 @@ } }, "node_modules/vitest": { - "version": "2.1.6", - "resolved": "https://registry.npmjs.org/vitest/-/vitest-2.1.6.tgz", - "integrity": "sha512-isUCkvPL30J4c5O5hgONeFRsDmlw6kzFEdLQHLezmDdKQHy8Ke/B/dgdTMEgU0vm+iZ0TjW8GuK83DiahBoKWQ==", + "version": "2.1.9", + "resolved": "https://registry.npmjs.org/vitest/-/vitest-2.1.9.tgz", + "integrity": "sha512-MSmPM9REYqDGBI8439mA4mWhV5sKmDlBKWIYbA3lRb2PTHACE0mgKwA8yQ2xq9vxDTuk4iPrECBAEW2aoFXY0Q==", "dev": true, "license": "MIT", "dependencies": { - "@vitest/expect": "2.1.6", - "@vitest/mocker": "2.1.6", - "@vitest/pretty-format": "^2.1.6", - "@vitest/runner": "2.1.6", - "@vitest/snapshot": "2.1.6", - "@vitest/spy": "2.1.6", - "@vitest/utils": "2.1.6", + "@vitest/expect": "2.1.9", + "@vitest/mocker": "2.1.9", + "@vitest/pretty-format": "^2.1.9", + "@vitest/runner": "2.1.9", + "@vitest/snapshot": "2.1.9", + "@vitest/spy": "2.1.9", + "@vitest/utils": "2.1.9", "chai": "^5.1.2", "debug": "^4.3.7", "expect-type": "^1.1.0", @@ -7917,24 +7951,24 @@ "tinyexec": "^0.3.1", "tinypool": "^1.0.1", "tinyrainbow": "^1.2.0", - "vite": "^5.0.0 || ^6.0.0", - "vite-node": "2.1.6", + "vite": "^5.0.0", + "vite-node": "2.1.9", "why-is-node-running": "^2.3.0" }, "bin": { "vitest": "vitest.mjs" }, "engines": { - "node": "^18.0.0 || ^20.0.0 || >=22.0.0" + "node": "^18.0.0 || >=20.0.0" }, "funding": { "url": "https://opencollective.com/vitest" }, "peerDependencies": { "@edge-runtime/vm": "*", - "@types/node": "^18.0.0 || ^20.0.0 || >=22.0.0", - "@vitest/browser": "2.1.6", - "@vitest/ui": "2.1.6", + "@types/node": "^18.0.0 || >=20.0.0", + "@vitest/browser": "2.1.9", + "@vitest/ui": "2.1.9", "happy-dom": "*", "jsdom": "*" }, diff --git a/package.json b/package.json index f1472d6a..6d2e6029 100644 --- a/package.json +++ b/package.json @@ -36,6 +36,7 @@ "@nfdi4plants/exceljs": "^0.3.0", "@tailwindcss/container-queries": "^0.1.1", "cytoscape": "^3.27.0", + "flyonui": "^1.3.0", "isomorphic-fetch": "^3.0.0", "jsonschema": "^1.4.1", "pako": "^2.1.0", diff --git a/src/Client/ARCitect/ARCitect.fs b/src/Client/ARCitect/ARCitect.fs deleted file mode 100644 index e262a156..00000000 --- a/src/Client/ARCitect/ARCitect.fs +++ /dev/null @@ -1,64 +0,0 @@ -module ARCitect.ARCitect - -open ARCitect.Interop -open Model -open Model.ARCitect -open Swate.Components.Shared -open Messages -open Elmish -open ARCtrl -open ARCtrl.Json - -let send (msg:ARCitect.Msg) = - let (data: obj) = - match msg with - | Init -> - "Hello from Swate!" - | AssayToARCitect assay -> - let assay = ArcAssay.toJsonString 0 assay - assay - | StudyToARCitect study -> - let json = ArcStudy.toJsonString 0 study - json - | InvestigationToARCitect inv -> - let json = ArcInvestigation.toJsonString 0 inv - json - | RequestPaths selectDirectories -> - selectDirectories - | Error exn -> - exn - postMessageToARCitect(msg, data) - -let EventHandler (dispatch: Messages.Msg -> unit) : IEventHandler = - { - AssayToSwate = fun data -> - let assay = ArcAssay.fromJsonString data.ArcAssayJsonString - log($"Received Assay {assay.Identifier} from ARCitect!") - Spreadsheet.InitFromArcFile (ArcFiles.Assay assay) |> SpreadsheetMsg |> dispatch - StudyToSwate = fun data -> - let study = ArcStudy.fromJsonString data.ArcStudyJsonString - Spreadsheet.InitFromArcFile (ArcFiles.Study (study, [])) |> SpreadsheetMsg |> dispatch - log($"Received Study {study.Identifier} from ARCitect!") - InvestigationToSwate = fun data -> - let inv = ArcInvestigation.fromJsonString data.ArcInvestigationJsonString - Spreadsheet.InitFromArcFile (ArcFiles.Investigation inv) |> SpreadsheetMsg |> dispatch - log($"Received Investigation {inv.Title} from ARCitect!") - PathsToSwate = fun paths -> - log $"Received {paths.paths.Length} paths from ARCitect!" - FilePicker.LoadNewFiles (List.ofArray paths.paths) |> FilePickerMsg |> dispatch - Error = fun exn -> - GenericError (Cmd.none, exn) |> DevMsg |> dispatch - } - - -let subscription (initial: Model) : (SubId * Subscribe) list = - let subscription (dispatch: Messages.Msg -> unit) : System.IDisposable = - let rmv = ARCitect.Interop.initEventListener (EventHandler dispatch) - { new System.IDisposable with - member _.Dispose() = rmv() - } - [ - // Only subscribe to ARCitect messages when host is set correctly via query param. - if initial.PersistentStorageState.Host = Some (Swatehost.ARCitect) then - ["ARCitect"], subscription - ] diff --git a/src/Client/ARCitect/Interop.fs b/src/Client/ARCitect/Interop.fs deleted file mode 100644 index 72f6604a..00000000 --- a/src/Client/ARCitect/Interop.fs +++ /dev/null @@ -1,53 +0,0 @@ -module ARCitect.Interop - -open Fable.Core.JsInterop -open Model.ARCitect - -let inline getUnionCaseName (x:'a) = - match Microsoft.FSharp.Reflection.FSharpValue.GetUnionFields(x, typeof<'a>) with - | case, _ -> case.Name - -let inline getEventHandlerByName (inst: 'A) (s:string) = - let fields = Microsoft.FSharp.Reflection.FSharpType.GetRecordFields(typeof<'A>) - match fields |> Array.tryFind(fun t -> t.Name = s) with - | Some pi -> Some(pi.GetValue(inst)) - | None -> None - -let verifyARCitectMsg (e: Browser.Types.MessageEvent) = - let content = e.data :?> {|swate: bool; api: string; data: obj|} - let source = e.source - if content.swate (*check source*) then - Some content - else - None - -let inline runApiFromName (apiHandler: 'E) (apiName: string) (data: 'A) = - let func = getEventHandlerByName apiHandler apiName - match func with - | Some f -> - let f: 'A -> unit = !!f - f data - | None -> - () - -let inline postMessageToARCitect (msg: 'A, data) = - let methodName = getUnionCaseName msg - let createContent (data) = {|swate = true; api = methodName; data = data|} - Browser.Dom.window.parent.postMessage(createContent data, "*") - -/// -/// Returns a function to remove the event listener -/// -/// -let initEventListener (eventHandler: IEventHandler) : unit -> unit = - let handle = - fun (e: Browser.Types.Event) -> - let e = e :?> Browser.Types.MessageEvent - match verifyARCitectMsg e with - | Some content -> - log ("Message from ARCitect: " + content.api) - runApiFromName eventHandler content.api content.data - | None -> - () - Browser.Dom.window.addEventListener("message", handle) - fun () -> Browser.Dom.window.removeEventListener("message", handle) \ No newline at end of file diff --git a/src/Client/App.fs b/src/Client/App.fs index 83bfff00..0e3a79fa 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -10,6 +10,29 @@ open Fable.Core.JsInterop importSideEffects "./tailwindstyle.scss" +module Subscriptions = + + let private ARCitectInAPI (dispatch: Messages.Msg -> unit) : Model.ARCitect.Interop.IARCitectInAPI = { + TestHello = fun name -> promise { return sprintf "Hello %s" name } + ResponsePaths = fun paths -> + promise { + Model.ARCitect.ResponsePaths paths |> Messages.ARCitectMsg |> dispatch + return true + } + } + + let subscription (initial: Model.Model) : (SubId * Subscribe) list = + let arcitect (dispatch: Messages.Msg -> unit) : System.IDisposable = + let initEventHandler = + MessageInterop.MessageInterop.createApi() + |> MessageInterop.MessageInterop.buildInProxy (ARCitectInAPI dispatch) + { new System.IDisposable with + member _.Dispose() = initEventHandler() + } + [ + ["ARCitect"], arcitect + ] + #if DEBUG open Elmish.HMR #endif @@ -18,7 +41,7 @@ Program.mkProgram Init.init Update.Update.update Index.View #if DEBUG |> Program.withConsoleTrace #endif -|> Program.withSubscription ARCitect.ARCitect.subscription +|> Program.withSubscription Subscriptions.subscription |> Program.toNavigable (parsePath Routing.Routing.route) Update.Update.urlUpdate |> Program.withReactBatched "elmish-app" |> Program.run diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index 0a8316eb..0a5cf86d 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -10,9 +10,11 @@ + + @@ -37,8 +39,6 @@ - - @@ -125,6 +125,7 @@ + diff --git a/src/Client/Init.fs b/src/Client/Init.fs index 547810c4..2709af62 100644 --- a/src/Client/Init.fs +++ b/src/Client/Init.fs @@ -22,6 +22,7 @@ let initialModel = DataAnnotatorModel = DataAnnotator.Model .init() SpreadsheetModel = Spreadsheet.Model .init() History = LocalHistory.Model .init() + ARCitectState = ARCitect.Model .init() ModalState = ModalState .init() } diff --git a/src/Client/MainComponents/Navbar.fs b/src/Client/MainComponents/Navbar.fs index 2f316e0b..dd0f3def 100644 --- a/src/Client/MainComponents/Navbar.fs +++ b/src/Client/MainComponents/Navbar.fs @@ -79,12 +79,14 @@ let private QuickAccessButtonListEnd (model: Model) dispatch = Html.i [prop.className "fa-solid fa-floppy-disk";] ], (fun _ -> - Spreadsheet.ManualSave |> SpreadsheetMsg |> dispatch match model.PersistentStorageState.Host with | Some (Swatehost.Browser) -> Spreadsheet.ExportXlsx model.SpreadsheetModel.ArcFile.Value |> SpreadsheetMsg |> dispatch + | Some (Swatehost.ARCitect) -> + ARCitect.Save model.SpreadsheetModel.ArcFile.Value |> ARCitectMsg |> dispatch | _ -> () - ) + ), + isDisabled = model.SpreadsheetModel.ArcFile.IsNone ) match model.PersistentStorageState.Host with | Some Swatehost.Browser -> diff --git a/src/Client/Messages.fs b/src/Client/Messages.fs index c9c44ef1..e0db86b2 100644 --- a/src/Client/Messages.fs +++ b/src/Client/Messages.fs @@ -118,6 +118,7 @@ type Msg = | ProtocolMsg of Protocol.Msg | DataAnnotatorMsg of DataAnnotator.Msg | SpreadsheetMsg of Spreadsheet.Msg +| ARCitectMsg of ARCitect.Msg /// This is used to forward Msg to SpreadsheetMsg/OfficeInterop | InterfaceMsg of SpreadsheetInterface.Msg | PageStateMsg of PageState.Msg diff --git a/src/Client/Model.fs b/src/Client/Model.fs index 680b3e2b..cab4519f 100644 --- a/src/Client/Model.fs +++ b/src/Client/Model.fs @@ -288,5 +288,6 @@ type Model = { /// Contains all information about spreadsheet view SpreadsheetModel : Spreadsheet.Model History : LocalHistory.Model + ARCitectState : ARCitect.Model ModalState : ModalState } \ No newline at end of file diff --git a/src/Client/Pages/FilePicker/FilePickerView.fs b/src/Client/Pages/FilePicker/FilePickerView.fs index a2107fc7..b8dbb5ea 100644 --- a/src/Client/Pages/FilePicker/FilePickerView.fs +++ b/src/Client/Pages/FilePicker/FilePickerView.fs @@ -58,7 +58,7 @@ let uploadButton (model: Model) dispatch (parentContainerResizeClass: string) = button.primary button.block prop.onClick(fun _ -> - ARCitect.RequestPaths false |> ARCitect.ARCitect.send + Start false |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch ) prop.text "Pick Files" ] @@ -66,7 +66,7 @@ let uploadButton (model: Model) dispatch (parentContainerResizeClass: string) = button.primary button.block prop.onClick(fun _ -> - ARCitect.RequestPaths true |> ARCitect.ARCitect.send + Start true |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch ) prop.text "Pick Directories" ] @@ -229,7 +229,16 @@ let fileContainer (model:Model) dispatch = insertButton model dispatch ] -let filePickerComponent (model:Model) (dispatch:Messages.Msg -> unit) = +[] +let Main (model:Model) (dispatch:Messages.Msg -> unit) = + + React.useEffect ( + (fun _ -> + model.ARCitectState.Paths |> List.ofArray |> LoadNewFiles |> FilePickerMsg |> dispatch + ), + [|box model.ARCitectState.Paths|] + ) + SidebarComponents.SidebarLayout.Container [ SidebarComponents.SidebarLayout.Header "File Picker" diff --git a/src/Client/Routing.fs b/src/Client/Routing.fs index 6e86f948..86ca1e87 100644 --- a/src/Client/Routing.fs +++ b/src/Client/Routing.fs @@ -3,24 +3,6 @@ module Routing open Elmish.UrlParser open Feliz -[] -module Host = - - [] - type Swatehost = - | Browser - | Excel - | ARCitect - with - static member ofQueryParam (queryInteger: int option) = - match queryInteger with - | Some 1 -> Swatehost.ARCitect - | Some 2 -> Swatehost.Excel - | _ -> Browser - - member this.IsStandalone = - this = Swatehost.Browser || this = Swatehost.ARCitect - [] type SidebarPage = | BuildingBlock diff --git a/src/Client/States/ARCitect.fs b/src/Client/States/ARCitect.fs index 759b757b..d88528df 100644 --- a/src/Client/States/ARCitect.fs +++ b/src/Client/States/ARCitect.fs @@ -1,19 +1,62 @@ -module Model.ARCitect +module Model.ARCitect open ARCtrl +open Fable.Core + +module Interop = + + [] + module InteropTypes = + + /// StringEnum to make it a simple string in js world + [] + [] + type ARCFile = + | Investigation + | Study + | Assay + | Template + + type IARCitectOutAPI = { + Init: unit -> JS.Promise + Save: InteropTypes.ARCFile * string -> JS.Promise + RequestPaths: bool -> JS.Promise + /// returns person jsons + RequestPersons: unit -> JS.Promise + } + + type IARCitectInAPI = { + TestHello: string -> JS.Promise + /// JS.Promise + ResponsePaths: string [] -> JS.Promise + } + + +let api = + MessageInterop.MessageInterop.createApi() + |> MessageInterop.MessageInterop.buildOutProxy + +open Elmish type Msg = - | Init - | Error of exn - | RequestPaths of selectDirectories: bool - | AssayToARCitect of ArcAssay - | StudyToARCitect of ArcStudy - | InvestigationToARCitect of ArcInvestigation - -type IEventHandler = { - Error: exn -> unit - AssayToSwate : {| ArcAssayJsonString: string |} -> unit - StudyToSwate : {| ArcStudyJsonString: string |} -> unit - InvestigationToSwate : {| ArcInvestigationJsonString: string |} -> unit - PathsToSwate : {| paths: string [] |} -> unit -} \ No newline at end of file + | Init of ApiCall + | Save of ArcFiles + /// ApiCall + | RequestPaths of ApiCall + /// Selecting paths requires user input, which we cannot await. + /// To avoid timeout `RequestPaths` simply returns true if call was successful, + /// ... and `ResponsePaths` will be sent as soon as user selected the directories + | ResponsePaths of string [] + /// expects person jsons + | RequestPersons of ApiCall + +type Model = + { + Paths: string [] + Persons: Person [] + } + + static member init() = { + Paths = [||]; + Persons = [||] + } \ No newline at end of file diff --git a/src/Client/States/Spreadsheet.fs b/src/Client/States/Spreadsheet.fs index 59d2f1fd..2363101b 100644 --- a/src/Client/States/Spreadsheet.fs +++ b/src/Client/States/Spreadsheet.fs @@ -153,7 +153,6 @@ type Key = type Msg = -| ManualSave // <--> UI <--> | UpdateState of Model | UpdateCell of (int*int) * CompositeCell diff --git a/src/Client/Update.fs b/src/Client/Update.fs index eb77986d..c03dd520 100644 --- a/src/Client/Update.fs +++ b/src/Client/Update.fs @@ -328,6 +328,11 @@ let update (msg : Msg) (model : Model) : Model * Cmd = let nextModel, nextCmd = History.update msg currentModel nextModel, nextCmd + | ARCitectMsg msg -> + let nextState, nextModel0, nextCmd = ARCitect.update model.ARCitectState currentModel msg + let nextModel = {nextModel0 with ARCitectState = nextState} + nextModel, nextCmd + /// This function is used to determine which msg should be logged to activity log. /// The function is exception based, so msg which should not be logged needs to be added here. let matchMsgToLog (msg: Msg) = diff --git a/src/Client/Update/ARCitectUpdate.fs b/src/Client/Update/ARCitectUpdate.fs new file mode 100644 index 00000000..268c743a --- /dev/null +++ b/src/Client/Update/ARCitectUpdate.fs @@ -0,0 +1,102 @@ +namespace Update + +open Elmish + +open Messages +open OfficeInterop +open OfficeInterop.Core +open Model + +module ARCitect = + + open ARCtrl + open ARCtrl.Json + + let api = Model.ARCitect.api + + let update (state: ARCitect.Model) (model:Model.Model) (msg: ARCitect.Msg) : ARCitect.Model * Model * Cmd = + match msg with + | ARCitect.Init msg -> + match msg with + | Start () -> + let cmd = + Cmd.OfPromise.either + api.Init + () + (Finished >> ARCitect.Init >> ARCitectMsg) + (curry GenericError Cmd.none >> DevMsg) + state, model, cmd + | ApiCall.Finished (arcFile, json) -> + let resolvedArcFile = + match arcFile with + | ARCitect.Interop.InteropTypes.ARCFile.Assay -> + let assay = ArcAssay.fromJsonString json + ArcFiles.Assay assay + | ARCitect.Interop.InteropTypes.ARCFile.Study -> + let study = ArcStudy.fromJsonString json + ArcFiles.Study (study, []) + | ARCitect.Interop.InteropTypes.ARCFile.Investigation -> + let inv = ArcInvestigation.fromJsonString json + ArcFiles.Investigation inv + | ARCitect.Interop.InteropTypes.ARCFile.Template -> + let template = Template.fromJsonString json + ArcFiles.Template template + let cmd = Spreadsheet.InitFromArcFile resolvedArcFile |> SpreadsheetMsg |> Cmd.ofMsg + state, model, cmd + + | ARCitect.Save arcFile -> + let arcFileEnum, json = + match arcFile with + | ArcFiles.Assay assay -> + ARCitect.Interop.InteropTypes.ARCFile.Assay, ArcAssay.toJsonString 0 assay + | ArcFiles.Study (study, _) -> + ARCitect.Interop.InteropTypes.ARCFile.Study, ArcStudy.toJsonString 0 study + | ArcFiles.Investigation inv -> + ARCitect.Interop.InteropTypes.ARCFile.Investigation, ArcInvestigation.toJsonString 0 inv + | ArcFiles.Template template -> + ARCitect.Interop.InteropTypes.ARCFile.Template, Template.toJsonString 0 template + let cmd = + Cmd.OfPromise.attempt + api.Save + (arcFileEnum, json) + (curry GenericError Cmd.none >> DevMsg) + state, model, cmd + + | ARCitect.RequestPaths msg -> + match msg with + | Start selectDirectories -> + let cmd = + Cmd.OfPromise.either + api.RequestPaths + (selectDirectories) + (Finished >> ARCitect.RequestPaths >> ARCitectMsg) + (curry GenericError Cmd.none >> DevMsg) + state, model, cmd + | ApiCall.Finished (wasSuccessful: bool) -> + let cmd = + if wasSuccessful then + Cmd.none + else + GenericError (Cmd.none, exn("RequestPaths failed")) |> DevMsg |> Cmd.ofMsg + state, model, cmd + + | ARCitect.ResponsePaths paths -> + {state with Paths = paths}, model, Cmd.none + + | ARCitect.RequestPersons msg -> + match msg with + | Start () -> + let cmd = + Cmd.OfPromise.either + api.RequestPersons + () + (Finished >> ARCitect.RequestPersons >> ARCitectMsg) + (curry GenericError Cmd.none >> DevMsg) + state, model, cmd + | ApiCall.Finished persons -> + let personsResolved = + persons + |> Array.map (fun personJson -> + Person.fromJsonString personJson + ) + {state with Persons = personsResolved}, model, Cmd.none \ No newline at end of file diff --git a/src/Client/Update/InterfaceUpdate.fs b/src/Client/Update/InterfaceUpdate.fs index 71732dd9..01e24e2c 100644 --- a/src/Client/Update/InterfaceUpdate.fs +++ b/src/Client/Update/InterfaceUpdate.fs @@ -98,21 +98,17 @@ module Interface = match msg with | Initialize host -> let cmd = - Cmd.batch [ - match host with - | Swatehost.Excel -> - ExcelHelper.officeload() |> Async.StartImmediate - Cmd.none - | Swatehost.Browser -> - Spreadsheet.Model.initHistoryIndexedDB() |> Promise.start - Cmd.none - | Swatehost.ARCitect -> - Cmd.ofEffect (fun _ -> - LocalHistory.Model.ResetHistoryWebStorage() - Spreadsheet.Model.initHistoryIndexedDB() |> Promise.start - ARCitect.ARCitect.send ARCitect.Init - ) - ] + match host with + | Swatehost.Excel -> + ExcelHelper.officeload() |> Async.StartImmediate + Cmd.none + | Swatehost.Browser -> + Spreadsheet.Model.initHistoryIndexedDB() |> Promise.start + Cmd.none + | Swatehost.ARCitect -> + LocalHistory.Model.ResetHistoryWebStorage() + Spreadsheet.Model.initHistoryIndexedDB() |> Promise.start + Start() |> ARCitect.Init |> ARCitectMsg |> Cmd.ofMsg /// Updates from local storage if standalone in browser let nextModel = model.UpdateFromLocalStorage() nextModel, cmd @@ -295,7 +291,7 @@ module Interface = let distinct = deselectedColumns |> Array.distinct let cmd = if distinct.Length <> 1 then - let msg = Failure("Please select one column only if you want to use `Remove Building Block`.") + let msg = exn "Please select one column only if you want to use `Remove Building Block`." GenericError (Cmd.none,msg) |> DevMsg |> Cmd.ofMsg else Spreadsheet.DeleteColumn (distinct.[0]) |> SpreadsheetMsg |> Cmd.ofMsg diff --git a/src/Client/Update/SpreadsheetUpdate.fs b/src/Client/Update/SpreadsheetUpdate.fs index 58ae3c0e..8946a4da 100644 --- a/src/Client/Update/SpreadsheetUpdate.fs +++ b/src/Client/Update/SpreadsheetUpdate.fs @@ -16,21 +16,6 @@ module Spreadsheet = module Helper = - let fullSaveModel (state: Spreadsheet.Model) (model:Model) = - let snapshotJsonString = state.ToJsonString() - Spreadsheet.Model.SaveToLocalStorage(snapshotJsonString) // This will cache the most up to date table state to local storage. - let nextHistory = model.History.SaveSessionSnapshot state // this will cache the table state for certain operations in session storage. - if model.PersistentStorageState.Host = Some Swatehost.ARCitect then - match state.ArcFile with // model is not yet updated at this position. - | Some (Assay assay) -> - ARCitect.ARCitect.send(ARCitect.AssayToARCitect assay) - | Some (Study (study,_)) -> - ARCitect.ARCitect.send(ARCitect.StudyToARCitect study) - | Some (Investigation inv) -> - ARCitect.ARCitect.send(ARCitect.InvestigationToARCitect inv) - | _ -> () - () - /// /// This function will store the information correctly. /// Can return save information to local storage (persistent between browser sessions) and session storage. @@ -65,11 +50,21 @@ module Spreadsheet = if model.PersistentStorageState.Host = Some Swatehost.ARCitect then match state.ArcFile with // model is not yet updated at this position. | Some (Assay assay) -> - ARCitect.ARCitect.send(ARCitect.AssayToARCitect assay) + let json = assay.ToJsonString() + ARCitect.api.Save(ARCitect.Interop.InteropTypes.ARCFile.Assay, json) + |> Promise.start | Some (Study (study,_)) -> - ARCitect.ARCitect.send(ARCitect.StudyToARCitect study) + let json = study.ToJsonString() + ARCitect.api.Save(ARCitect.Interop.InteropTypes.ARCFile.Study, json) + |> Promise.start | Some (Investigation inv) -> - ARCitect.ARCitect.send(ARCitect.InvestigationToARCitect inv) + let json = inv.ToJsonString() + ARCitect.api.Save(ARCitect.Interop.InteropTypes.ARCFile.Investigation, json) + |> Promise.start + | Some (Template template) -> + let json = template.toJsonString() + ARCitect.api.Save(ARCitect.Interop.InteropTypes.ARCFile.Template, json) + |> Promise.start | _ -> () state, model, newCmd @@ -91,9 +86,6 @@ module Spreadsheet = let innerUpdate (state: Spreadsheet.Model) (model: Model) (msg: Spreadsheet.Msg) = match msg with - | ManualSave -> - Helper.fullSaveModel state model - state, model, Cmd.none | UpdateState nextState -> nextState, model, Cmd.none | UpdateDatamap datamapOption -> diff --git a/src/Client/Util/ElmishHelper.fs b/src/Client/Util/ElmishHelper.fs new file mode 100644 index 00000000..ae2dd3a3 --- /dev/null +++ b/src/Client/Util/ElmishHelper.fs @@ -0,0 +1,13 @@ +[] +module ElmishHelper + +module Elmish = + + type ApiCallWithFail<'s,'f> = + | Start of 's + | Finished of 'f + | Failed of exn + + type ApiCall<'s,'f> = + | Start of 's + | Finished of 'f diff --git a/src/Client/Util/MessageInterop.fs b/src/Client/Util/MessageInterop.fs index 90914cea..8d7b28f0 100644 --- a/src/Client/Util/MessageInterop.fs +++ b/src/Client/Util/MessageInterop.fs @@ -15,12 +15,17 @@ type private IMessagePayload = {| /// 2. If PendingRequests contains the requestId, the message is a request. /// Only if both conditions are met, Swate sends a response. api: string option - requestId: string option + requestId: string data: obj option error: string option |} -type PendingRequests = Dictionary unit) * (exn -> unit)> +type private PendingRequests = Dictionary unit) * (exn -> unit)> + +/// This serves as container for queries. +/// Might be a good idea to use NanoStores: https://github.com/nanostores/nanostores ... +/// ... or to integrate within elmish. +let private PendingRequests = PendingRequests() type InteropOptions = { Target: Browser.Types.Window @@ -32,23 +37,24 @@ open Fable.Core open Fable.SimpleJson open Browser.Types -module private Helper = - let private sendMsgWithResponse (pendingRequestsDictionary: PendingRequests) (target: Browser.Types.Window) (payload: IMessagePayload) = +module MessageInteropHelper = + + let private sendMsgWithResponse (target: Browser.Types.Window) (payload: IMessagePayload) = Promise.create (fun resolve reject -> // create timeout for response let timeout = Fable.Core.JS.setTimeout (fun () -> - pendingRequestsDictionary.Remove(payload.requestId.Value) |> ignore + PendingRequests.Remove(payload.requestId) |> ignore reject (new TimeoutException("Request timed out")) ) 5000 - pendingRequestsDictionary.Add(payload.requestId.Value, (resolve, reject)) + PendingRequests.Add(payload.requestId, (resolve, reject)) target.postMessage(payload, "*") ) - let rec getReturnType typ = + let rec private getReturnType typ = if Reflection.FSharpType.IsFunction typ then let _, res = Reflection.FSharpType.GetFunctionElements typ getReturnType res @@ -57,56 +63,38 @@ module private Helper = else typ - let proxyCall (target: Browser.Types.Window) (func: RecordField) pendingRequestsDictionary = - let funcArgs : (TypeInfo [ ]) = + let private proxyCall (target: Browser.Types.Window) (func: RecordField) = + + let argumentType : TypeInfo = match func.FieldType with - | TypeInfo.Func getArgs -> getArgs() + | TypeInfo.Func getArgs -> + match getArgs() with + | [| _ as typeInfo; TypeInfo.Promise _ |] -> + typeInfo + | anyElse -> + failwithf "MessageInterop-Error: Only Promise return types with 1 argument are supported for outgoing messages: %A" anyElse | _ -> failwithf "MessageInterop-Error: Field %s does not have a valid definiton" func.FieldName - let argumentCount = (Array.length funcArgs) - 1 - let returnTypeAsync = Array.last funcArgs - - let funcNeedParameters = - match funcArgs with - | [| TypeInfo.Async _ |] -> false - | [| TypeInfo.Promise _ |] -> false - | [| TypeInfo.Unit; TypeInfo.Async _ |] -> false - | otherwise -> true - let executeRequest = - let returnType = - match returnTypeAsync with - | TypeInfo.Promise getPromiseTypeArgument -> getPromiseTypeArgument() - | _ -> failwithf "MessageInterop-Error:: Expected field %s to have a return type of Async<'t> or Task<'t>" func.FieldName - fun requestBody -> sendMsgWithResponse pendingRequestsDictionary target requestBody + fun requestBody -> + sendMsgWithResponse target requestBody + + fun arg0 -> - fun arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 -> - let inputArguments = - if funcNeedParameters - then Array.take argumentCount [| box arg0;box arg1;box arg2;box arg3; box arg4; box arg5; box arg6; box arg7 |] - else [| |] + let data: obj[] = + match argumentType with + | TypeInfo.Unit -> [||] + | TypeInfo.Tuple _ -> arg0 + | _ -> [|arg0|] let requestBody: IMessagePayload = - {| swate = true; api = Some func.FieldName; data = Some inputArguments; requestId = Some (System.Guid.NewGuid().ToString()); error = None |} + {| swate = true; api = Some func.FieldName; data = Some data; requestId = System.Guid.NewGuid().ToString(); error = None |} executeRequest requestBody -module MessageInterop = - - let createApi() : InteropOptions = { - Target = Browser.Dom.window.parent - GenericErrorHandler = fun exn -> Browser.Dom.console.log($"Proxy Error: {exn.Message}") - } - - let withErrorHandler errorHandler options : InteropOptions = { options with GenericErrorHandler = errorHandler } - - let withTarget target options : InteropOptions = { options with Target = target } - -type MessageInterop() = - - // Function to generate a new instance dynamically - static member buildOutProxy (target: Browser.Types.Window, resolvedType: Type, pendingRequestsDictionary: PendingRequests) : 'T = + // Function to generate a new instance dynamically + let buildOutProxyInner (target: Browser.Types.Window, resolvedType: Type) : 'T = if not (FSharpType.IsRecord resolvedType) then failwithf "MessageInterop-Error: Provided type is not a record. %s" resolvedType.FullName @@ -118,39 +106,17 @@ type MessageInterop() = let recordFields = [| for field in fields do let normalize n = - let fn = Helper.proxyCall target field pendingRequestsDictionary + let fn = proxyCall target field // this match case comes from Fable.Remoting // https://github.com/Zaid-Ajaj/Fable.Remoting/blob/9bf4dab1987abad342c671cb4ff1a8a7e0e846d0/Fable.Remoting.Client/Remoting.fs#L58 // I cannot trigger any case other than 1 arguments, as all record type arguments are parsed into a tuple match n with | 0 -> - box (fn null null null null null null null null) + box (fn null) | 1 -> - box (fun a -> - fn a null null null null null null null) - | 2 -> - let proxyF a b = fn a b null null null null null null - unbox (System.Func<_,_,_> proxyF) - | 3 -> - let proxyF a b c = fn a b c null null null null null - unbox (System.Func<_,_,_,_> proxyF) - | 4 -> - let proxyF a b c d = fn a b c d null null null null - unbox (System.Func<_,_,_,_,_> proxyF) - | 5 -> - let proxyF a b c d e = fn a b c d e null null null - unbox (System.Func<_,_,_,_,_,_> proxyF) - | 6 -> - let proxyF a b c d e f = fn a b c d e f null null - unbox (System.Func<_,_,_,_,_,_,_> proxyF) - | 7 -> - let proxyF a b c d e f g = fn a b c d e f g null - unbox (System.Func<_,_,_,_,_,_,_,_> proxyF) - | 8 -> - let proxyF a b c d e f g h = fn a b c d e f g h - unbox (System.Func<_,_,_,_,_,_,_,_,_> proxyF) + box (fun a -> fn a) | _ -> - failwithf "MessageInterop-Error: Cannot generate proxy function for %s. Only up to 8 arguments are supported. Consider using a record type as input" field.FieldName + failwithf "MessageInterop-Error: Cannot generate proxy function for %s. Only up to 1 argument is supported. Consider using a record type as input" field.FieldName let argumentCount = match field.FieldType with @@ -167,7 +133,7 @@ type MessageInterop() = | _ -> failwithf "MessageInterop-Error: Cannot build proxy. Exepected type %s to be a valid protocol definition which is a record of functions" resolvedType.FullName - static member buildInProxy(recordType, recordTypeType: Type, target: Browser.Types.Window, handleGenericError, pendingRequestsDictionary: PendingRequests) = + let buildInProxyInner(recordType: 'i, recordTypeType: Type, target: Browser.Types.Window, handleGenericError) = let schemaType = createTypeInfo recordTypeType match schemaType with @@ -218,11 +184,12 @@ type MessageInterop() = try promise { let! r = runApiFromName apiHandler api content.data - return {| content with data = Some r|} + let p: IMessagePayload = {| content with data = Some !!r|} + return p } with | exn -> - let p: IMessagePayload = {| content with error = Some exn.Message; data = None|} + let p: IMessagePayload = {| content with error = Some exn.Message; data = None |} Promise.lift p |> Promise.map (fun (payload: IMessagePayload) -> let result: IMessagePayload = {| payload with api = None |} @@ -244,32 +211,45 @@ type MessageInterop() = | Some content -> if content.error.IsSome then let exn = new Exception(content.error.Value) - match pendingRequestsDictionary.TryGetValue(content.requestId.Value) with + match PendingRequests.TryGetValue(content.requestId) with | true, (_, reject) -> - pendingRequestsDictionary.Remove(content.requestId.Value) |> ignore + PendingRequests.Remove(content.requestId) |> ignore reject exn | _ -> handleGenericError exn - elif content.requestId.IsSome then - match pendingRequestsDictionary.TryGetValue(content.requestId.Value) with + else + match PendingRequests.TryGetValue(content.requestId) with | true, (resolve, _) -> - log "[Swate] response from ARCitect" - pendingRequestsDictionary.Remove(content.requestId.Value) |> ignore + log $"[Swate] Response from ARCitect" + PendingRequests.Remove(content.requestId) |> ignore resolve content.data | _ -> - log "[Swate] request from ARCitect" + log $"[Swate] Request from ARCitect: {content.api}" resolveIncMessage recordType content - else - log "MessageInterop-Warning: Unhandled ARCitect msg" | None -> () Browser.Dom.window.addEventListener("message", handle) fun () -> Browser.Dom.window.removeEventListener("message", handle) - - static member inline buildProxy<'o, 'i> (incomingMsgHandler: 'i) (options: InteropOptions) : 'o * (unit -> unit) = - let PendingRequests = PendingRequests() - let inType = typeof<'i> + +module MessageInterop = + + let createApi() : InteropOptions = { + Target = Browser.Dom.window.parent + GenericErrorHandler = fun exn -> Browser.Dom.console.error($"Proxy Error: {exn.Message}") + } + + let withErrorHandler errorHandler options : InteropOptions = { options with GenericErrorHandler = errorHandler } + + let withTarget target options : InteropOptions = { options with Target = target } + +type MessageInterop() = + + static member inline buildOutProxy<'o> (options: InteropOptions) : 'o = let outType = typeof<'o> - MessageInterop.buildOutProxy(options.Target, outType, PendingRequests), - MessageInterop.buildInProxy(incomingMsgHandler, inType, options.Target, options.GenericErrorHandler, PendingRequests) + MessageInteropHelper.buildOutProxyInner(options.Target, outType) + + /// Returns a function to remove the event listener + static member inline buildInProxy<'i> (incomingMsgHandler: 'i) (options: InteropOptions) : (unit -> unit) = + let inType: Type = typeof<'i> + MessageInteropHelper.buildInProxyInner(incomingMsgHandler, inType, options.Target, options.GenericErrorHandler) diff --git a/src/Client/Util/SwateHost.fs b/src/Client/Util/SwateHost.fs new file mode 100644 index 00000000..52ccbde2 --- /dev/null +++ b/src/Client/Util/SwateHost.fs @@ -0,0 +1,18 @@ +[] +module Host + +[] +type Swatehost = +| Browser +| Excel +| ARCitect +with + static member ofQueryParam (queryInteger: int option) = + match queryInteger with + | Some 1 -> Swatehost.ARCitect + | Some 2 -> Swatehost.Excel + | _ -> Browser + + member this.IsStandalone = + this = Swatehost.Browser || this = Swatehost.ARCitect + diff --git a/src/Client/Views/SidebarView.fs b/src/Client/Views/SidebarView.fs index ac3385af..d590136a 100644 --- a/src/Client/Views/SidebarView.fs +++ b/src/Client/Views/SidebarView.fs @@ -22,7 +22,7 @@ type SidebarView = TermSearch.Main (model, dispatch) | {SidebarPage = Routing.SidebarPage.FilePicker } -> - FilePicker.filePickerComponent model dispatch + FilePicker.Main model dispatch | {SidebarPage = Routing.SidebarPage.Protocol } -> Protocol.Templates.Main (model, dispatch) diff --git a/src/Client/tailwind.config.js b/src/Client/tailwind.config.js index 514eb3ca..8ae70a39 100644 --- a/src/Client/tailwind.config.js +++ b/src/Client/tailwind.config.js @@ -4,6 +4,7 @@ module.exports = { content: [ "./index.html", "./**/*.{fs,js,ts,jsx,tsx}", +/* '../../node_modules/flyonui/dist/js/*.js',*/ ], daisyui: { themes: [ @@ -48,6 +49,8 @@ module.exports = { require('@tailwindcss/container-queries'), require('@tailwindcss/typography'), require('daisyui'), + //require('flyonui'), + //require('flyonui/plugin') ], darkMode: ['selector', '[data-theme="dark"]'] } From 70d0ff3067c5d2239c2c124382eb4679a97f3d12 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Thu, 20 Feb 2025 16:05:16 +0100 Subject: [PATCH 04/11] Allow import of persons from ARC #555 #429 :sparkles: --- src/Client/Model.fs | 5 + src/Client/SharedComponents/Metadata/Assay.fs | 1 + src/Client/SharedComponents/Metadata/Forms.fs | 175 +++++++++++++++--- .../Metadata/Investigation.fs | 1 + src/Client/SharedComponents/Metadata/Study.fs | 1 + .../SharedComponents/Metadata/Template.fs | 2 +- src/Client/Types.fs | 9 + 7 files changed, 167 insertions(+), 27 deletions(-) diff --git a/src/Client/Model.fs b/src/Client/Model.fs index cab4519f..13235c49 100644 --- a/src/Client/Model.fs +++ b/src/Client/Model.fs @@ -95,6 +95,11 @@ type PersistentStorageState = { Autosave = true } + member this.IsARCitect = + match this.Host with + | Some Swatehost.ARCitect -> true + | _ -> false + member this.TIBQueries = {| TermSearch = ResizeArray [ diff --git a/src/Client/SharedComponents/Metadata/Assay.fs b/src/Client/SharedComponents/Metadata/Assay.fs index 043af3f4..41ca7ff8 100644 --- a/src/Client/SharedComponents/Metadata/Assay.fs +++ b/src/Client/SharedComponents/Metadata/Assay.fs @@ -53,6 +53,7 @@ let Main(assay: ArcAssay, setArcAssay: ArcAssay -> unit, setDatamap: ArcAssay -> (fun persons -> assay.Performers <- persons setArcAssay assay), + model.PersistentStorageState.IsARCitect, "Performers" ) FormComponents.CommentsInput( diff --git a/src/Client/SharedComponents/Metadata/Forms.fs b/src/Client/SharedComponents/Metadata/Forms.fs index a46e37db..83a26956 100644 --- a/src/Client/SharedComponents/Metadata/Forms.fs +++ b/src/Client/SharedComponents/Metadata/Forms.fs @@ -17,13 +17,6 @@ open Swate.Components.Shared module private API = - [] - type Request<'A> = - | Ok of 'A - | Error of exn - | Loading - | Idle - module Null = let defaultValue (def:'A) (x:'A) = if isNull x then def else x @@ -218,6 +211,82 @@ module private Helper = ] ] + let PersonsModal (existingPersons: ResizeArray, externalPersons: Person [], select: Person -> unit, back) = + Daisy.modal.div [ + modal.active + prop.children [ + Daisy.modalBackdrop [] + Daisy.modalBox.div [ + prop.className "max-h-[80%] overflow-y-hidden flex flex-col space-y-2" + prop.children [ + Html.div [ + prop.className "space-y-2 overflow-y-auto max-h-fit overflow-x-auto" + prop.children [ + Html.table [ + prop.className "table" + prop.children [ + Html.thead [ + Html.tr [ + Html.th [] // Select + Html.th "Name" + Html.th "Affiliation" + Html.th "Orcid" + Html.th "Address" + Html.th "Contact" + Html.th "Roles" + Html.th "Comments" + ] + ] + Html.tbody [ + for person in externalPersons do + let isSelected = existingPersons |> Seq.exists (fun x -> x.Equals person) + Html.tr [ + Html.td [ + Html.button [ + prop.className "btn btn-primary" + prop.disabled isSelected + prop.text "Add" + prop.onClick (fun _ -> + if not isSelected then + select person + ) + ] + ] + Html.td [ + prop.className "no-wrap" + prop.text ([person.FirstName; person.MidInitials; person.LastName] |> List.choose id |> String.concat " ") + ] + Html.td (person.Affiliation |> Option.defaultValue "") + Html.td (person.ORCID |> Option.defaultValue "") + Html.td (person.Address |> Option.defaultValue "") + Html.td ([person.EMail; person.Phone; person.Fax] |> List.choose id |> String.concat "; ") + Html.td [ + prop.title (person.Roles |> Seq.map _.ToJsonString() |> String.concat "; ") + prop.text (person.Roles |> Seq.map _.NameText |> String.concat "; ") + ] + Html.td (person.Comments |> Seq.map _.toJsonString() |> String.concat "; ") + ] + ] + ] + ] + ] + ] + Html.div [ + prop.className "flex justify-end gap-4" + prop.style [style.gap (length.rem 1)] + prop.children [ + Daisy.button.button [ + prop.text "back" + button.outline + prop.onClick back + ] + ] + ] + ] + ] + ] + ] + let publicationModal (pub: Publication, confirm, back) = Daisy.modal.div [ modal.active @@ -320,7 +389,7 @@ type FormComponents = /// /// [] - static member InputSequence<'A>(inputs: ResizeArray<'A>, constructor: unit -> 'A, setter: ResizeArray<'A> -> unit, inputComponent: 'A * ('A -> unit) * (MouseEvent -> unit) -> ReactElement, inputEquality: 'A -> 'A -> bool, ?label: string) = + static member InputSequence<'A>(inputs: ResizeArray<'A>, constructor: unit -> 'A, setter: ResizeArray<'A> -> unit, inputComponent: 'A * ('A -> unit) * (MouseEvent -> unit) -> ReactElement, inputEquality: 'A -> 'A -> bool, ?label: string, ?extendedElements: ReactElement) = // dnd-kit requires an id for each element in the list. // The id is used to keep track of the order of the elements in the list. // Because most of our classes do not have a unique id, we generate a new guid for each element in the list. @@ -359,9 +428,12 @@ type FormComponents = areEqual = equalityFunc ) Html.div [ + prop.className "space-y-2" prop.children [ if label.IsSome then Generic.FieldTitle label.Value + if extendedElements.IsSome then + extendedElements.Value DndKit.DndContext( sensors = sensors, onDragEnd = handleDragEnd, @@ -559,15 +631,15 @@ type FormComponents = [] static member PersonRequestInput (orcid: string option, doisetter, searchsetter: Person -> unit, ?label:string) = let orcid = defaultArg orcid "" - let state, setState = React.useState(API.Request.Idle) - let resetState = fun _ -> setState API.Request.Idle + let state, setState = React.useState(GenericApiState.Idle) + let resetState = fun _ -> setState GenericApiState.Idle Html.div [ prop.className "grow cursor-auto" prop.children [ match state with - | API.Request.Ok p -> Helper.personModal (p, (fun _ -> searchsetter p; resetState()), resetState) - | API.Request.Error e -> Helper.errorModal(e, resetState) - | API.Request.Loading -> Modals.Loading.Modal(rmv=resetState) + | GenericApiState.Ok p -> Helper.personModal (p, (fun _ -> searchsetter p; resetState()), resetState) + | GenericApiState.Error e -> Helper.errorModal(e, resetState) + | GenericApiState.Loading -> Modals.Loading.Modal(rmv=resetState) | _ -> Html.none if label.IsSome then Generic.FieldTitle label.Value Daisy.join [ @@ -584,14 +656,14 @@ type FormComponents = button.info prop.text "Search" prop.onClick (fun _ -> - setState API.Request.Loading + setState GenericApiState.Loading // setState <| API.Request.Error (new Exception("Not implemented")) // setState <| (API.Request.Ok (Person.create(orcid=orcid,firstName="John",lastName="Doe"))) API.start API.requestByORCID orcid - (API.Request.Ok >> setState) - (API.Request.Error >> setState) + (GenericApiState.Ok >> setState) + (GenericApiState.Error >> setState) ) ] ] @@ -681,16 +753,67 @@ type FormComponents = Helper.deleteButton rmv.Value ] - static member PersonsInput (persons: ResizeArray, setter: ResizeArray -> unit, ?label: string) = + [] + static member PersonsInput (persons: ResizeArray, setter: ResizeArray -> unit, ?isARCitect: bool, ?label: string) = + let isARCitect = defaultArg isARCitect false + let (externalPersons: GenericApiState), setExternalPersons = React.useState(GenericApiState.Idle) + let extendedElements = + match isARCitect with + | true -> + React.fragment [ + Html.div [ + prop.className "flex justify-center" + prop.children [ + Html.button [ + prop.className "btn btn-primary btn-wide" + prop.text "Import Persons" + prop.onClick (fun _ -> + promise { + setExternalPersons GenericApiState.Loading + let! personsJson = Model.ARCitect.api.RequestPersons() + let persons = + personsJson + |> Array.map ARCtrl.Person.fromJsonString + |> Array.sortBy _.LastName + + GenericApiState.Ok persons + |> setExternalPersons + } + |> Promise.catch (fun e -> + GenericApiState.Error e + |> setExternalPersons + ) + |> Promise.start + ) + ] + ] + ] + match externalPersons with + | GenericApiState.Idle -> Html.none + | GenericApiState.Error e -> Helper.errorModal(e, (fun _ -> setExternalPersons GenericApiState.Idle)) + | GenericApiState.Loading -> Modals.Loading.Modal(rmv=(fun _ -> setExternalPersons GenericApiState.Idle)) + | GenericApiState.Ok externalPersons -> : + Helper.PersonsModal( + persons, + externalPersons, + (fun person -> persons.Add(person); persons |> setter), + (fun _ -> setExternalPersons GenericApiState.Idle) + ) + ] + |> Some + | false -> None + FormComponents.InputSequence( persons, Person, setter, (fun (v, setV, rmv) -> FormComponents.PersonInput(v, setV, rmv)), (fun person1 person2 -> person1.Equals person2), - ?label=label + ?label=label, + ?extendedElements = extendedElements ) + [] static member DateTimeInput (input_: string, setter: string -> unit, ?label: string) = let ref = React.useInputRef() @@ -745,17 +868,17 @@ type FormComponents = [] static member PublicationRequestInput (id: string option, searchAPI: string -> Fable.Core.JS.Promise, doisetter, searchsetter: Publication -> unit, ?label:string) = let id = defaultArg id "" - let state, setState = React.useState(API.Request.Idle) - let resetState = fun _ -> setState API.Request.Idle + let state, setState = React.useState(GenericApiState.Idle) + let resetState = fun _ -> setState GenericApiState.Idle Html.div [ prop.className "grow" prop.children [ if label.IsSome then Generic.FieldTitle label.Value //if state.IsSome || error.IsSome then match state with - | API.Request.Ok pub -> Helper.publicationModal(pub,(fun _ -> searchsetter pub; resetState()), resetState) - | API.Request.Error e -> Helper.errorModal(e, resetState) - | API.Request.Loading -> Modals.Loading.Modal(rmv=resetState) + | GenericApiState.Ok pub -> Helper.publicationModal(pub,(fun _ -> searchsetter pub; resetState()), resetState) + | GenericApiState.Error e -> Helper.errorModal(e, resetState) + | GenericApiState.Loading -> Modals.Loading.Modal(rmv=resetState) | _ -> Html.none Daisy.join [ prop.className "w-full" @@ -770,12 +893,12 @@ type FormComponents = join.item prop.text "Search" prop.onClick (fun _ -> - setState API.Request.Loading + setState GenericApiState.Loading API.start searchAPI id - (API.Request.Ok >> setState) - (API.Request.Error >> setState) + (GenericApiState.Ok >> setState) + (GenericApiState.Error >> setState) ) ] ] diff --git a/src/Client/SharedComponents/Metadata/Investigation.fs b/src/Client/SharedComponents/Metadata/Investigation.fs index 5e13b012..0e80b649 100644 --- a/src/Client/SharedComponents/Metadata/Investigation.fs +++ b/src/Client/SharedComponents/Metadata/Investigation.fs @@ -41,6 +41,7 @@ let Main(investigation: ArcInvestigation, setInvestigation: ArcInvestigation -> (fun i -> investigation.Contacts <- ResizeArray i setInvestigation investigation), + model.PersistentStorageState.IsARCitect, "Contacts" ) FormComponents.PublicationsInput( diff --git a/src/Client/SharedComponents/Metadata/Study.fs b/src/Client/SharedComponents/Metadata/Study.fs index ac6539f4..a029c38c 100644 --- a/src/Client/SharedComponents/Metadata/Study.fs +++ b/src/Client/SharedComponents/Metadata/Study.fs @@ -41,6 +41,7 @@ let Main(study: ArcStudy, assignedAssays: ArcAssay list, setArcStudy: (ArcStudy (fun persons -> study.Contacts <- ResizeArray(persons) setArcStudy (study , assignedAssays)), + model.PersistentStorageState.IsARCitect, "Contacts" ) FormComponents.PublicationsInput ( diff --git a/src/Client/SharedComponents/Metadata/Template.fs b/src/Client/SharedComponents/Metadata/Template.fs index 15788439..4e1563af 100644 --- a/src/Client/SharedComponents/Metadata/Template.fs +++ b/src/Client/SharedComponents/Metadata/Template.fs @@ -81,7 +81,7 @@ let Main(template: Template, setTemplate: Template -> unit) = template.Authors <-ResizeArray s //template |> ArcFiles.Template |> Spreadsheet.UpdateArcFile |> SpreadsheetMsg |> dispatch) setTemplate template), - "Authors" + label="Authors" ) ] ) diff --git a/src/Client/Types.fs b/src/Client/Types.fs index 33efeccb..c9ea3ce7 100644 --- a/src/Client/Types.fs +++ b/src/Client/Types.fs @@ -3,6 +3,15 @@ module Types open ARCtrl +module Feliz = + + [] + type GenericApiState<'s> = + | Idle + | Loading + | Ok of 's + | Error of exn + module JsonImport = [] From 91185f4e2184095f77ede610f8f6bfab74fb0b3d Mon Sep 17 00:00:00 2001 From: Kevin F Date: Thu, 20 Feb 2025 16:10:16 +0100 Subject: [PATCH 05/11] Blacklist `InitFromArcFile` to not SAVE to disc on msg call #632 This removes initial save --- src/Client/Update/SpreadsheetUpdate.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Client/Update/SpreadsheetUpdate.fs b/src/Client/Update/SpreadsheetUpdate.fs index 8946a4da..4f0b5e9b 100644 --- a/src/Client/Update/SpreadsheetUpdate.fs +++ b/src/Client/Update/SpreadsheetUpdate.fs @@ -33,7 +33,7 @@ module Spreadsheet = //This matchcase handles undo / redo functionality match msg with - | UpdateActiveView _ | Reset | UpdateSelectedCells _ + | UpdateActiveView _ | Reset | UpdateSelectedCells _ | InitFromArcFile _ | UpdateActiveCell _ | CopySelectedCell | CopyCell _ | MoveSelectedCell _ | SetActiveCellFromSelected -> state, model, cmd | _ -> From 1b30483ede4e1f0222dcd6b1a0b366eab637fe21 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Thu, 20 Feb 2025 16:28:08 +0100 Subject: [PATCH 06/11] Remake filepicker --- src/Client/MainComponents/Widgets.fs | 4 +-- src/Client/Pages/FilePicker/FilePickerView.fs | 26 ++++++++++--------- src/Client/SharedComponents/Metadata/Forms.fs | 2 +- src/Client/Update/ARCitectUpdate.fs | 1 + 4 files changed, 18 insertions(+), 15 deletions(-) diff --git a/src/Client/MainComponents/Widgets.fs b/src/Client/MainComponents/Widgets.fs index 689d0bb4..a2f459b0 100644 --- a/src/Client/MainComponents/Widgets.fs +++ b/src/Client/MainComponents/Widgets.fs @@ -193,8 +193,8 @@ type Widget = let content = Html.div [ prop.className "@container/filePickerWidget min-w-32" prop.children [ - FilePicker.uploadButton model dispatch "@md/filePickerWidget:flex-row" - if model.FilePickerState.FileNames <> [] then + FilePicker.UploadButton(model, dispatch, "@md/filePickerWidget:flex-row") + if model.FilePickerState.FileNames <> [] || model.ARCitectState.Paths <> [||] then FilePicker.fileSortElements model dispatch Html.div [ diff --git a/src/Client/Pages/FilePicker/FilePickerView.fs b/src/Client/Pages/FilePicker/FilePickerView.fs index b8dbb5ea..dcd6c7cc 100644 --- a/src/Client/Pages/FilePicker/FilePickerView.fs +++ b/src/Client/Pages/FilePicker/FilePickerView.fs @@ -26,7 +26,16 @@ let update (filePickerMsg: FilePicker.Msg) (state: FilePicker.Model) (model: Mod nextState, Cmd.none /// "parentContainerResizeClass": uses tailwind container queries. Expects a string like "@md/parentId:flex-row" -let uploadButton (model: Model) dispatch (parentContainerResizeClass: string) = +[] +let UploadButton (model: Model, dispatch, parentContainerResizeClass: string) = + + React.useEffect ( + (fun _ -> + model.ARCitectState.Paths |> List.ofArray |> LoadNewFiles |> FilePickerMsg |> dispatch + ), + [|box model.ARCitectState.Paths|] + ) + let inputId = "filePicker_OnFilePickerMainFunc" Html.div [ prop.className [ @@ -216,10 +225,11 @@ module FileNameTable = ] -let fileContainer (model:Model) dispatch = +let FileContainer (model:Model) dispatch = + SidebarComponents.SidebarLayout.LogicContainer [ - uploadButton model dispatch "@md/sidebar:flex-row" + UploadButton(model, dispatch, "@md/sidebar:flex-row") if model.FilePickerState.FileNames <> [] then fileSortElements model dispatch @@ -229,21 +239,13 @@ let fileContainer (model:Model) dispatch = insertButton model dispatch ] -[] let Main (model:Model) (dispatch:Messages.Msg -> unit) = - React.useEffect ( - (fun _ -> - model.ARCitectState.Paths |> List.ofArray |> LoadNewFiles |> FilePickerMsg |> dispatch - ), - [|box model.ARCitectState.Paths|] - ) - SidebarComponents.SidebarLayout.Container [ SidebarComponents.SidebarLayout.Header "File Picker" SidebarComponents.SidebarLayout.Description "Select files from your computer and insert their names into Excel" // Colored container element for all uploaded file names and sort elements - fileContainer model dispatch + FileContainer model dispatch ] \ No newline at end of file diff --git a/src/Client/SharedComponents/Metadata/Forms.fs b/src/Client/SharedComponents/Metadata/Forms.fs index 83a26956..1242fe39 100644 --- a/src/Client/SharedComponents/Metadata/Forms.fs +++ b/src/Client/SharedComponents/Metadata/Forms.fs @@ -792,7 +792,7 @@ type FormComponents = | GenericApiState.Idle -> Html.none | GenericApiState.Error e -> Helper.errorModal(e, (fun _ -> setExternalPersons GenericApiState.Idle)) | GenericApiState.Loading -> Modals.Loading.Modal(rmv=(fun _ -> setExternalPersons GenericApiState.Idle)) - | GenericApiState.Ok externalPersons -> : + | GenericApiState.Ok externalPersons -> Helper.PersonsModal( persons, externalPersons, diff --git a/src/Client/Update/ARCitectUpdate.fs b/src/Client/Update/ARCitectUpdate.fs index 268c743a..e821c5b0 100644 --- a/src/Client/Update/ARCitectUpdate.fs +++ b/src/Client/Update/ARCitectUpdate.fs @@ -81,6 +81,7 @@ module ARCitect = state, model, cmd | ARCitect.ResponsePaths paths -> + log (sprintf "ResponsePaths: %A" paths) {state with Paths = paths}, model, Cmd.none | ARCitect.RequestPersons msg -> From eeef931a61cb32b90ac5f6492412d105e39701ed Mon Sep 17 00:00:00 2001 From: Kevin F Date: Fri, 21 Feb 2025 10:25:54 +0100 Subject: [PATCH 07/11] Update paths and filepicker logic --- src/Client/MainComponents/Widgets.fs | 14 +- src/Client/Pages/FilePicker/FilePickerView.fs | 276 +++++++++--------- src/Client/States/ARCitect.fs | 24 +- src/Client/Update.fs | 2 +- src/Client/Update/ARCitectUpdate.fs | 15 +- src/Client/Views/SidebarView.fs | 2 +- 6 files changed, 171 insertions(+), 162 deletions(-) diff --git a/src/Client/MainComponents/Widgets.fs b/src/Client/MainComponents/Widgets.fs index a2f459b0..50e88665 100644 --- a/src/Client/MainComponents/Widgets.fs +++ b/src/Client/MainComponents/Widgets.fs @@ -191,19 +191,9 @@ type Widget = static member FilePicker (model, dispatch, rmv) = let content = Html.div [ - prop.className "@container/filePickerWidget min-w-32" + prop.className "flex flex-col gap-2" prop.children [ - FilePicker.UploadButton(model, dispatch, "@md/filePickerWidget:flex-row") - if model.FilePickerState.FileNames <> [] || model.ARCitectState.Paths <> [||] then - FilePicker.fileSortElements model dispatch - - Html.div [ - prop.style [style.maxHeight (length.px 350); style.overflow.auto] - prop.children [ - FilePicker.FileNameTable.table model dispatch - ] - ] - FilePicker.insertButton model dispatch + Pages.FilePicker.Main(model, dispatch, "@container/filePickerWidget min-w-32") ] ] let prefix = WidgetLiterals.FilePicker diff --git a/src/Client/Pages/FilePicker/FilePickerView.fs b/src/Client/Pages/FilePicker/FilePickerView.fs index dcd6c7cc..1d37bfe8 100644 --- a/src/Client/Pages/FilePicker/FilePickerView.fs +++ b/src/Client/Pages/FilePicker/FilePickerView.fs @@ -1,4 +1,4 @@ -module FilePicker +namespace Pages open Model open Browser.Types @@ -9,134 +9,138 @@ open Feliz open Feliz.DaisyUI open Swate -let update (filePickerMsg: FilePicker.Msg) (state: FilePicker.Model) (model: Model.Model) : FilePicker.Model * Cmd = - match filePickerMsg with - | LoadNewFiles fileNames -> - let nextModel = { - model with - Model.FilePickerState.FileNames = fileNames |> List.mapi (fun i x -> i + 1, x) - Model.PageState.SidebarPage = Routing.SidebarPage.FilePicker - } - let nextCmd = UpdateModel nextModel|> Cmd.ofMsg - state, nextCmd - | UpdateFileNames newFileNames -> - let nextState : FilePicker.Model = { - FileNames = newFileNames - } - nextState, Cmd.none - -/// "parentContainerResizeClass": uses tailwind container queries. Expects a string like "@md/parentId:flex-row" -[] -let UploadButton (model: Model, dispatch, parentContainerResizeClass: string) = - - React.useEffect ( - (fun _ -> - model.ARCitectState.Paths |> List.ofArray |> LoadNewFiles |> FilePickerMsg |> dispatch - ), - [|box model.ARCitectState.Paths|] - ) - - let inputId = "filePicker_OnFilePickerMainFunc" - Html.div [ - prop.className [ - "flex flex-col gap-2" - parentContainerResizeClass - ] - prop.children [ - Html.input [ - prop.style [style.display.none] - prop.id inputId - prop.multiple true - prop.type'.file - prop.onChange (fun (ev: File list) -> - let files = ev //ev.target?files - - let fileNames = - files |> List.map (fun f -> f.name) - - fileNames |> LoadNewFiles |> FilePickerMsg |> dispatch - - //let picker = Browser.Dom.document.getElementById(inputId) - //// https://stackoverflow.com/questions/3528359/html-input-type-file-file-selection-event/3528376 - //picker?value <- null - ) +module FilePicker = + + let update (filePickerMsg: FilePicker.Msg) (state: FilePicker.Model) (model: Model.Model) : FilePicker.Model * Cmd = + match filePickerMsg with + | LoadNewFiles fileNames -> + let nextModel = { + model with + Model.FilePickerState.FileNames = fileNames |> List.mapi (fun i x -> i + 1, x) + Model.PageState.SidebarPage = Routing.SidebarPage.FilePicker + } + let nextCmd = UpdateModel nextModel|> Cmd.ofMsg + state, nextCmd + | UpdateFileNames newFileNames -> + let nextState : FilePicker.Model = { + FileNames = newFileNames + } + nextState, Cmd.none + +type FilePicker = + + + /// "parentContainerResizeClass": uses tailwind container queries. Expects a string like "@md/parentId:flex-row" + static member private UploadButtons (model: Model, dispatch, parentContainerResizeClass: string) = + + let inputId = "filePicker_OnFilePickerMainFunc" + Html.div [ + prop.className [ + "flex flex-col gap-2" + parentContainerResizeClass ] - match model.PersistentStorageState.Host with - | Some (Swatehost.ARCitect) -> - Daisy.button.button [ - button.primary - button.block - prop.onClick(fun _ -> - Start false |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + prop.children [ + Html.input [ + prop.style [style.display.none] + prop.id inputId + prop.multiple true + prop.type'.file + prop.onChange (fun (ev: File list) -> + let files = ev //ev.target?files + + let fileNames = + files |> List.map (fun f -> f.name) + + fileNames |> LoadNewFiles |> FilePickerMsg |> dispatch + + //let picker = Browser.Dom.document.getElementById(inputId) + //// https://stackoverflow.com/questions/3528359/html-input-type-file-file-selection-event/3528376 + //picker?value <- null ) - prop.text "Pick Files" ] + match model.PersistentStorageState.Host with + | Some Swatehost.ARCitect -> + let target = ARCitect.Interop.InteropTypes.ARCitectPathsTarget.FilePicker + Daisy.button.button [ + button.primary + button.block + prop.onClick(fun _ -> + Start {|target = target; dictionaries = false |} |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + ) + prop.text "Pick Files" + ] + Daisy.button.button [ + button.primary + button.block + prop.onClick(fun _ -> + Start {|target = target; dictionaries = true |} |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + ) + prop.text "Pick Directories" + ] + | _ -> + Daisy.button.button [ + button.primary + button.block + prop.onClick(fun _ -> + let getUploadElement = Browser.Dom.document.getElementById inputId + getUploadElement.click() + ) + prop.text "Pick file names" + ] + ] + ] + + static member private ActionButtons (model: Model) dispatch = + Html.div [ + prop.className "flex flex-row justify-center gap-2" + prop.children [ + Daisy.button.button [ - button.primary - button.block - prop.onClick(fun _ -> - Start true |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + button.neutral + button.outline + prop.onClick (fun _ -> + Messages.FilePicker.UpdateFileNames [] |> FilePickerMsg |> dispatch ) - prop.text "Pick Directories" + prop.text "Cancel" ] - | _ -> + Daisy.button.button [ button.primary - button.block - prop.onClick(fun _ -> - let getUploadElement = Browser.Dom.document.getElementById inputId - getUploadElement.click() + prop.onClick (fun _ -> + let fileNames = model.FilePickerState.FileNames |> List.map snd + SpreadsheetInterface.InsertFileNames fileNames |> InterfaceMsg |> dispatch ) - prop.text "Pick file names" + prop.text "Insert file names" ] - ] - ] - -let insertButton (model: Model) dispatch = - Html.div [ - prop.className "flex flex-row justify-center" - prop.children [ - - Daisy.button.button [ - button.success - button.wide - prop.onClick (fun _ -> - let fileNames = model.FilePickerState.FileNames |> List.map snd - SpreadsheetInterface.InsertFileNames fileNames |> InterfaceMsg |> dispatch - ) - prop.text "Insert file names" ] ] - ] - -let sortButton icon msg = - Daisy.button.a [ - join.item - prop.onClick msg - prop.children [ - Html.i [prop.classes ["fa-lg"; icon]] - ] - ] -let fileSortElements (model: Model) dispatch = - Html.div [ - Daisy.join [ + static member private SortButton icon msg = + Daisy.button.a [ + join.item + prop.onClick msg prop.children [ - sortButton "fa-solid fa-arrow-down-a-z" (fun _ -> - let sortedList = model.FilePickerState.FileNames |> List.sortBy snd |> List.mapi (fun i x -> i+1,snd x) - UpdateFileNames sortedList |> FilePickerMsg |> dispatch - ) - sortButton "fa-solid fa-arrow-down-z-a" (fun _ -> - let sortedList = model.FilePickerState.FileNames |> List.sortByDescending snd |> List.mapi (fun i x -> i+1,snd x) - UpdateFileNames sortedList |> FilePickerMsg |> dispatch - ) + Html.i [prop.classes ["fa-lg"; icon]] ] ] - ] -module FileNameTable = + static member private FileSortElements (model: Model) dispatch = + Html.div [ + Daisy.join [ + prop.children [ + FilePicker.SortButton "fa-solid fa-arrow-down-a-z" (fun _ -> + let sortedList = model.FilePickerState.FileNames |> List.sortBy snd |> List.mapi (fun i x -> i+1,snd x) + UpdateFileNames sortedList |> FilePickerMsg |> dispatch + ) + FilePicker.SortButton "fa-solid fa-arrow-down-z-a" (fun _ -> + let sortedList = model.FilePickerState.FileNames |> List.sortByDescending snd |> List.mapi (fun i x -> i+1,snd x) + UpdateFileNames sortedList |> FilePickerMsg |> dispatch + ) + ] + ] + ] - let deleteFromTable (id,fileName) (model:Model) dispatch = + static member private DeleteFromTable (id,fileName) (model:Model) dispatch = Components.Components.DeleteButton (props = [ prop.onClick (fun _ -> let newList = @@ -150,7 +154,7 @@ module FileNameTable = button.outline ]) - let moveUpButton (id,fileName) (model:Model) dispatch = + static member private MoveUpButton (id,fileName) (model:Model) dispatch = Daisy.button.a [ button.xs join.item @@ -175,7 +179,7 @@ module FileNameTable = ] ] - let moveDownButton (id,fileName) (model:Model) dispatch = + static member private MoveDownButton (id,fileName) (model:Model) dispatch = Daisy.button.a [ button.xs join.item @@ -200,14 +204,14 @@ module FileNameTable = ] ] - let moveButtonList (id,fileName) (model:Model) dispatch = + static member private MoveButtonList (id,fileName) (model:Model) dispatch = Daisy.join [ - moveUpButton (id,fileName) model dispatch - moveDownButton (id,fileName) model dispatch + FilePicker.MoveUpButton (id,fileName) model dispatch + FilePicker.MoveDownButton (id,fileName) model dispatch ] - let table (model:Model) dispatch = + static member private FileViewTable (model:Model) dispatch = Daisy.table [ table.zebra table.xs @@ -217,35 +221,37 @@ module FileNameTable = Html.tr [ Html.td [Html.b $"{index}"] Html.td fileName - Html.td [moveButtonList (index,fileName) model dispatch] - Html.td [prop.style [style.textAlign.right]; prop.children [deleteFromTable (index,fileName) model dispatch]] + Html.td [FilePicker.MoveButtonList (index,fileName) model dispatch] + Html.td [prop.style [style.textAlign.right]; prop.children [FilePicker.DeleteFromTable (index,fileName) model dispatch]] ] ] ] ] -let FileContainer (model:Model) dispatch = + static member Main (model:Model, dispatch, containerQueryClass: string) = - SidebarComponents.SidebarLayout.LogicContainer [ + React.fragment [ - UploadButton(model, dispatch, "@md/sidebar:flex-row") + match model.FilePickerState.FileNames with + | [] -> - if model.FilePickerState.FileNames <> [] then - fileSortElements model dispatch + FilePicker.UploadButtons(model, dispatch, containerQueryClass) + | _ -> + FilePicker.FileSortElements model dispatch - FileNameTable.table model dispatch - //fileNameElements model dispatch - insertButton model dispatch - ] + FilePicker.FileViewTable model dispatch + //fileNameElements model dispatch + FilePicker.ActionButtons model dispatch + ] -let Main (model:Model) (dispatch:Messages.Msg -> unit) = + static member Sidebar (model:Model, dispatch:Messages.Msg -> unit) = - SidebarComponents.SidebarLayout.Container [ - SidebarComponents.SidebarLayout.Header "File Picker" + SidebarComponents.SidebarLayout.Container [ + SidebarComponents.SidebarLayout.Header "File Picker" - SidebarComponents.SidebarLayout.Description "Select files from your computer and insert their names into Excel" + SidebarComponents.SidebarLayout.Description "Select files from your computer and insert their names into Excel" - // Colored container element for all uploaded file names and sort elements - FileContainer model dispatch - ] \ No newline at end of file + // Colored container element for all uploaded file names and sort elements + FilePicker.Main (model, dispatch, "@md/sidebar:flex-row") + ] \ No newline at end of file diff --git a/src/Client/States/ARCitect.fs b/src/Client/States/ARCitect.fs index d88528df..aabec6bd 100644 --- a/src/Client/States/ARCitect.fs +++ b/src/Client/States/ARCitect.fs @@ -17,10 +17,20 @@ module Interop = | Assay | Template + [] + [] + type ARCitectPathsTarget = + | FilePicker + | DataAnnotator + + type RequestPathsPojo = {| target: InteropTypes.ARCitectPathsTarget; dictionaries: bool|} + + type ResponsePathsPojo = {| target: InteropTypes.ARCitectPathsTarget; paths: string []|} + type IARCitectOutAPI = { Init: unit -> JS.Promise Save: InteropTypes.ARCFile * string -> JS.Promise - RequestPaths: bool -> JS.Promise + RequestPaths: RequestPathsPojo -> JS.Promise /// returns person jsons RequestPersons: unit -> JS.Promise } @@ -28,7 +38,7 @@ module Interop = type IARCitectInAPI = { TestHello: string -> JS.Promise /// JS.Promise - ResponsePaths: string [] -> JS.Promise + ResponsePaths: ResponsePathsPojo -> JS.Promise } @@ -42,21 +52,19 @@ type Msg = | Init of ApiCall | Save of ArcFiles /// ApiCall - | RequestPaths of ApiCall + | RequestPaths of ApiCall /// Selecting paths requires user input, which we cannot await. - /// To avoid timeout `RequestPaths` simply returns true if call was successful, - /// ... and `ResponsePaths` will be sent as soon as user selected the directories - | ResponsePaths of string [] + /// To avoid timeout `RequestPaths` simply returns true if call was successful, + /// ... and `ResponsePaths` will be sent as soon as user selected the directories + | ResponsePaths of Interop.ResponsePathsPojo /// expects person jsons | RequestPersons of ApiCall type Model = { - Paths: string [] Persons: Person [] } static member init() = { - Paths = [||]; Persons = [||] } \ No newline at end of file diff --git a/src/Client/Update.fs b/src/Client/Update.fs index c03dd520..28076526 100644 --- a/src/Client/Update.fs +++ b/src/Client/Update.fs @@ -277,7 +277,7 @@ let update (msg : Msg) (model : Model) : Model * Cmd = | FilePickerMsg filePickerMsg -> let nextFilePickerState, nextCmd = - FilePicker.update filePickerMsg currentModel.FilePickerState model + Pages.FilePicker.update filePickerMsg currentModel.FilePickerState model let nextModel = { currentModel with diff --git a/src/Client/Update/ARCitectUpdate.fs b/src/Client/Update/ARCitectUpdate.fs index e821c5b0..a156d5e4 100644 --- a/src/Client/Update/ARCitectUpdate.fs +++ b/src/Client/Update/ARCitectUpdate.fs @@ -64,11 +64,11 @@ module ARCitect = | ARCitect.RequestPaths msg -> match msg with - | Start selectDirectories -> + | Start pojo -> let cmd = Cmd.OfPromise.either api.RequestPaths - (selectDirectories) + pojo (Finished >> ARCitect.RequestPaths >> ARCitectMsg) (curry GenericError Cmd.none >> DevMsg) state, model, cmd @@ -80,9 +80,14 @@ module ARCitect = GenericError (Cmd.none, exn("RequestPaths failed")) |> DevMsg |> Cmd.ofMsg state, model, cmd - | ARCitect.ResponsePaths paths -> - log (sprintf "ResponsePaths: %A" paths) - {state with Paths = paths}, model, Cmd.none + | ARCitect.ResponsePaths pojo -> + match pojo.target with + | ARCitect.Interop.InteropTypes.ARCitectPathsTarget.FilePicker -> + let paths = Array.indexed pojo.paths |> List.ofArray + state, {model with FilePickerState.FileNames = paths}, Cmd.none + | _ -> + Browser.Dom.console.error("ResponsePaths: target not implemented:", pojo.target) + state, model, Cmd.none | ARCitect.RequestPersons msg -> match msg with diff --git a/src/Client/Views/SidebarView.fs b/src/Client/Views/SidebarView.fs index d590136a..ad6b62fe 100644 --- a/src/Client/Views/SidebarView.fs +++ b/src/Client/Views/SidebarView.fs @@ -22,7 +22,7 @@ type SidebarView = TermSearch.Main (model, dispatch) | {SidebarPage = Routing.SidebarPage.FilePicker } -> - FilePicker.Main model dispatch + Pages.FilePicker.Sidebar (model, dispatch) | {SidebarPage = Routing.SidebarPage.Protocol } -> Protocol.Templates.Main (model, dispatch) From f236cb6982e959fcd056e84da7d4416e8b5bae24 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Fri, 21 Feb 2025 10:47:18 +0100 Subject: [PATCH 08/11] Improve outgoing arcitect args --- src/Client/Util/MessageInterop.fs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Client/Util/MessageInterop.fs b/src/Client/Util/MessageInterop.fs index 8d7b28f0..c7e5f060 100644 --- a/src/Client/Util/MessageInterop.fs +++ b/src/Client/Util/MessageInterop.fs @@ -82,11 +82,11 @@ module MessageInteropHelper = fun arg0 -> - let data: obj[] = + let data: obj = match argumentType with | TypeInfo.Unit -> [||] - | TypeInfo.Tuple _ -> arg0 - | _ -> [|arg0|] + | TypeInfo.Tuple _ -> arg0 + | _ -> arg0 let requestBody: IMessagePayload = {| swate = true; api = Some func.FieldName; data = Some data; requestId = System.Guid.NewGuid().ToString(); error = None |} @@ -95,7 +95,7 @@ module MessageInteropHelper = // Function to generate a new instance dynamically let buildOutProxyInner (target: Browser.Types.Window, resolvedType: Type) : 'T = - + if not (FSharpType.IsRecord resolvedType) then failwithf "MessageInterop-Error: Provided type is not a record. %s" resolvedType.FullName @@ -180,7 +180,7 @@ module MessageInteropHelper = match content.api with | Some api -> promise { - let! payload = + let! payload = try promise { let! r = runApiFromName apiHandler api content.data @@ -195,7 +195,7 @@ module MessageInteropHelper = let result: IMessagePayload = {| payload with api = None |} result ) - + target.postMessage(payload, "*") } |> Promise.start @@ -204,7 +204,7 @@ module MessageInteropHelper = {| content with error = Some "No API name given!"|} target.postMessage(payload, "*") - let handle = + let handle = fun (e: Browser.Types.Event) -> let e = e :?> Browser.Types.MessageEvent match verifyMsg e with From fe4bf6d614996d9b5c84138c4c7ea32932f071f5 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Fri, 21 Feb 2025 15:26:31 +0100 Subject: [PATCH 09/11] Fix data annotator relative paths in ARCitect #539 :bug: --- src/Client/App.fs | 5 ++ .../Pages/DataAnnotator/DataAnnotator.fs | 74 ++++++++++++++++--- src/Client/Pages/FilePicker/FilePickerView.fs | 5 +- src/Client/States/ARCitect.fs | 29 ++++---- src/Client/Update.fs | 1 - src/Client/Update/ARCitectUpdate.fs | 35 +++++++-- src/Client/Views/SidebarView.fs | 2 +- 7 files changed, 113 insertions(+), 38 deletions(-) diff --git a/src/Client/App.fs b/src/Client/App.fs index 0e3a79fa..864cd828 100644 --- a/src/Client/App.fs +++ b/src/Client/App.fs @@ -19,6 +19,11 @@ module Subscriptions = Model.ARCitect.ResponsePaths paths |> Messages.ARCitectMsg |> dispatch return true } + ResponseFile = fun file -> + promise { + Model.ARCitect.ResponseFile file |> Messages.ARCitectMsg |> dispatch + return true + } } let subscription (initial: Model.Model) : (SubId * Subscribe) list = diff --git a/src/Client/Pages/DataAnnotator/DataAnnotator.fs b/src/Client/Pages/DataAnnotator/DataAnnotator.fs index ad4a8242..0a8623be 100644 --- a/src/Client/Pages/DataAnnotator/DataAnnotator.fs +++ b/src/Client/Pages/DataAnnotator/DataAnnotator.fs @@ -14,6 +14,7 @@ module private DataAnnotatorHelper = let ResetButton model (rmvFile: Browser.Types.Event -> unit) = Daisy.button.button [ + prop.className "grow" prop.onClick rmvFile button.outline if model.DataAnnotatorModel.DataFile.IsNone then @@ -99,6 +100,26 @@ module private DataAnnotatorHelper = ] ] ] + + let RequestPathButton (fileName: string option, requestPath) = + let fileName = defaultArg fileName "Choose File" + Html.label [ + prop.className "join flex" + prop.onClick requestPath + prop.children [ + Html.button [ + prop.className "btn btn-primary join-item" + prop.text "Choose File" + ] + Html.input [ + prop.title fileName + prop.className "input input-bordered input-disabled join-item grow" + prop.value fileName + prop.readOnly true + ] + ] + ] + let UploadButton (ref: IRefValue<#Browser.Types.HTMLElement option>) (model: Model) (uploadFile: Browser.Types.File -> unit) = Daisy.file [ prop.className "col-span-2" @@ -111,6 +132,7 @@ module private DataAnnotatorHelper = let OpenModalButton model mkOpen = Daisy.button.button [ button.primary + prop.className "grow" if model.DataAnnotatorModel.DataFile.IsNone then button.disabled prop.text "Open Annotator" @@ -120,14 +142,10 @@ module private DataAnnotatorHelper = open DataAnnotatorButtons - let ModalMangementComponent ref (model: Model) (openModal: Browser.Types.Event -> unit) rmvFile uploadFile = + let ModalMangementContainer (children: ReactElement list) = Html.div [ - prop.className "grid grid-cols-2 gap-4" - prop.children [ - UploadButton ref model uploadFile - ResetButton model rmvFile - OpenModalButton model openModal - ] + prop.className "flex flex-col gap-4" + prop.children children ] let DataFileConfigComponent model rmvFile target setTarget dispatch = @@ -324,7 +342,7 @@ type DataAnnotator = static member Main(model: Model, dispatch: Msg -> unit) = let showModal, setShowModal = React.useState(false) let ref = React.useInputRef() - let uploadFile = fun (e: Browser.Types.File) -> + let uploadFileOnChange = fun (e: Browser.Types.File) -> promise { let! content = e.text() let dtf = DataFile.create(e.name, e.``type``, content, e.size) @@ -337,6 +355,40 @@ type DataAnnotator = UpdateDataFile None |> DataAnnotatorMsg |> dispatch if ref.current.IsSome then ref.current.Value.value <- null + let requestFileFromARCitect = fun _ -> + if model.PersistentStorageState.IsARCitect then + setShowModal true + Elmish.ApiCall.Start () + |> ARCitect.RequestFile + |> ARCitectMsg + |> dispatch + + let activateModal = fun _ -> setShowModal true + + React.fragment [ + ModalMangementContainer [ + match model.PersistentStorageState.IsARCitect with + | true -> + DataAnnotatorHelper.DataAnnotatorButtons.RequestPathButton( + model.DataAnnotatorModel.DataFile |> Option.map _.DataFileName, + requestFileFromARCitect + ) + | false -> + DataAnnotatorHelper.DataAnnotatorButtons.UploadButton ref model uploadFileOnChange + Html.div [ + prop.className "flex flex-row gap-4" + prop.children [ + DataAnnotatorHelper.DataAnnotatorButtons.ResetButton model rmvFile + DataAnnotatorHelper.DataAnnotatorButtons.OpenModalButton model activateModal + ] + ] + ] + match model.DataAnnotatorModel, showModal with + | { DataFile = Some _; ParsedFile = Some _ }, true -> DataAnnotator.Modal(model, dispatch, rmvFile, fun _ -> setShowModal false) + | _, _ -> Html.none + ] + + static member Sidebar(model, dispatch) = SidebarComponents.SidebarLayout.Container [ SidebarComponents.SidebarLayout.Header "Data Annotator" @@ -344,10 +396,8 @@ type DataAnnotator = SidebarComponents.SidebarLayout.Description "Specify exact data points for annotation." SidebarComponents.SidebarLayout.LogicContainer [ - ModalMangementComponent ref model (fun _ -> setShowModal true) rmvFile uploadFile - match model.DataAnnotatorModel, showModal with - | { DataFile = Some _; ParsedFile = Some _ }, true -> DataAnnotator.Modal(model, dispatch, rmvFile, fun _ -> setShowModal false) - | _, _ -> Html.none + DataAnnotator.Main(model, dispatch) ] + ] diff --git a/src/Client/Pages/FilePicker/FilePickerView.fs b/src/Client/Pages/FilePicker/FilePickerView.fs index 1d37bfe8..89b0949f 100644 --- a/src/Client/Pages/FilePicker/FilePickerView.fs +++ b/src/Client/Pages/FilePicker/FilePickerView.fs @@ -60,12 +60,11 @@ type FilePicker = ] match model.PersistentStorageState.Host with | Some Swatehost.ARCitect -> - let target = ARCitect.Interop.InteropTypes.ARCitectPathsTarget.FilePicker Daisy.button.button [ button.primary button.block prop.onClick(fun _ -> - Start {|target = target; dictionaries = false |} |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + Start false |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch ) prop.text "Pick Files" ] @@ -73,7 +72,7 @@ type FilePicker = button.primary button.block prop.onClick(fun _ -> - Start {|target = target; dictionaries = true |} |> ARCitect.RequestPaths |> ARCitectMsg |> dispatch + Start true|> ARCitect.RequestPaths |> ARCitectMsg |> dispatch ) prop.text "Pick Directories" ] diff --git a/src/Client/States/ARCitect.fs b/src/Client/States/ARCitect.fs index aabec6bd..f7775e4e 100644 --- a/src/Client/States/ARCitect.fs +++ b/src/Client/States/ARCitect.fs @@ -17,20 +17,20 @@ module Interop = | Assay | Template - [] - [] - type ARCitectPathsTarget = - | FilePicker - | DataAnnotator - - type RequestPathsPojo = {| target: InteropTypes.ARCitectPathsTarget; dictionaries: bool|} - - type ResponsePathsPojo = {| target: InteropTypes.ARCitectPathsTarget; paths: string []|} + type ARCitectFile = {| + mimetype: string + content: string + size: int + name: string + |} type IARCitectOutAPI = { Init: unit -> JS.Promise Save: InteropTypes.ARCFile * string -> JS.Promise - RequestPaths: RequestPathsPojo -> JS.Promise + /// selectDictionaries:bool -> JS.Promise + RequestPaths: bool -> JS.Promise + /// () -> JS.Promise + RequestFile: unit -> JS.Promise /// returns person jsons RequestPersons: unit -> JS.Promise } @@ -38,7 +38,8 @@ module Interop = type IARCitectInAPI = { TestHello: string -> JS.Promise /// JS.Promise - ResponsePaths: ResponsePathsPojo -> JS.Promise + ResponsePaths: string [] -> JS.Promise + ResponseFile: InteropTypes.ARCitectFile -> JS.Promise } @@ -52,13 +53,15 @@ type Msg = | Init of ApiCall | Save of ArcFiles /// ApiCall - | RequestPaths of ApiCall + | RequestPaths of ApiCall /// Selecting paths requires user input, which we cannot await. /// To avoid timeout `RequestPaths` simply returns true if call was successful, /// ... and `ResponsePaths` will be sent as soon as user selected the directories - | ResponsePaths of Interop.ResponsePathsPojo + | ResponsePaths of string [] /// expects person jsons | RequestPersons of ApiCall + | RequestFile of ApiCall + | ResponseFile of Interop.InteropTypes.ARCitectFile type Model = { diff --git a/src/Client/Update.fs b/src/Client/Update.fs index 28076526..c8df31b9 100644 --- a/src/Client/Update.fs +++ b/src/Client/Update.fs @@ -171,7 +171,6 @@ module DataAnnotator = ParsedFile = parsedFile } nextState, model, Cmd.none - module History = let update (msg: History.Msg) (model: Model) : Model * Cmd = match msg with diff --git a/src/Client/Update/ARCitectUpdate.fs b/src/Client/Update/ARCitectUpdate.fs index a156d5e4..3dc402b6 100644 --- a/src/Client/Update/ARCitectUpdate.fs +++ b/src/Client/Update/ARCitectUpdate.fs @@ -80,14 +80,33 @@ module ARCitect = GenericError (Cmd.none, exn("RequestPaths failed")) |> DevMsg |> Cmd.ofMsg state, model, cmd - | ARCitect.ResponsePaths pojo -> - match pojo.target with - | ARCitect.Interop.InteropTypes.ARCitectPathsTarget.FilePicker -> - let paths = Array.indexed pojo.paths |> List.ofArray - state, {model with FilePickerState.FileNames = paths}, Cmd.none - | _ -> - Browser.Dom.console.error("ResponsePaths: target not implemented:", pojo.target) - state, model, Cmd.none + | ARCitect.ResponsePaths paths -> + let paths = Array.indexed paths |> List.ofArray + state, {model with FilePickerState.FileNames = paths}, Cmd.none + + | ARCitect.RequestFile msg -> + log "Starting RequestFile" + match msg with + | Start () -> + let cmd = + Cmd.OfPromise.either + api.RequestFile + () + (Finished >> ARCitect.RequestFile >> ARCitectMsg) + (curry GenericError Cmd.none >> DevMsg) + state, model, cmd + | ApiCall.Finished wasSuccessful -> + let cmd = + if wasSuccessful then + Cmd.none + else + GenericError (Cmd.none, exn("RequestFile failed")) |> DevMsg |> Cmd.ofMsg + state, model, cmd + + | ARCitect.ResponseFile file -> + let dataFile = DataAnnotator.DataFile.create(file.name, file.mimetype, file.content, file.size) + let msg = dataFile |> Some |> DataAnnotator.UpdateDataFile |> DataAnnotatorMsg + state, model , Cmd.ofMsg msg | ARCitect.RequestPersons msg -> match msg with diff --git a/src/Client/Views/SidebarView.fs b/src/Client/Views/SidebarView.fs index ad6b62fe..3d221258 100644 --- a/src/Client/Views/SidebarView.fs +++ b/src/Client/Views/SidebarView.fs @@ -28,7 +28,7 @@ type SidebarView = Protocol.Templates.Main (model, dispatch) | {SidebarPage = Routing.SidebarPage.DataAnnotator } -> - Pages.DataAnnotator.Main(model, dispatch) + Pages.DataAnnotator.Sidebar(model, dispatch) | {SidebarPage = Routing.SidebarPage.JsonExport } -> JsonExporter.Core.FileExporter.Main(model, dispatch) From 9309f76a2d90290d78a78052f3b91fcae5a526a9 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Fri, 21 Feb 2025 15:36:46 +0100 Subject: [PATCH 10/11] only call global.window in function body to avoid reference error in non-browser environment --- src/Client/Util/MessageInterop.fs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Client/Util/MessageInterop.fs b/src/Client/Util/MessageInterop.fs index c7e5f060..50d1157a 100644 --- a/src/Client/Util/MessageInterop.fs +++ b/src/Client/Util/MessageInterop.fs @@ -28,7 +28,7 @@ type private PendingRequests = Dictionary unit) * (exn -> unit)> let private PendingRequests = PendingRequests() type InteropOptions = { - Target: Browser.Types.Window + Target: unit -> Browser.Types.Window GenericErrorHandler: exn -> unit } @@ -40,7 +40,7 @@ open Browser.Types module MessageInteropHelper = - let private sendMsgWithResponse (target: Browser.Types.Window) (payload: IMessagePayload) = + let private sendMsgWithResponse (target: unit -> Browser.Types.Window) (payload: IMessagePayload) = Promise.create (fun resolve reject -> // create timeout for response let timeout = @@ -51,7 +51,7 @@ module MessageInteropHelper = ) 5000 PendingRequests.Add(payload.requestId, (resolve, reject)) - target.postMessage(payload, "*") + target().postMessage(payload, "*") ) let rec private getReturnType typ = @@ -63,7 +63,7 @@ module MessageInteropHelper = else typ - let private proxyCall (target: Browser.Types.Window) (func: RecordField) = + let private proxyCall (target: unit -> Browser.Types.Window) (func: RecordField) = let argumentType : TypeInfo = match func.FieldType with @@ -94,7 +94,7 @@ module MessageInteropHelper = executeRequest requestBody // Function to generate a new instance dynamically - let buildOutProxyInner (target: Browser.Types.Window, resolvedType: Type) : 'T = + let buildOutProxyInner (target: unit -> Browser.Types.Window, resolvedType: Type) : 'T = if not (FSharpType.IsRecord resolvedType) then failwithf "MessageInterop-Error: Provided type is not a record. %s" resolvedType.FullName @@ -133,7 +133,7 @@ module MessageInteropHelper = | _ -> failwithf "MessageInterop-Error: Cannot build proxy. Exepected type %s to be a valid protocol definition which is a record of functions" resolvedType.FullName - let buildInProxyInner(recordType: 'i, recordTypeType: Type, target: Browser.Types.Window, handleGenericError) = + let buildInProxyInner(recordType: 'i, recordTypeType: Type, target: unit -> Browser.Types.Window, handleGenericError) = let schemaType = createTypeInfo recordTypeType match schemaType with @@ -196,13 +196,13 @@ module MessageInteropHelper = result ) - target.postMessage(payload, "*") + target().postMessage(payload, "*") } |> Promise.start | None -> let payload: IMessagePayload = {| content with error = Some "No API name given!"|} - target.postMessage(payload, "*") + target().postMessage(payload, "*") let handle = fun (e: Browser.Types.Event) -> @@ -235,7 +235,7 @@ module MessageInteropHelper = module MessageInterop = let createApi() : InteropOptions = { - Target = Browser.Dom.window.parent + Target = fun () -> Browser.Dom.window.parent GenericErrorHandler = fun exn -> Browser.Dom.console.error($"Proxy Error: {exn.Message}") } From d0a0029fb3331e52bf6ccf02a93ff8e216de8307 Mon Sep 17 00:00:00 2001 From: Kevin F Date: Fri, 21 Feb 2025 16:00:28 +0100 Subject: [PATCH 11/11] fix slow behaviour --- .../Pages/DataAnnotator/DataAnnotator.fs | 19 +++++++++++++------ src/Client/States/DataAnnotator.fs | 2 ++ src/Client/Update.fs | 6 ++++-- src/Client/Update/ARCitectUpdate.fs | 10 ++++++---- 4 files changed, 25 insertions(+), 12 deletions(-) diff --git a/src/Client/Pages/DataAnnotator/DataAnnotator.fs b/src/Client/Pages/DataAnnotator/DataAnnotator.fs index 0a8623be..55c386d2 100644 --- a/src/Client/Pages/DataAnnotator/DataAnnotator.fs +++ b/src/Client/Pages/DataAnnotator/DataAnnotator.fs @@ -101,11 +101,11 @@ module private DataAnnotatorHelper = ] ] - let RequestPathButton (fileName: string option, requestPath) = + let RequestPathButton (fileName: string option, requestPath, isLoading: bool) = let fileName = defaultArg fileName "Choose File" Html.label [ - prop.className "join flex" prop.onClick requestPath + prop.className "join flex" prop.children [ Html.button [ prop.className "btn btn-primary join-item" @@ -117,6 +117,13 @@ module private DataAnnotatorHelper = prop.value fileName prop.readOnly true ] + Html.span [ + prop.className "btn btn-primary join-item btn-disabled" + prop.children [ + if isLoading then + Daisy.loading [] + ] + ] ] ] @@ -346,7 +353,6 @@ type DataAnnotator = promise { let! content = e.text() let dtf = DataFile.create(e.name, e.``type``, content, e.size) - setShowModal true dtf |> Some |> UpdateDataFile |> DataAnnotatorMsg |> dispatch } |> Async.AwaitPromise @@ -355,9 +361,9 @@ type DataAnnotator = UpdateDataFile None |> DataAnnotatorMsg |> dispatch if ref.current.IsSome then ref.current.Value.value <- null - let requestFileFromARCitect = fun _ -> + let requestFileFromARCitect = fun (e: Browser.Types.MouseEvent) -> + e.preventDefault() if model.PersistentStorageState.IsARCitect then - setShowModal true Elmish.ApiCall.Start () |> ARCitect.RequestFile |> ARCitectMsg @@ -371,7 +377,8 @@ type DataAnnotator = | true -> DataAnnotatorHelper.DataAnnotatorButtons.RequestPathButton( model.DataAnnotatorModel.DataFile |> Option.map _.DataFileName, - requestFileFromARCitect + requestFileFromARCitect, + model.DataAnnotatorModel.Loading ) | false -> DataAnnotatorHelper.DataAnnotatorButtons.UploadButton ref model uploadFileOnChange diff --git a/src/Client/States/DataAnnotator.fs b/src/Client/States/DataAnnotator.fs index 83ee6e8b..7e3f7a62 100644 --- a/src/Client/States/DataAnnotator.fs +++ b/src/Client/States/DataAnnotator.fs @@ -100,10 +100,12 @@ type Model = { DataFile: DataFile option ParsedFile: ParsedDataFile option + Loading: bool } static member init () = { DataFile = None ParsedFile = None + Loading = false } type Msg = diff --git a/src/Client/Update.fs b/src/Client/Update.fs index c8df31b9..6129ae1f 100644 --- a/src/Client/Update.fs +++ b/src/Client/Update.fs @@ -154,8 +154,10 @@ module DataAnnotator = DataAnnotator.ParsedDataFile.fromFileBySeparator s file ) let nextState: DataAnnotator.Model = { - DataFile = dataFile - ParsedFile = parsedFile + state with + DataFile = dataFile + ParsedFile = parsedFile + Loading = false } nextState, model, Cmd.none | DataAnnotator.ToggleHeader -> diff --git a/src/Client/Update/ARCitectUpdate.fs b/src/Client/Update/ARCitectUpdate.fs index 3dc402b6..9519ea89 100644 --- a/src/Client/Update/ARCitectUpdate.fs +++ b/src/Client/Update/ARCitectUpdate.fs @@ -85,7 +85,6 @@ module ARCitect = state, {model with FilePickerState.FileNames = paths}, Cmd.none | ARCitect.RequestFile msg -> - log "Starting RequestFile" match msg with | Start () -> let cmd = @@ -94,19 +93,22 @@ module ARCitect = () (Finished >> ARCitect.RequestFile >> ARCitectMsg) (curry GenericError Cmd.none >> DevMsg) - state, model, cmd + let nextModel = + {model with DataAnnotatorModel.Loading = true; DataAnnotatorModel.DataFile = None; DataAnnotatorModel.ParsedFile = None} + state, nextModel, cmd | ApiCall.Finished wasSuccessful -> + let nextModel = {model with DataAnnotatorModel.Loading = false} let cmd = if wasSuccessful then Cmd.none else GenericError (Cmd.none, exn("RequestFile failed")) |> DevMsg |> Cmd.ofMsg - state, model, cmd + state, nextModel, cmd | ARCitect.ResponseFile file -> let dataFile = DataAnnotator.DataFile.create(file.name, file.mimetype, file.content, file.size) let msg = dataFile |> Some |> DataAnnotator.UpdateDataFile |> DataAnnotatorMsg - state, model , Cmd.ofMsg msg + state, {model with DataAnnotatorModel.Loading = true} , Cmd.ofMsg msg | ARCitect.RequestPersons msg -> match msg with