{ "version": 3, "sourceRoot": "Source", "sources": ["webws/DatatableTypes.fs", "webws/Routing.fs", "webws/AdminRouting.fs", "webws/ClientRouting.fs", "webws/PageState.fs", "webws/WSHelper.fs", "webws/UsersDisplay.fs", "webws/EntityDetail.fs", "webws/DatabasesDisplay.fs", "webws/DatabaseDisplay.fs", "webws/EntityDisplay.fs", "webws/FormHelpers.fs", "webws/DetailValueFormatter.fs", "webws/InstanceForm.fs", "webws/Datatable.fs", "webws/InstanceDisplay.fs", "webws/ImportPage.fs", "webws/ClientContent.fs", "webws/Client.fs", "webws/Templating.fs", "webws/Site.fs"], "sourcesContent": ["namespace web\n\nopen WebSharper\nopen WebSharper.UI\n\n[]\nmodule DatatableTypes =\n\n type PaginationState = {\n currentPage: int\n perPage: int\n }\n\n type SearchCriteria = {\n column: string;\n value: string\n }\n\n type SortDirection = |Asc |Desc\n type SortCriteria = {\n column: string option;\n direction: SortDirection\n }\n\n // types to support display of different types of instances lists:\n // - main list\n // - linked list (both to parents and to children)\n type LinkedTableInfo =\n {\n sourceInstanceId: Ids.InstanceId\n direction: Ids.RelationAndDirection\n }\n with\n override self.ToString() =\n let sourceId = Ids.InstanceId.Get self.sourceInstanceId\n match self.direction with\n | Ids.ChildrenVia (relationId) -> $\"{sourceId}_children_relation_{relationId|>Ids.RelationId.Get}\"\n | Ids.ParentsVia (relationId) -> $\"{sourceId}_parents_relation_{relationId|>Ids.RelationId.Get}\"\n type TableType =\n | Main\n | Linked of LinkedTableInfo\n | Linkable of LinkedTableInfo\n with\n override self.ToString() =\n match self with\n | Main -> \"main\"\n | Linked l -> \"linked_\" + l.ToString()\n | Linkable l -> \"linkable_\" + l.ToString()\n\n type TableDocInfo =\n {\n doc: WebSharper.UI.Doc\n refresh: unit -> unit\n numberOfRows: View\n\n }\n with\n static member fromDoc (doc:WebSharper.UI.Doc) =\n {\n doc = doc\n refresh = fun () -> ()\n numberOfRows = View.Const 0\n }\n[]\nmodule LinkedInstancesTypes =\n type RelatedInDirectionForIntInstanceId = |ParentsFor of int | ChildrenFor of int\n", "namespace web\nopen WebSharper\nopen Microsoft.AspNetCore.Authorization;\nopen WebSharper.UI.Html\nopen WebSharper.Sitelets\nopen WebSharper.UI\nopen WebSharper.UI.Html.Elt\nopen DatatableTypes\n\ntype LoginError = | AuthenticationError\n\ntype EndPoint =\n | [] Home\n | [] Instances of entityId:int * state:string option\n | [] Instance of instanceId:int * state:string option\n | [] CreateInstance of entityId:int\n | [] EditInstance of instanceId:int\n | [] About\n | [] Login of ReturnUrl: string option * errorCode: LoginError option\n | [] Logout\n | [] ForgotPassword\n | [] ResetPassword of token:string * email:string\n | [] Signup\n | [] ConfirmEmail of token:string * email:string\n | [] GetAttachment of detailValueId:int64\n | [] GetTableCsv of tableType:TableType *\n id:int *\n page:int *\n perPage:int *\n searchColumn:string *\n searchValue:string *\n sortColumn:string option*\n sortDirection:SortDirection\n | [] HandleUpload\n // The public form endpoint takes an optional GET parameter named \"responsive\". When present (with any value), the page includes the\n // iframeresizer code to communicate with the parent page and allow responsive resizing (https://github.com/davidjbradshaw/iframe-resizer)\n | [] PublicForm of entityId:int*responsive:string option\n | [] PublicFormSubmitted of entityId:int\n | [] Import of entityId:int\n // We add an endpoint that will actually be handled by the embedded Sitelet for admin pages.\n // We put everything in the wildcard, see https://github.com/dotnet-websharper/core/issues/1330\n | [] Admin of args:list\n\n\n[]\nmodule Routing =\n let router : WebSharper.Sitelets.Router =\n WebSharper.Sitelets.InferRouter.Router.Infer ()\n", "namespace web.admin\nopen web\nopen WebSharper\nopen WebSharper.Sitelets\nopen WebSharper.Sitelets.Router\nopen WebSharper.Sitelets.RouterOperators\n\n[]\nmodule AdminRouting=\n // Admin pages endpoints. Those are defined at the root, but are embedded in the app's main Sitelet\n // under the prefix \"/admin\"\n type AdminEndPoint =\n |[] Users\n |[] Databases\n |[] Database of databaseId:int\n |[] Entity of entityId:int\n |[]User of id:int\n // Router inferred from endpoints. It is used to define the Sitelet for the admin pages\n let router : WebSharper.Sitelets.Router =\n WebSharper.Sitelets.InferRouter.Router.Infer ()\n // This router can be used to generate admin routes including the \"/admin\" prefix\n let adminRouter: WebSharper.Sitelets.Router =\n r \"admin\" / WebSharper.Sitelets.InferRouter.Router.Infer ()\n", "namespace web\nopen WebSharper\n\n[]\n// Needed to install the client side routing in this specific module. Doing it in the module Routing led to an obscure error\n// with some client side function being called server side. Putting it here avoids that error.\n// It was moved here from ClientContent to make it available to the public form client code si it can redirect to an\n// endpoint after a successful public form submission.\nmodule ClientRouting =\n let installedRouter =\n Routing.router\n |> Sitelets.Router.Slice\n (fun endpoint ->\n match endpoint with\n | Home -> Some endpoint\n | Instances _ -> Some endpoint\n | Instance _ -> Some endpoint\n | EditInstance _ -> Some endpoint\n | CreateInstance _ -> Some endpoint\n | PublicForm _ -> Some endpoint\n | Import _ -> Some endpoint\n | Admin[\"users\"] -> Some endpoint\n | Admin[\"databases\"] -> Some endpoint\n | Admin[\"database\";_databaseId] -> Some endpoint\n | Admin[\"entity\";_entityId] -> Some endpoint\n | _ -> None\n )\n id\n |> WebSharper.UI.Router.Install Home\n", "namespace web\n// This is the way we save the state of the page in the URL to have the back button working.\n// The state of the page is kept in a Var that is created at first render in ClientContent.\n// As the state kept differs for each endpoint, we define a module below for each endpoint, in which\n// we define the State type and its Empty value used for initialisation.\n// From this state Var, we use lenses to derive other Vars to be used in widgets in the page. The widgets\n// update thir respective Vars, and this is reflected in the main state Var.\n// The stateVar is serialised and put in an optional GET parameter.\n// The same serialiasation is done for all pages, wiht the helpers fromStringOption and toStringOption below.\n// When the state Var is updated, a new entry is added in the browser's history with pushStateIfNeeded.\n//\n// The handling of the first back event requires special care. When the client side router is installed,\n// WebSharper creates a Var (https://github.com/dotnet-websharper/ui/blob/master/WebSharper.UI/Router.fs#L108)\n// holding the EndPoint value of the currently displayed page.\n// Thie Var is used to determine if the page needs to be redisplayed. This introduced a subtle bug:\n// Imagine this browsing history states:\n// A -> B -> C -> D\n// Throughout all this browsing, the client router's var is left untouched because the current EndPoint didn't change.\n// Even though the URL displayed in the address bar is updated thanks to the browser's History API, the client\n// side router has no view of this.\n// Then the user presses back. Now, the endpoint of the displayed page is updated to C, because this is a normal browsing\n// to a URL with the state C in the GET parameter.\n// If the user now takes an action in the page, like changing the display order in a table, the URL in the address bar\n// is updated accordingly (with state E), but the endpoint of the client side router is not updated. And this causes a problem if the\n// user now presses back. The client side router will see that the endpoint of the page to display (C) is exactly the same as\n// the endpoint it considers as displayed (C) because it is not aware that we went to state D.\n// One solution could be to make the client side router of all the state changes, but the problem is that this will trigger\n// a full page re-display. This is something we want to avoid.\n// The best solution found was to trigger a client side router refresh with `ClientRouting.installedRouter.Update (fun v -> v)`\n// Pros and cons:\n// + works!\n// - the installed router (which is a Var), is left out of sync. But this was actually already the case, we just didn't reflect the state in the URL\n// - we refresh the router at every step, while it's only needed at the first back after a forward change as explained above\n//\nopen WebSharper\nopen WebSharper.JavaScript\nopen WebSharper.UI\n[]\nmodule PageState =\n // It is not possible to add a constraint to ensure a record has a field.\n // See https://stackoverflow.com/a/39276278\n // This is the raison d'être of this interface\n type IState<'T> =\n // pushOnHistory has to be set to true when the app changes the state. However,\n // it is set to false before it is pushed on the history. This way, we avoid\n // pushing on history a URL that we visit following a press of the back button.\n abstract member pushOnHistory:bool\n // Return IState<_> so we can chain them\n abstract member withPushOnHistory:bool -> IState<'T>\n // get access to the state itself so it can be serialised\n abstract member toState:unit -> 'T\n\n // Encodes the state of the page in a string option that can be put in the EndPoint\n []\n let toStringOption<'a>(s:'a) =\n s|>WebSharper.Json.Serialize|> JS.EncodeURIComponent |> Some\n\n // Function to build the stateVar from the string option retrieved from the EndPoint\n []\n let fromStringOption<'a>(so:string option):Var<'a option>=\n match so with\n | None -> Var.Create None\n | Some s ->\n let parsedState:'a =\n s\n |> JS.DecodeURIComponent\n |> WebSharper.Json.Deserialize\n parsedState\n |> Some\n |> Var.Create\n // Adds an entry in the history if needed, i.e. if state.pushOnHistory=true\n []\n let pushStateIfNeeded<'T>(stateOption:IState<'T> option, buildEndPointWithState: string option-> EndPoint) =\n let h = JS.Window.History\n match stateOption with\n | None ->\n ()\n | Some st ->\n if st.pushOnHistory then\n // The state pushed on history is always false. See IState.pushOnHistory for reason.\n let pushedState:'T = st.withPushOnHistory(false).toState()\n // The link to be pushed on the history\n let endpoint = pushedState|>toStringOption|>buildEndPointWithState\n //ClientRouting.installedRouter.Set endpoint\n let link = Routing.router.Link(endpoint)\n // Add the entry in the history, but only if we push another state. Otherwise, we would\n // get 2 entries for the same page, eg when refreshing a table or refiltering a page with the same criteria.\n if h.State <> pushedState then\n h.PushState(pushedState,\"\",link)\n\n // All Vars used to store the individual state information are derived from the stateVar using Lenses.\n // This means that everytime a part of the state if modified, stateVar will be too. So using a Sink on\n // its views enables us to record every change of the state in the brower history.\n []\n let setupPushStateSink (stateVar:Var<_>)(stringOptionToEndPoint) =\n stateVar.View|> View.Sink (fun s ->\n pushStateIfNeeded(s |> Option.map (fun v -> v :>IState<_>), stringOptionToEndPoint)\n )\n\n // A popstate event is fired when a back event occurs.\n // When this occurs, we need to update the state so it corresponds to the state in the popped URL.\n []\n let setupPopStateListener (stateVar:Var<_>) =\n // This function is meant to fix the first back after a forward change (see above comments).\n // However, it currently is triggered at every `popstate` event as I didn't identify a criteria\n // to limit its action.\n let fixFirstBack(poppedState) =\n ClientRouting.installedRouter.Update (fun v -> v)\n\n // register listener only on first display of page\n match stateVar.Value with\n | None ->\n JS.Window.AddEventListener (\"popstate\", System.Action(fun e ->\n let state = JS.Inline(\"\"\"$0.state\"\"\",e)\n\n JavaScript.JS.SetTimeout (fun () ->\n fixFirstBack(state)\n // Zero timer just to put it at end of queue and execute it immediately\n ) 0 |> ignore\n ()\n )\n )\n | _ ->\n ()\n // Helper function to setup the Sink to run when stateVar is updated, and the listener to run\n // when a pop state event occurs.\n []\n let setupStateHandlers (stateVar:Var<_>) (stringOptionToEndPoint) =\n // This function will continuously update the URL so it contains the current page state\n setupPushStateSink stateVar stringOptionToEndPoint\n // Popstate occurs when a back event occurs, so we need to update state\n setupPopStateListener stateVar\n\n // Helper function to initialise the State Var and sinks and listeners.\n []\n let setupPageState (state:string option) (stringOptionToEndPoint)=\n let stateVar = state |> fromStringOption\n setupStateHandlers stateVar stringOptionToEndPoint\n stateVar\n\n // This module defines the state of the pages behind the EndPoint Instances(id,stateString option)\n // If a new information becomes part of the state, add it as a field to the State typei here, define a lens\n // on that field to get a Var, and use it as the Var holding the new state information.\n []\n module Datatable =\n open DatatableTypes\n type State =\n {\n sortCriteria : SortCriteria option\n searchCriteria: SearchCriteria option\n paginationState: PaginationState option\n pushOnHistory: bool\n }\n interface IState with\n member self.withPushOnHistory(b) = {self with pushOnHistory = b}\n member self.pushOnHistory = self.pushOnHistory\n member self.toState() = self\n let Empty = { sortCriteria = None; searchCriteria = None; paginationState = None; pushOnHistory = true}\n []\n module InstanceDisplay =\n open DatatableTypes\n type State =\n {\n map: Map\n pushOnHistory: bool\n }\n interface IState with\n member self.withPushOnHistory(b) = {self with pushOnHistory = b}\n member self.pushOnHistory = self.pushOnHistory\n member self.toState() = self\n let Empty = { map = Map.empty; pushOnHistory = true}\n", "namespace web\nopen Microsoft.AspNetCore.Identity\nopen System.Security.Claims\nopen System.Reflection\nopen System\n// for IEndpointRouteBuilder\nopen Microsoft.AspNetCore.Routing\n// for endpoints.Map\nopen Microsoft.AspNetCore.Builder\nopen Microsoft.AspNetCore\nopen Microsoft.AspNetCore.Authorization\nopen WebSharper.AspNetCore\nopen FSharp.Reflection\nopen FSharp.Core\n\nopen System.Collections.ObjectModel\n\n\nopen Microsoft.Extensions.DependencyInjection\n\n// For [Extension]\nopen System.Runtime.CompilerServices\nopen System.Runtime.InteropServices\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen NGettext\nopen WebSharper.UI\nopen WebSharper.UI.Client\n\ntype I18n(catalog:Catalog) =\n inherit Myowndb.I18n.Helpers(catalog)\n // Helpers to get a Html.Text wrapped translated string\n member self.tt (s ,[]values:obj array)=\n text (self.p(s,values) )\n member self.tn (singular, plural, selector,[]values:obj array)=\n text (self.n(singular, plural, selector, values))\n member self.tc(context, s)=\n text (self.c(context,s))\n member self.tcp (context, s, []values:obj array)=\n text (self.cp(context,s,values) )\n member self.tcn (context, singular, plural, selector,[]values:obj array)=\n text (self.cn(context,singular, plural,selector,values))\n member self.locale() =\n catalog.CultureInfo.TwoLetterISOLanguageName\nmodule I18n=\n let setResultError (msg:string) (result:Result<_,_>) =\n result\n |> Result.mapError (fun _ -> msg)\n\n[]\nmodule ClientHelpers =\n let debounce f t =\n let mutable timer:JavaScript.JS.Handle option = None\n fun _ ->\n Option.iter JavaScript.JS.ClearTimeout timer\n timer <- Some(JavaScript.JS.SetTimeout (fun() -> timer <- None; f()) t)\n let randomIntString factor =\n JavaScript.Math.Floor(JavaScript.Math.Random()*factor).ToString()\n // Make data types list easily available on the client\n let dataTypes:DataType.DataType list = JavaScript.JS.Inline(\"window.myowndb_dataTypes\")\n\n[]\nmodule WSExtensions =\n module Var =\n let setIfChanged x v = if x <> Var.Get v then Var.Set v x\n let setAndCallIfChanged x v f=\n if x <> Var.Get v then\n Var.Set v x; f\n module Doc =\n // This returns a tuple of\n // - the Doc for the input field\n // - a bool view indicating if the user has changed the value but the debounced value was not yet updated\n let debouncedInput attr delay (debouncedVar:Var) =\n // If the delay is 0 we don't debounce\n if delay = 0 then\n Doc.InputType.Text attr debouncedVar\n ,\n View.Const false\n ,\n // In this case the reset function does nothing. See below for more explanations.\n (fun () -> () )\n else\n // This implementation had a problem with client side DateTime validation:\n // A date is accepted in the format `2020-01-01` but is updated ot include the time an becomes `2020-01-01 10:32:59`.\n // The problem comes from the fact that updates only flow from the internalVar to the debouncedVar: the debouncedVar is not\n // supposed to be updated externally. If the debouncedVar is modified externally as for date values, it will be considered\n // as awaiting validation and will prevent the form to be submitted.\n let (internalVar:Var) = Var.Create (debouncedVar.Value)\n // We return a reset function that simply set our internal var to an empty string. This is needed due to the on-way flow\n // from internal Var to debouncedVar, and we need to give a way to reset the internal var when the debouncedVar is reset\n // externally, eg when the form is reset.\n let resetFunction() = internalVar.Set \"\"\n let awaitingValidation = View.Map2 (fun intern debounced -> intern <> debounced) internalVar.View debouncedVar.View\n let update = ClientHelpers.debounce (fun _-> Var.setIfChanged internalVar.Value debouncedVar) delay\n do internalVar.View |> View.Sink update\n\n Doc.InputType.Text attr internalVar\n ,\n awaitingValidation\n ,\n resetFunction\n let Prepend d1 d2 = Doc.Append d2 d1\n // To be used in a pipe. doc2Async |> PrependPipedAsync docFirst results in [docFirst doc2]\n let PrependPipedAsync d1 d2async = async {\n let! d2=d2async\n return Doc.Append d1 d2\n }\n\n module Remoting =\n let activeRpcs = Var.Create 0\n type RemotingWithActiveCounter() =\n inherit Remoting.AjaxRemotingProvider()\n\n override _.AsyncBase(handle, data) =\n // Increase the number of active Rpcs\n activeRpcs.Update (fun n -> n+1)\n // Start the call\n let resAsync = base.AsyncBase(handle, data)\n async {\n let! res = resAsync\n activeRpcs.Update (fun n -> n-1)\n return res\n }\n\n module View =\n // transform a list of views in a view of a list\n // this form is not tail recursive\n let rec sequence (l:View<'a> list) =\n let retn = View.Const\n let (<*>) = View.Apply\n let cons a l = a::l\n match l with\n | [] -> retn []\n | h :: t ->\n (retn cons)\n <*>\n h\n <*>\n sequence t\n[]\nmodule HtmlHelpers =\n open Css\n type InfoBoxKind = |Primary |Secondary |SuccessBox |Danger |Warning |Info |Light |Dark\n type InfoBoxTemplate = Templating.Template<\"templates/InfoBox.html\">\n let classes (l:string list) = attr.``class`` (String.concat \" \" l )\n type WebSharper.UI.Html.attr with\n static member classDynPredBoth (trueClass:string) (falseClass:string) (boolView:View)=\n boolView\n |> View.Map (fun b -> if b then trueClass else falseClass) |> attr.classDyn\n let wrapInCard (id:string) (title:string)(body:Doc) =\n div [classes [\"card\";\"mb-4\"]; attr.id id ] [\n div [classes [\"card-header\"]] [\n i [classes [\"fas\";\"fa-table\";\"me-1\"]] []\n text title\n ]\n div [classes [\"card-body\"]] [\n body\n ]\n ]\n let infobox (kind:InfoBoxKind) (content:Doc) =\n InfoBoxTemplate()\n .Kind((sprintf \"%A\" kind).ToLower().Replace(\"box\",\"\"))\n .Content(content)\n .Doc()\n let dangerBox (content:Doc) =\n infobox InfoBoxKind.Danger content\n let successBox (content:Doc) =\n infobox InfoBoxKind.SuccessBox content\n let primaryBox (content:Doc) =\n infobox InfoBoxKind.Primary content\n\n let fontAwesomeIconWithClasses (cssClasses:string list)(name:string) =\n // @ = List.append\n li [classes ([\"fas\"; $\"fa-{name}\"] @ cssClasses)] []\n let fontAwesomeIcon = fontAwesomeIconWithClasses []\n let flashDuration = 1000\n let setupFlashClassRemover (docId:string) =\n // Define a javascript to be called after a timeout that will remove the flash class to\n // avoid repeated flashing when new .flash elements are added\n let classRemover =\n JavaScript.JS.Inline(\"\"\"\n function() {\n var id = $0\n var selector = \"[data-flash-id='\"+id+\"']\"\n var el = document.querySelector(selector)\n el.classList.remove('flash')\n }\n \"\"\", docId)\n // The the timer to remove the flash class\n JavaScript.JS.SetTimeout (fun() -> classRemover() ) flashDuration |> ignore\n // This function returns an attribute to assign to the element having the \"flash\" CSS class.\n // It handles the removal of the \"flash\" CSS class to avoid repetition of the flash when other elements\n // with the flash class are added.\n let flashAttribute () =\n // Generate an id to assign to the li element, so that we can remove the flash class\n // when the animation is done (otherwise subsequent .flash element renderings will also\n // highlight this one)\n let elementId = ClientHelpers.randomIntString 1000\n setupFlashClassRemover elementId\n attr.``data-`` \"flash-id\" elementId\n // Helper to set attributes of a flashed element when the caller wants to set CSS classes\n let flashAttributesWithClasses (cssClasses:string list) =\n [\n classes ( List.append cssClasses [\"flash\"])\n flashAttribute()\n ]\n // Helper to set flash attributes when no class is set by the caller\n // Beware: you cannot Attr.concat your own classes attribute to the return value of this function.\n // Use flashAttributesWithClasses instead if you need to set your own classes.\n let flashExclusiveAttributes () =\n flashAttributesWithClasses []\n\n // Call this function in the attrs list of an element to have it focused after it was rendered\n let focusAfterRender()=\n on.afterRender(fun el ->\n JavaScript.JS.Inline(\"\"\"var e = $0; e.focus();\"\"\", el)\n )\n\n // Returns a button that will show `content` when clicked. The button of the text is updated\n // according to the visibility of the content.\n let buttonRevealingContent (cfg:{|buttonTextWhenVisible:Doc;buttonTextWhenHidden:Doc;|}) (content:Doc) =\n let contentDisplayed = Var.Create false\n let buttonText =\n contentDisplayed.View\n |> View.Map (fun b -> if b then cfg.buttonTextWhenVisible else cfg.buttonTextWhenHidden)\n [\n button\n [\n classes [BS.btn;BS.``btn-primary``]\n on.click (fun _el _ev -> contentDisplayed.Set (not contentDisplayed.Value); )\n ]\n [ buttonText.V]\n div\n [attr.classDynPredBoth \"d-block\" \"d-none\" contentDisplayed.View]\n [content]\n ]\n |> Doc.Concat\n // Displays a Doc with a tooltip on hover. Configured in app's common.css data-tooltip settings\n let withTooltip (tooltip:string) (content:Doc) =\n span [ attr.``data-`` \"tooltip\" tooltip ] [content]\n // Displays a question mark with a tooltip on hover.\n let helpIcon (tooltip:string) =\n withTooltip tooltip (fontAwesomeIcon \"question-circle\")\n\n // Returns if the element identified by selector s is present in the document\n // Runs as javascript in the document, but is a F# function usable in F# code.\n let selectorPresent(s:string) =\n JavaScript.JS.Inline(\"\"\"\n var selector = $0\n var el = document.querySelector(selector)\n return el != undefined\n \"\"\", s)\n\nopen HtmlHelpers\n\n\nmodule EndpointRouting =\n type EndpointProp ={ method: string * Http.RequestDelegate -> IEndpointConventionBuilder; path: string; policies: string list; isWildcard: bool }\n\n\n let private getEndpointProps (aspnetEndpoints:IEndpointRouteBuilder) (case:UnionCaseInfo) =\n let firstArg (att:CustomAttributeData) =\n att.ConstructorArguments |> Seq.head\n // we get a CustomAttributeTypedArgument that holds a readonly collection of CustomAttributeTypedArgument whose value is a boxed string\n let getMethod (att) : (string*Microsoft.AspNetCore.Http.RequestDelegate)-> Microsoft.AspNetCore.Builder.IEndpointConventionBuilder =\n match (firstArg att |> fun v -> v.Value |> unbox |> (fun (v:ReadOnlyCollection) -> unbox (v.Item(0).Value)) ) with\n | \"GET\" -> aspnetEndpoints.MapGet;\n | \"POST\" -> aspnetEndpoints.MapPost;\n | \"PUT\" -> aspnetEndpoints.MapPut;\n | \"DELETE\" -> aspnetEndpoints.MapDelete;\n | _ -> aspnetEndpoints.Map\n let getConstructorArguments (att:CustomAttributeData) =\n att.ConstructorArguments\n |> Seq.collect (fun a ->\n a.Value\n |> unbox\n |> Seq.map (fun (el:CustomAttributeTypedArgument)-> unbox (el.Value)))\n // Extracts endpoint arguments that are not put in the URL's path, ie they are posted form data or\n // placed in the query string.\n // These elements are specified in the endpoint's attribute\n let nonPathElements (case: UnionCaseInfo) =\n let attributes = case.GetCustomAttributesData()\n attributes\n |> Seq.fold (fun acc att ->\n match att.AttributeType.Name with\n |\"FormDataAttribute\"|\"QueryAttribute\" ->\n let args = getConstructorArguments att\n Seq.concat (seq [acc;args])\n | _ ->\n //printfn \"uknown attribute %s\" att.AttributeType.Name\n acc\n )\n Seq.empty\n\n // returns elements that are place in the url's PATH by Websharper.\n let getPathElements (case:UnionCaseInfo) =\n let ignored = nonPathElements case\n let fields = case.GetFields()|> Array.map (fun e -> e.Name)\n fields\n |> Seq.fold (fun acc n ->\n if Seq.contains n ignored then\n acc\n else\n Array.concat (seq [acc;[|n|]])\n )\n [||]\n // returns a string specifying the matched elements in the aspnet endpoint's path\n // format: /{argname1}/{argname2}...\n // empty if none\n // this is meant to be concatenated to the websharper endpoint's path present in the attribute\n let dynamicPathElements (case:UnionCaseInfo)=\n let elements = getPathElements case\n let suffix= elements\n |> Array.fold (fun acc e ->\n acc+\"/{\"+e+\"}\"\n )\n \"\"\n suffix\n // See https://learn.microsoft.com/en-us/aspnet/core/fundamentals/routing?view=aspnetcore-7.0#route-templates\n // A wildcard is indicated by a star before the path component.\n let makeEndpointPropsWildcardIfNeeded (r:EndpointProp) =\n if r.isWildcard then\n let lastCurlyOpen = r.path.LastIndexOf(\"{\")\n let newPath = r.path.Remove(lastCurlyOpen,1).Insert(lastCurlyOpen,\"{*\")\n { r with path = newPath}\n else\n r\n // iterates over all CustomAttributeData and accumulates info in the record r\n let rec getEndpointPropsInternal (atts:CustomAttributeData seq) (r:EndpointProp)=\n match atts|>List.ofSeq with\n | [] -> r\n | att::t ->\n match att.AttributeType.Name with\n // The EndPointAttribute case will handle the arguments passed to the EndPoint annotation\n | \"EndPointAttribute\" ->\n // this holds the path and possibly the method\n let annotation:string = string (att|> firstArg).Value\n let suffix = (dynamicPathElements case)\n // helper function to get the path from an annotation's string\n let buildPath ann = (sprintf \"%s%s\" ((ann|> string |> fun s -> s.Trim('\"')).Trim('/')) suffix )\n // Inspired from WebSharper.Core/src/sitelets/WebSharper.Sitelets/RouterAttributeReader.fs:176\n // The EndPoint annotation is either only a path, or a method followed by a path (separated by a space)\n match annotation.IndexOf(\" \") with\n // No method was specified\n | -1 ->\n // Recurse without changing the method\n getEndpointPropsInternal t {r with path = buildPath (firstArg att)}\n // A method was specified, extract it and include it in the recursive call\n | i ->\n // The part before the space is the method\n let annotatedMethod = annotation.Substring(0, i)\n // After the space is the path\n let annotatedPath = annotation.Substring(i + 1)\n\n // Get the method's function to be passed in the recursive call\n let method : (string*Microsoft.AspNetCore.Http.RequestDelegate)-> Microsoft.AspNetCore.Builder.IEndpointConventionBuilder =\n match annotatedMethod with\n | \"GET\" -> aspnetEndpoints.MapGet;\n | \"POST\" -> aspnetEndpoints.MapPost;\n | \"PUT\" -> aspnetEndpoints.MapPut;\n | \"DELETE\" -> aspnetEndpoints.MapDelete;\n | _ -> aspnetEndpoints.Map\n\n // Do recursive call with data extracted from annotation\n getEndpointPropsInternal t {r with path = buildPath annotatedPath ; method = method}\n | \"MethodAttribute\" ->\n // this holds the HTTP method for the endpoint\n // in the record we set the corresponding endpoint.Map${Method}\n getEndpointPropsInternal t {r with method = (getMethod att) }\n | \"FormDataAttribute\" -> r\n | \"WildcardAttribute\" ->\n // We just mark the record as wildcard so it can be handled after all attributes have been seen.\n getEndpointPropsInternal t {r with isWildcard = true}\n | \"AuthorizeAttribute\" ->\n // here we handle the policies\n // a.MemberName = \"Policy\"\n // a.MemberInfo = \"Policy\"\n // a.TypedValue = \"Admin\"\n let args = att.NamedArguments\n match args|>Seq.length with\n // Authorize without arguments is requiring authentication\n | 0 -> getEndpointPropsInternal t { r with policies=\"Authenticate\"::r.policies}\n // policies listed are all required, there's no further flexibility here\n | _ -> getEndpointPropsInternal t { r with policies=(List.concat [| r.policies;\n (args\n |> Seq.toList\n |> List.map (fun a -> a.TypedValue.ToString().Trim('\"'))\n )\n |])}\n | _ ->\n //printfn \"Unknown Attribute: %s with args %A\" att.AttributeType.Name att.ConstructorArguments\n getEndpointPropsInternal t r\n let attributes = case.GetCustomAttributesData()\n let r = getEndpointPropsInternal attributes {method= aspnetEndpoints.MapGet; path=\"\"; policies=[]; isWildcard=false }\n makeEndpointPropsWildcardIfNeeded r\n\n\n\n type EndpointKind = |Remoting |Page\n let MapWebSharperEndpointsInternal<'T>(aspnetEndpoints:IEndpointRouteBuilder) (kind:EndpointKind)=\n\n let ws = aspnetEndpoints.CreateApplicationBuilder()\n .UseWebSharper( fun builder -> builder.SiteletAssembly(Assembly.GetExecutingAssembly()) |> ignore)\n .Build()\n let endpointsType = typeof<'T>\n let duCases =\n Reflection.FSharpType.GetUnionCases endpointsType\n duCases |> Array.iter (fun c ->\n let props = getEndpointProps aspnetEndpoints c\n let builder = match kind with\n | Page -> props.method(props.path,ws)\n | Remoting ->\n aspnetEndpoints.MapPost(props.path,ws)\n // Only call RequireAuthorization if some policies are present, otherwise\n // even endpoint without authorize annotation will require an authentication...\n if List.length props.policies > 0 then\n builder.RequireAuthorization(props.policies|>List.toArray) |> ignore\n )\n\n let MapWebSharperEndpoints<'T>(aspnetEndpoints:IEndpointRouteBuilder) =\n MapWebSharperEndpointsInternal<'T> aspnetEndpoints Page\n let MapWebSharperRemotingEndpoints<'T>(aspnetEndpoints:IEndpointRouteBuilder) =\n MapWebSharperEndpointsInternal<'T> aspnetEndpoints Remoting\n\n[]\ntype ApplicationBuilderExtensions =\n []\n static member UseWebSharperEndpointRouting<'T>\n (\n this: IApplicationBuilder\n ) =\n // POST requests with x-websharper-rpc are handled here\n // this means that non-POST requests with that header are not sent to websharper\n this.MapWhen( (fun httpContext -> httpContext.Request.Headers.ContainsKey(\"x-websharper-rpc\") && httpContext.Request.Method=\"POST\") ,\n (fun (app:IApplicationBuilder)-> app\n .UseRouting()\n .UseAuthentication()\n .UseAuthorization()\n .UseEndpoints(fun endpoints ->\n EndpointRouting.MapWebSharperRemotingEndpoints<'T>(endpoints))\n |> ignore\n )\n )\n // requests without the x-websharper-rpc header are handled here.\n .MapWhen( (fun httpContext -> not (httpContext.Request.Headers.ContainsKey(\"x-websharper-rpc\"))) ,\n (fun (app:IApplicationBuilder)-> app\n .UseRouting()\n .UseAuthentication()\n .UseAuthorization()\n .UseEndpoints(fun endpoints ->\n EndpointRouting.MapWebSharperEndpoints<'T>(endpoints))\n |> ignore\n )\n )\n[]\nmodule ClientI18n =\n open WebSharper.JavaScript\n\n [)>]\n type JStr() =\n [, \"/vendor/gettext_spread.js\")>]\n member _.t (s:string,[] args:obj array) : string=\n JS.Inline (\"\"\"\n return spread_gettext(window.myowndb_i18n,$0,$1)\n \"\"\", s, args)\n\n member self.tt(s:string,[] args:obj array) =\n text (self.t(s,args))\n\n [, \"/vendor/gettext_spread.js\")>]\n member _.n (s:string,plural:string,n:int64,[]o:obj array)=\n JS.Inline (\"\"\"\n return spread_ngettext(window.myowndb_i18n,$0,$1,$2,$3)\n \"\"\", s, plural, n, o)\n\n member self.tn(s:string,plural:string,n:int64,[] args:obj array) =\n text (self.n(s,plural, n,args))\n\n // Translate msgid in domain. Doesn't handle plurals or context.\n [, \"/vendor/gettext_spread.js\")>]\n member _.td (domain:string,s:string,[]o:obj array)=\n JS.Inline (\"\"\"\n return spread_dgettext(window.myowndb_i18n,$0,$1,$2)\n \"\"\", domain, s, o)\n\n let t = JStr()\n\n // Make this module auto open, so that code opening ClientI18n also get access to\n // its functions.\n []\n module NotificationSubscriptionTranslations =\n open NotificationSubscriptionCriteria\n let translateNotificationEvent(e:Event) =\n match e with\n | AfterCreate -> t.t(\"Creation\")\n let translateNotificationProtocol(e:Protocol) =\n match e with\n | Smtp -> t.t(\"Email\")\n\n\nopen ClientI18n\n\n// Code handling MyOwnDB help display\n[]\nmodule MyOwnDBHelp=\n open WebSharper.JavaScript\n\n // Function parsinga markdown string to HTML, client-side\n [)>]\n let parseMarkdown (s:string) =\n JS.Inline (\"\"\"\n return marked.parse($0);\n \"\"\", s)\n\n // Function sanitising the HTML it receives as argument.\n [)>]\n let purifyHTML (s:string)=\n JS.Inline (\"\"\"\n return DOMPurify.sanitize($0)\n \"\"\", s)\n\n\n type HelpTranslation()=\n // Helper to translate the help message id to its string found in the myowndbhelp.po file, hence the\n // gettext domain \"myowndbhelp\" passed as first argument.\n member _.tHelp(msgid:string,[] args:obj array)=\n t.td(\"myowndbhelp\",msgid,args)\n // Helper to display the help frame for the msgid.\n member self.helpBlock(msgid:string,[] args:obj array)=\n self.tHelp(msgid,args)\n // Help translations are in the markdown format, parse it\n |> parseMarkdown\n // Just to be sure, sanitise it\n |> purifyHTML\n // Create a Doc instance from the string\n |> Doc.Verbatim\n // Wrap it in a box that can be identified as being help\n |> primaryBox\n\n let th= HelpTranslation()\n\n // Types that when translated to javascript give driver config objects\n [)>]\n [)>]\n type DriverPopover = {title: string; description: string}\n type DriverStep = {element: string; popover: DriverPopover}\n type DriverTour =\n { steps: DriverStep array}\n // Helper function to set the tour steps on a page\n let setPageTour (tour: DriverTour ) =\n JS.Inline (\"\"\"\n var tour = $0;\n window.tour = tour\n // Set the window.tour.\n // We set it on window to make it global, so that it is accessible from the\n // menu icon, which is only generated at the first page render, not when\n // the body of the page is update by ClientContent.fs\n // We set the tour object globally so that the driver object is only constructed when\n // the use clicks on the help icon. Constructing the driver object here is problematic with\n // client side generated content as it is possibly not yet available here.\n \"\"\", tour)\n\n // Trigger showing the tour\n let showTour() =\n JS.Inline (\"\"\"\n // Assign to local variable. I think it prevents some quirks?\n var fullTour = window.tour\n // Filtering function, to keep only elements found\n // We do it this way to be able to show tours for client side generated content.\n // We filter out inexisting elements so we can be generic in the tour definition, and\n // still be sure only existing elements will be covered.\n function elementPresent(step) {\n return document.querySelector(step.element) != null\n }\n // Filter the steps of the full tour\n var filteredsteps = fullTour.steps.filter(elementPresent)\n // Clone the full tour\n var realTour = structuredClone(fullTour)\n // and set its steps so only existing elements are included\n realTour.steps = filteredsteps\n // and build the driverObj with it\n var driverObj = window.driver.js.driver(realTour);\n // Start the tour\n driverObj.drive();\n \"\"\")\n\n // Tour building functions\n module Tour =\n // Build a DriverStep instance from the 3 strings\n let newStep (selector:string)(title:string)(description:string) =\n { element= selector; popover = {title=title; description=description}}\n\n // Initialise a tour with no step\n let newTour () : DriverTour=\n { steps =\n [| |]\n }\n\n // Add a step to the tour passed as last parameter\n let addStep (selector:string)(title:string)(description:string) (tour:DriverTour)=\n // Only add the step if the element targetted is present. This simplifies the definitions\n // of tour as there's no attention to be spent on knowing if user is admin or not\n {tour with steps = Array.append tour.steps [|newStep selector title description|]}\n\n // Takes an array of the form [| [| selector; title; desc |] ; ....|]\n // and returns a DriverTour with these steps\n let fromTuple (a: (string*string*string) array) =\n a\n |> Array.fold\n // Folder adds the step to the current tour\n (fun tour (selector,title,description) -> tour |> addStep selector title description)\n // Initialise with an empty tour\n (newTour())\n\n let setPageTourFromTuples (a: (string*string*string) array) =\n a\n |> fromTuple\n |> setPageTour\n\n\n // Returns the icon to be shown in the menu.\n // Is a function so that it can possibly be expanded with additional\n // behaviour setup.\n let tourMenuIcon() =\n fontAwesomeIcon \"info-circle\"\n\n // Disable the tour, displaying a default tour\n let resetTour() =\n JS.Inline (\"\"\"\n var step = $0\n var tour = { steps : [ step ] };\n var driverObj = window.driver.js.driver(tour);\n window.show_tour=driverObj.drive;\n \"\"\",\n Tour.newStep \"#pageTourIcon\" (th.tHelp(\"Guided tour\")) (th.tHelp(\"You clicked on the right icon to ask for a guided tour. Unfortunately there is no guided tour around this page.\")))\n\n\n\n[]\nmodule JsonHelpers =\n let deserialisedEmptyDataTable = [|new Map([||]) |]\n let deserialiseDataTable (json:string) =\n Json.Decode array>(Json.Parse json )\n\n[]\nmodule DeleteConfirmation =\n open Css\n []\n type BSTooltip() =\n []\n []\n member this.Hide() = WebSharper.JavaScript.Interop.X<_>\n []\n member this.Dispose() = WebSharper.JavaScript.Interop.X<_>\n\n // Function displaying a custom element triggering the display of a confirmation\n // request before an action is taken.\n // The first argument is a function taking as argument one Attr (which is the onclick\n // attribute that is defined here and which the caller has to set on the element\n // supposed to trigger the deletion)\n // The second argument is the action to take if the user confirms.\n let customDeleteConfirmation (docFn:Attr -> Doc)(takeAction:unit->Async)(confirmationQuestion:string) =\n let deleteStep = Var.Create 0\n deleteStep.View\n |> View.Map(fun step ->\n let dustbin =\n docFn\n (\n on.click\n (fun ev el ->\n deleteStep.Set 1)\n\n )\n match step with\n | 0 ->\n dustbin\n | 1 ->\n let tooltipId = string (System.Random().Next())\n let tooltipVar:Ref = ref Unchecked.defaultof<_>\n span [ Attr.Create \"data-bs-toggle\" \"tooltip\"\n Attr.Create \"data-bs-placement\" \"top\"\n Attr.Create \"title\" confirmationQuestion\n attr.id tooltipId\n on.afterRender (fun el ->\n tooltipVar.Value <-(\n JavaScript.JS.Inline(\"\"\"\n var el = document.getElementById($0)\n var tt = new bootstrap.Tooltip(el)\n return tt\n \"\"\", tooltipId)\n )\n )\n ]\n [\n span [classes [BS.``text-danger``; BS.``px-2``]\n on.click(fun el ev ->\n async {\n let! result = takeAction()\n if result then\n deleteStep.Set -1\n tooltipVar.Value.Dispose()\n else\n deleteStep.Set 3\n tooltipVar.Value.Dispose()\n }|> Async.Start\n )\n ]\n [t.tt(\"Yes\")]\n span\n [on.click\n (fun el ev->\n deleteStep.Set 0\n tooltipVar.Value.Dispose()\n )\n ]\n [t.tt(\"No\")]\n ]\n // Error\n | 3 -> span [] [t.tt(\"An error occured\");dustbin]\n | _ -> span [] []\n )\n\n let deleteConfirmation (target:string)(takeAction:unit->Async) =\n customDeleteConfirmation\n (\n fun onclick ->\n span [\n classes [ $\"myowndb-delete-{target}\" ]\n attr.``data-`` \"myowndb-action\" \"delete\";\n onclick\n ]\n [\n // Use of class me-5 for display in tables. It makes the yes be under the cursor\n // for easy confirmation in datatable action cells\n li [ classes [\"fas\"; \"fa-trash-alt\"; BS.``me-5``] ] []\n ]\n )\n takeAction\n (t.t(\"Confirm deletion?\"))\n", "namespace web.admin\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen web.ClientI18n\nopen web.HtmlHelpers\nopen web.WSExtensions\nopen web.Css\n\n[]\nmodule UsersDisplay =\n\n // This is called by the ClientContent.clientBody() to render the body of the page\n // according to the client-side router state.\n let pageBody () = async {\n let t = JStr()\n let! users = Server.Users.getUsers()\n let usersCollection =\n ListModel.Create\n (fun (u:User.User) -> u.id)\n []\n let resultVar = Var.Create Doc.Empty\n let res =\n match users with\n | Ok l ->\n usersCollection.Set (l|> Seq.ofList)\n resultVar.Set Doc.Empty\n | Error es ->\n usersCollection.Set [||]\n resultVar.Set(\n infobox\n (InfoBoxKind.Danger)\n (t.tt(\"An error occured\"))\n )\n\n // If the editedUser Var holds Some user, we will display the edition for for that user\n let editedUser:Var> = Var.Create None\n // Function generating the form to edit the user passed as\n let editionFormForUser (user:User.User) =\n // Put the user in a var and create lenses to easily link it to form fields\n let u = Var.Create user\n let firstname =\n u.Lens\n (fun u -> u.firstname|> Option.defaultValue \"\")\n (fun u v ->\n if v = \"\" then\n {u with firstname=None}\n else\n {u with firstname=Some v}\n )\n let lastname =\n u.Lens\n (fun u -> u.lastname|> Option.defaultValue \"\")\n (fun u v ->\n if v = \"\" then\n {u with lastname=None}\n else\n {u with lastname=Some v}\n )\n let email =\n u.LensAuto (fun u -> u.email)\n let userTypeId =\n u.LensAuto (fun u -> u.user_type_id)\n form\n [ attr.id \"admin_users_form\"]\n [\n label [attr.``for`` \"userEditionFirstname\"] [t.tt(\"Firstname\")]\n Doc.InputType.Text [attr.id \"userEditionFirstname\"] firstname\n\n label [attr.``for`` \"userEditionLastname\"] [t.tt(\"Lastname\")]\n Doc.InputType.Text [attr.id \"userEditionLastname\"] lastname\n\n label [attr.``for`` \"userEditionEmail\"] [t.tt(\"Email\")]\n Doc.InputType.Email [attr.id \"email\"; attr.id \"userEditionEmail\"; ] email\n\n label [attr.``for`` \"userEditionUsertype\"] [t.tt(\"User type\")]\n Doc.InputType.Select\n [attr.id \"userEditionUsertype\";]\n (fun id -> if id=1 then (t.t(\"Administrator\")) else t.t(\"Standard\"))\n [1;2]\n userTypeId\n\n Doc.Button\n (t.t(\"Save\"))\n [classes [BS.btn; BS.``btn-primary``]]\n (fun () ->\n async {\n let emailElt = (downcast JavaScript.JS.Document.GetElementById(\"userEditionEmail\"): WebSharper.JavaScript.HTMLInputElement)\n if emailElt.CheckValidity() then\n let! r =\n if u.Value.id = Ids.UserId 0 then\n Server.Users.createUser u.Value\n else\n Server.Users.updateUser u.Value\n match r with\n | Ok [u] ->\n // We get the updated user back, inject it in the users collection used to display the table\n // Add updates an existing entry\n usersCollection.Add u\n // Notify of the success\n resultVar.Set (infobox InfoBoxKind.SuccessBox (t.tt \"User saved successfully\"))\n // Get out of user edition, hiding the form\n editedUser.Set None\n // This Ok l should not happen as single row result is ensured server side\n | Ok _ ->\n resultVar.Set (infobox InfoBoxKind.Danger (t.tt(\"An error occured\")))\n | Error es ->\n resultVar.Set (infobox InfoBoxKind.Danger (text (es|>Error.toString)))\n }\n |> Async.Start\n )\n Doc.Button\n (t.t(\"Cancel\"))\n [classes [BS.btn; BS.``btn-secondary``]]\n // Cancelling is simply going to a state where no user edition is done\n (fun () -> editedUser.Set None)\n ]\n // The view displaying the for or an empty doc according to the editedUser Var value.\n let editionformView () =\n editedUser.View\n |> View.Map (fun uo ->\n match uo with\n | None -> Doc.Empty\n | Some u -> editionFormForUser u\n )\n\n let usersTable =\n usersCollection.View\n |> View.Map\n (fun l ->\n let deleteElement (u:User.User)=\n web.DeleteConfirmation.deleteConfirmation \"user\" (\n (fun () -> async {\n match! Server.Users.deleteUser u with\n | Ok _ ->\n usersCollection.Remove u\n resultVar.Set Doc.Empty\n // signal success\n return true\n | Error es ->\n resultVar.Set(\n infobox\n (InfoBoxKind.Danger)\n (text (es|>Error.toString))\n )\n // signal failure\n return false\n })\n )\n let resetPasswordElement (u:User.User)=\n button\n [ classes [BS.btn; BS.``btn-secondary``]\n on.click\n (fun ev el ->\n async {\n let! res = Server.Users.resetPassword u\n match res with\n | Ok _ ->\n resultVar.Set (infobox InfoBoxKind.SuccessBox (t.tt \"The user has received a mail to reset the password. The old password was invalidated.\"))\n | Error _ ->\n resultVar.Set( infobox (InfoBoxKind.Danger) (t.tt(\"An error occured\")))\n return ()\n }\n |> Async.Start\n )\n ]\n [\n t.tt(\"Force password reset\")\n ]\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id \"admin_users_table\" ]\n [\n thead []\n [\n tr []\n [\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Firstname\")]\n ]\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Lastname\")]\n ]\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Email\")]\n ]\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"User type\")]\n ]\n\n ]\n\n ]\n\n tbody []\n [\n l\n |> Seq.map (fun u ->\n tr\n []\n [\n td [classes [BS.``table-sm``]] [text (u.firstname|> Option.defaultValue \"\")]\n td [classes [BS.``table-sm``]] [text (u.lastname|> Option.defaultValue \"\")]\n td [classes [BS.``table-sm``]] [text u.email]\n td [classes [BS.``table-sm``]] [if u.user_type_id = 1 then t.tt(\"Administrator\") else t.tt(\"Standard user\") ]\n td [classes [BS.``table-sm``;\"myowndbactioncell\";]\n on.click (fun ev el ->\n // Remove previous feedback\n resultVar.Set Doc.Empty\n // Trigger form display\n editedUser.Set (Some u)\n // The form is at the top of the page, scroll to it\n JavaScript.JS.Window.ScrollTo(0,0)\n )\n ] [ a [attr.``data-`` \"myowndb-action\" \"edit\";] [li [ classes [\"fas\"; \"fa-edit\"; BS.``me-5``;\"myowndb-action-cell\"]] [] ]]\n td [classes [BS.``table-sm``;\"myowndbactioncell\"];\n ] [ (deleteElement u).V ]\n td [classes [BS.``table-sm``;\"myowndbactioncell\"];\n ] [ a [attr.``data-`` \"myowndb-action\" \"resetpw\"] [(resetPasswordElement u)]]\n ]\n )\n |> Doc.Concat\n\n ]\n ]\n )\n\n return div\n []\n [\n Doc.Button\n (t.t(\"Add new\"))\n [classes [BS.btn; BS.``btn-primary``]]\n (fun () ->\n resultVar.Set Doc.Empty\n editedUser.Set (Some(User.Init())))\n editionformView().V\n resultVar.V\n usersTable.V\n ]\n }\n", "namespace web.admin\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen web.ClientI18n\nopen web.HtmlHelpers\nopen web.WSExtensions\nopen web.Css\n\n[]\nmodule EntityDetail =\n\n //********************************************************************************\n // Elements to add a new detail\n //********************************************************************************\n // With type constraints making the function can be required, but I think it works here without inlining\n // because we use an interface as constraint.\n let addNewDetailSection<'T when 'T:>Specs.IDetailSpec<'T>>\n (initialiseSpec:unit -> 'T)\n (serverCall:'T->Async>)\n (refreshList:unit->Async)\n (buttonText:Doc)=\n\n let datatypeSpecs:Specs.DataTypeSpec list = web.ClientHelpers.dataTypes |> List.map(fun dt -> dt.toSpec() )\n let formDisplayedVar = Var.Create false\n let entityDetailSpecVar:Var<'T> =\n Var.Create\n (initialiseSpec())\n // lenses on DetailSpec's fields\n let dataTypeVar =\n entityDetailSpecVar.Lens\n (fun r -> (r:>Specs.IDetailSpec<'T>).dataType)\n (fun r v -> (r:>Specs.IDetailSpec<'T>).withDataType v)\n // A lens to the propositions field, which is an option\n let entityDetailPropositionsVar =\n entityDetailSpecVar.Lens\n (fun r -> (r:>Specs.IDetailSpec<'T>).propositions)\n (fun r v -> (r:>Specs.IDetailSpec<'T>).withPropositions v)\n let newDetailNameVar =\n entityDetailSpecVar.Lens\n (fun r -> (r:>Specs.IDetailSpec<'T>).name)\n (fun r v -> (r:>Specs.IDetailSpec<'T>).withName v )\n // The list of propositions entered by the user is lensed into the spec too. But there's some more transformation\n // as the code below uses a list of strings\n // Manipulating a list of string is easier below as it allows the use of the DocSeqCached function\n let propositionsVar:Var> =\n entityDetailSpecVar.Lens\n (fun (r:'T) ->\n match (r:>Specs.IDetailSpec<'T>).propositions with\n | Some l -> l |> List.map (fun i -> i.value )\n | None -> []\n )\n (fun (r:'T) (strList) ->\n if List.length strList = 0 && (r:>Specs.IDetailSpec<'T>).dataType.name <> \"choose in list\" then\n (r:>Specs.IDetailSpec<'T>).withPropositions None\n else\n Some (strList |> List.map (fun s -> {detailValuePropositionId = None; value = s}:Specs.DetailValuePropositionItemSpec))\n |> (r:>Specs.IDetailSpec<'T>).withPropositions\n )\n // When we select a data type with propositions, set the entityDetailPropositionsVar to Some []\n // We set an empty list\n let propositionsBackup:Var = Var.Create None\n dataTypeVar.View\n |> View.Sink\n (fun selectedDataType ->\n let chooseInList = (datatypeSpecs |> List.find(fun dt -> dt.name = \"choose in list\"))\n\n // As updating the lens updates the base object it seems we got in a loop here.\n // Those extensive conditions break the loop\n if (selectedDataType = chooseInList) && entityDetailPropositionsVar.Value.IsNone then\n match propositionsBackup.Value with\n | Some _ ->\n // If propositions were backed up, restore these\n entityDetailPropositionsVar.Set (propositionsBackup.Value)\n | None ->\n // If no proposition is backed up, initialise with an empty list\n entityDetailPropositionsVar.Set (Some [])\n else if (selectedDataType <> chooseInList) && entityDetailPropositionsVar.Value.IsSome then\n // BAckup current propositions to restore in other branch of the if\n propositionsBackup.Set entityDetailPropositionsVar.Value\n entityDetailPropositionsVar.Set None\n )\n\n // A bool view indicating if the submit button is disabled, so true = button is disabled\n let submitDisabledView =\n View.Map3\n (fun name propositions (dataType:Specs.DataTypeSpec)->\n // Disable if name is empty or when the data type is choose in list and there is no proposition\n name = \"\" || ( dataType.name = \"choose in list\" && propositions = [])\n )\n newDetailNameVar.View\n propositionsVar.View\n dataTypeVar.View\n\n // Build the list of propositions entered by the user.\n // We do it outside of the function generating the div view below so that only\n // the new proposition is rendered\n let propositionsListDoc =\n propositionsVar.View.DocSeqCached (fun p ->\n // Return the li element, with the flash class set\n li\n [classes [\"flash\"]; flashAttribute()]\n [\n // The value of the proposition\n text p\n // The trash icon to delete this proposition from the list\n span\n [ on.click (fun _el _ev ->\n // Filtering propositions different from this one will remove it.\n propositionsVar.Set (propositionsVar.Value |> List.filter (fun v -> v<>p))\n )]\n [\n fontAwesomeIconWithClasses [BS.``ms-1``] \"trash\"\n ]\n\n ]\n\n )\n // This is the view displaying elements to manage value propositions\n // It is based on the entityDetailPropositionsVar indicating if propositions should be managed\n // with a Some value\n let propositionsDocView =\n entityDetailPropositionsVar.View\n // Use View.MapCached here as all record field lenes are updated as soon as one field is updated.\n // Not using the cache here rerenders the propositions input field and focuses it as soon as one\n // character is typed in the detail name.\n |> View.MapCached (fun propositions ->\n match propositions with\n // If the propositions in the spec is None, nothing to show\n | None ->\n Doc.Empty\n // If the propositions in the space is Some _, then show the management of propositions.\n // We don't use the value though as we manipulate the string list and not the DetailValuePropositionItemSpec list.\n | Some _ ->\n let newPropositionVar = Var.Create \"\"\n // Add proposition to list when enter is pressed\n let addOnEnter () =\n on.keyUp\n (fun el ev ->\n if ev.KeyCode = 13 then\n propositionsVar.Set (List.append propositionsVar.Value [newPropositionVar.Value]|> List.distinct)\n newPropositionVar.Set \"\"\n )\n\n // This is the UI to manage propositions\n div\n []\n [\n // Name of the detail\n label [attr.``for`` \"newProposition\"] [t.tt(\"Add proposition\")]\n // We need to focus it after render because it is re-rendered every time we add a proposition\n // because it is locate in the View.Map. Without this, it loses focus after a proposition is added\n // by pressing enter.\n Doc.InputType.Text [attr.id \"newProposition\";focusAfterRender();addOnEnter(); attr.placeholder(t.t(\"Press Enter to add\"))] newPropositionVar\n // Followed by value propositions for this detail\n ul\n [ attr.id \"newPropositionsList\"]\n [\n // We build the list of lis outside of this view so that only the new entry is rendered\n propositionsListDoc\n ]\n\n ]\n )\n\n let newDetailForm =\n let errorVar = Var.Create (Doc.Empty)\n div\n []\n [\n errorVar.V\n label [attr.``for`` \"newDetailName\"] [t.tt(\"Detail name\")]\n Doc.InputType.Text [attr.``id`` \"newDetailName\"] newDetailNameVar\n Doc.InputType.Select [attr.``id`` \"newDetailDataType\";] (fun (dt:Specs.DataTypeSpec) -> t.t(dt.name)) datatypeSpecs dataTypeVar\n propositionsDocView.V\n\n button\n [\n attr.id \"submitNewEntityDetail\"\n classes [BS.btn; BS.``btn-primary``];\n UI.Html.attr.disabledDynPred (View.Const \"disabled\") submitDisabledView;\n on.click (fun _el _ev ->\n async {\n let! res = serverCall (entityDetailSpecVar.Value)\n match res with\n | Error es ->\n errorVar.Set (dangerBox (text (es |> Error.toString)))\n | Ok _ ->\n // Call the function updating the entity details list, signaling it this is\n // and update so updated
  • is flashed.\n do! refreshList()\n // Clear the new detail form fields\n entityDetailSpecVar.Set (initialiseSpec())\n }|>Async.Start\n )\n ]\n [\n t.tt(\"Submit\")\n ];\n ]\n buttonRevealingContent\n {|\n buttonTextWhenVisible = t.tt(\"Hide new detail form\")\n buttonTextWhenHidden = buttonText\n |}\n newDetailForm\n", "namespace web.admin\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen web.ClientI18n\nopen web.HtmlHelpers\nopen web.WSExtensions\nopen web.Css\nopen Ids\n\n// Renders /admin/databases\n[]\nmodule DatabasesDisplay =\n\n // This is called by the ClientContent.clientBody() to render the body of the page\n // according to the client-side router state.\n let pageBody () = async {\n let t = JStr()\n let! dbs = Server.Databases.getDatabases()\n let dbsCollection =\n ListModel.Create\n (fun (db:Specs.DatabaseSpec) -> db.databaseId )\n []\n let resultVar = Var.Create Doc.Empty\n match dbs with\n | Ok l ->\n dbsCollection.Set (l|> Seq.ofList)\n resultVar.Set Doc.Empty\n | Error es ->\n dbsCollection.Set [||]\n resultVar.Set(\n infobox\n (InfoBoxKind.Danger)\n (t.tt(\"An error occured\"))\n )\n // If the editedDb Var holds Some db, we will display the edition for for that db\n let editedDb:Var> = Var.Create None\n\n let editionFormForDb (database:Specs.DatabaseSpec) =\n // Put the user in a var and create lenses to easily link it to form fields\n let db = Var.Create database\n let name =\n db.LensAuto\n (fun u -> u.name)\n let buttonLabel=\n match database.databaseId with\n | Some _ -> t.t(\"Update\")\n | None -> t.t(\"Create\")\n form\n [ attr.id \"admin_databases_form\"]\n [\n label [attr.``for`` \"dbEditionName\"] [t.tt(\"Name\")]\n Doc.InputType.Text [attr.id \"dbEditionName\"] name\n\n Doc.Button\n buttonLabel\n [classes [BS.btn; BS.``btn-primary``]]\n (fun () ->\n async {\n let! r = Server.Databases.createOrUpdateDatabase db.Value\n match r with\n | Ok [db] ->\n // We get the updated user back, inject it in the users collection used to display the table\n // Add updates an existing entry\n dbsCollection.Add db\n // Notify of the success\n resultVar.Set (infobox InfoBoxKind.SuccessBox (t.tt \"Database saved successfully\"))\n // Get out of user edition, hiding the form\n editedDb.Set None\n // This Ok l should not happen as single row result is ensured server side\n | Ok _ ->\n resultVar.Set (infobox InfoBoxKind.Danger (t.tt(\"An error occured\")))\n | Error es ->\n resultVar.Set (infobox InfoBoxKind.Danger (text (es|>Error.toString)))\n }\n |> Async.Start\n )\n Doc.Button\n (t.t(\"Cancel\"))\n [classes [BS.btn; BS.``btn-secondary``]]\n // Cancelling is simply going to a state where no user edition is done\n (fun () -> editedDb.Set None)\n ]\n\n\n let editionformView () =\n editedDb.View\n |> View.Map (fun dbo ->\n match dbo with\n | None -> Doc.Empty\n | Some db -> editionFormForDb db\n )\n\n let dbsTable =\n dbsCollection.View\n |> View.Map\n (fun l ->\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id \"admin_databases_table\" ]\n [\n thead []\n [\n tr []\n [\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Name\")]\n ]\n\n ]\n\n ]\n\n tbody []\n [\n l\n |> Seq.map (fun db ->\n tr\n []\n [\n td [classes [BS.``table-sm``]] [text db.name]\n td [classes [BS.``table-sm``;\"myowndbactioncell\";]\n on.click (fun ev el ->\n // Remove previous feedback\n resultVar.Set Doc.Empty\n // Trigger form display\n editedDb.Set (Some db)\n // The form is at the top of the page, scroll to it\n JavaScript.JS.Window.ScrollTo(0,0)\n )\n ] [ a [attr.``data-`` \"myowndb-action\" \"edit\";] [li [ classes [\"fas\"; \"fa-edit\"; BS.``me-5``;\"myowndb-action-cell\"]] [] ]]\n td [classes [BS.``table-sm``;\"myowndbactioncell\";] ]\n [ a [attr.``data-`` \"myowndb-action\" \"view\";attr.href (AdminRouting.adminRouter.Link (AdminRouting.AdminEndPoint.Database (db.databaseId|> fun idIn -> idIn|>Option.get |> DatabaseId.Get)))] [li [ classes [\"fas\"; \"fa-search\"; BS.``me-5``;\"myowndb-action-cell\"]] [] ]]\n ]\n )\n |> Doc.Concat\n\n ]\n ]\n )\n return div\n []\n [\n Doc.Button\n (t.t(\"Add new\"))\n [classes [BS.btn; BS.``btn-primary``; \"myowndb-btn-add-db\"]]\n (fun () ->\n resultVar.Set Doc.Empty\n editedDb.Set (Some(Specs.DatabaseSpec.Init())))\n editionformView().V\n resultVar.V\n dbsTable.V\n ]\n }\n", "namespace web.admin\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen web.ClientI18n\nopen web.HtmlHelpers\nopen web.WSExtensions\nopen web.Css\n\n[]\nmodule DatabaseDisplay =\n\n // This is called by the ClientContent.clientBody() to render the body of the page\n // according to the client-side router state.\n let pageBody (databaseId:int) (pageInfo:web.PageInfo.Admin.Database.PageInfo)= async {\n let t = JStr()\n\n\n// _____ _ _ _ _\n// | ____|_ __ | |_(_) |_(_) ___ ___\n// | _| | '_ \\| __| | __| |/ _ \\/ __|\n// | |___| | | | |_| | |_| | __/\\__ \\\n// |_____|_| |_|\\__|_|\\__|_|\\___||___/\n\n\n\n let! entities = Server.Database.getEntities databaseId\n let entitiesCollection =\n ListModel.Create\n (fun (e:Specs.EntitySpec) -> e.entityId)\n []\n let entitiesResultVar = Var.Create Doc.Empty\n match entities with\n | Ok l ->\n entitiesCollection.Set (l|> Seq.ofList)\n entitiesResultVar.Set Doc.Empty\n | Error es ->\n entitiesCollection.Set [||]\n entitiesResultVar.Set(\n infobox\n (InfoBoxKind.Danger)\n (t.tt(\"An error occured\"))\n )\n // If the editedEntity Var holds Some entity, we will display the edition for for that entity\n let editedEntity:Var> = Var.Create None\n\n let editionFormForEntity (entity:Specs.EntitySpec) =\n // Put the user in a var and create lenses to easily link it to form fields\n let e = Var.Create entity\n let name =\n e.LensAuto\n (fun u -> u.name)\n let hasPublicForm =\n e.LensAuto\n (fun u -> u.hasPublicForm)\n form\n [ attr.id \"admin_entities_form\"]\n [\n div\n []\n [\n label [attr.``for`` \"entityEditionName\"] [t.tt(\"Name\")]\n Doc.InputType.Text [attr.id \"entityEditionName\"] name\n ]\n div\n []\n [\n label [ attr.``for`` \"entityEditionPublicForm\"; classes [] ] [t.tt(\"Has public form\")]\n Doc.InputType.CheckBox [attr.id \"entityEditionPublicForm\"] hasPublicForm\n ]\n\n Doc.Button\n (t.t(\"Save\"))\n [classes [BS.btn; BS.``btn-primary``]]\n (fun () ->\n async {\n let! r =\n Server.Database.createOrUpdateEntity databaseId e.Value\n match r with\n | Ok [e] ->\n // We get the updated user back, inject it in the users collection used to display the table\n // Add updates an existing entry\n entitiesCollection.Add e\n // Notify of the success\n entitiesResultVar.Set (infobox InfoBoxKind.SuccessBox (t.tt \"Entity saved successfully\"))\n // Get out of user edition, hiding the form\n editedEntity.Set None\n // This Ok l should not happen as single row result is ensured server side\n | Ok _ ->\n entitiesResultVar.Set (infobox InfoBoxKind.Danger (t.tt(\"An error occured\")))\n | Error es ->\n entitiesResultVar.Set (infobox InfoBoxKind.Danger (text (es|>Error.toString)))\n }\n |> Async.Start\n )\n Doc.Button\n (t.t(\"Cancel\"))\n [classes [BS.btn; BS.``btn-secondary``]]\n // Cancelling is simply going to a state where no user edition is done\n (fun () -> editedEntity.Set None)\n ]\n\n\n let editionformView () =\n editedEntity.View\n |> View.Map (fun eo ->\n match eo with\n | None -> Doc.Empty\n | Some e -> editionFormForEntity e\n )\n\n let setPublicForm(spec:Specs.EntitySpec) =\n async {\n let! r = Server.Database.createOrUpdateEntity databaseId spec\n match r with\n | Ok [e] ->\n entitiesCollection.Add e\n entitiesResultVar.Set(successBox (t.tt(\"Saved successfully\")))\n | _ ->\n entitiesResultVar.Set(dangerBox (t.tt(\"An error occured\")))\n } |> Async.Start\n\n let entitiesTable =\n entitiesCollection.View\n |> View.Map\n (fun l ->\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id \"admin_entities_table\" ]\n [\n thead []\n [\n tr []\n [\n th []\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Name\")]\n ]\n\n ]\n\n ]\n\n tbody []\n [\n l\n |> Seq.map (fun e ->\n tr\n []\n [\n td [classes [BS.``table-sm``]] [text e.name]\n td\n [classes [BS.``table-sm``;\"myowndbactioncell\";]]\n [\n a\n [\n attr.``data-`` \"myowndb-action\" \"togglePublicForm\";\n on.click (fun _el ev -> ev.PreventDefault(); setPublicForm {e with hasPublicForm = not e.hasPublicForm})]\n [\n fontAwesomeIconWithClasses [BS.``ms-1``] $\"\"\"toggle-{if e.hasPublicForm then \"on\" else \"off\"}\"\"\"\n ]\n if e.hasPublicForm then\n let publicFormRelativeLink = web.Routing.router.Link (web.EndPoint.PublicForm ((e.entityId |> Option.get |> Ids.EntityId.Get),None))\n let publicFormLink = JavaScript.URL(publicFormRelativeLink, JavaScript.JS.Document.BaseURI).Href\n let documentationUrlOption= pageInfo.publicFormDocumentationUrl\n span\n []\n [\n t.tt(\"Has public form\")\n helpIcon\n (t.t(\"The public form can be embedded in you website using an IFRAME. Add this to your html: . To make it resize to fit your page automatically, follow the documention link.\", publicFormLink))\n text \"(\"\n a [ attr.href publicFormLink; attr.target \"_blank\"] [text publicFormLink]\n // If a documentation URL was set in the config, display it here\n documentationUrlOption\n |> Option.map (fun url ->\n\n [\n text \" - \"\n a [ attr.href url; attr.target \"_blank\" ] [t.tt(\"Documentation\")]\n ]\n |> Doc.Concat\n )\n |> Option.defaultValue (Doc.Empty)\n text \")\"\n\n ]\n else\n t.tt(\"Has no public form\");\n ]\n td [classes [BS.``table-sm``;\"myowndbactioncell\";]\n on.click (fun ev el ->\n // Remove previous feedback\n entitiesResultVar.Set Doc.Empty\n // Trigger form display\n editedEntity.Set (Some e)\n // The form is at the top of the page, scroll to it\n JavaScript.JS.Window.ScrollTo(0,0)\n )\n ] [ a [attr.``data-`` \"myowndb-action\" \"edit\";] [li [ classes [\"fas\"; \"fa-edit\"; BS.``me-5``;\"myowndb-action-cell\"]] [] ]]\n td [classes [BS.``table-sm``;\"myowndbactioncell\";] ]\n [ a [attr.``data-`` \"myowndb-action\" \"view\"; attr.href (AdminRouting.adminRouter.Link (AdminRouting.AdminEndPoint.Entity (e.entityId|> fun (eid) -> eid |> Option.map Ids.EntityId.Get|> Option.get)))] [li [ classes [\"fas\"; \"fa-search\"; BS.``me-5``;\"myowndb-action-cell\"]] [] ]]\n ]\n )\n |> Doc.Concat\n\n ]\n ]\n )\n\n\n// ____ _ _ _\n// | _ \\ ___| |_ __ _(_) |___\n// | | | |/ _ \\ __/ _` | | / __|\n// | |_| | __/ || (_| | | \\__ \\\n// |____/ \\___|\\__\\__,_|_|_|___/\n\n\n let detailsCollection =\n ListModel.Create\n // The entitiesNames is a string listing entities using the detail of which the spec is\n // the second element of the pair\n (fun (_entitiesNames:string,d:Specs.DetailSpec) -> d.detailId)\n []\n let detailsResultVar = Var.Create Doc.Empty\n let refreshDetailsList () = async {\n let! details = Server.Database.getDetailSpecs databaseId\n match details with\n | Ok l ->\n detailsCollection.Set (l|> Seq.ofList)\n detailsResultVar.Set Doc.Empty\n | Error _es ->\n detailsCollection.Set [||]\n detailsResultVar.Set(\n infobox\n (InfoBoxKind.Danger)\n (t.tt(\"An error occured\"))\n )\n }\n do! refreshDetailsList()\n\n // Function displaying the table cell content for the name column.\n let displayEditableName (entitiesNames:string)(d:Specs.DetailSpec) =\n let step = Var.Create 0\n step.View\n |> View.Map (fun n ->\n match n with\n // Step 0: display the name and an edit icon\n | 0 ->\n span\n []\n [\n text d.name\n span\n [\n on.click (fun _el _ev -> step.Set 1)\n attr.``data-`` \"myowndb-action\" \"edit\"\n ]\n [\n fontAwesomeIcon \"edit\"\n ]\n ]\n // Step 1: when the edit icon is clicked, we get to step 1 for edition.\n | 1 ->\n let nameVar = Var.Create d.name\n Doc.InputType.Text\n [\n classes [\"myowndb-detail-name-edition\"]\n focusAfterRender()\n on.keyUp\n (fun el kev ->\n async {\n match kev.KeyCode with\n // Enter: submit\n | 13 ->\n let newSpec = {d with name = nameVar.Value}\n let! res = Server.Database.updateDetail newSpec\n match res with\n | Ok s -> detailsCollection.Add (entitiesNames,s|>List.head)\n | Error es -> detailsResultVar.Set (dangerBox (es|>Error.toString|>text))\n // Escape\n | 27 ->\n step.Set 0\n | _ -> ()\n } |> Async.Start\n )\n ]\n nameVar\n |> Doc.Prepend (helpIcon (t.t(\"Enter to submit, Escape to cancel\")))\n | _ ->\n step.Set 0\n Doc.Empty\n )\n let displayEditablePropositions (entitiesNames:string)(detail:Specs.DetailSpec) =\n let step = Var.Create 0\n step.View\n |> View.Map (fun n ->\n match n with\n // Step 0: display propositions\n | 0 ->\n span\n [\n ]\n [\n text\n (detail.propositions\n |> Option.map (List.map (fun (p:Specs.DetailValuePropositionItemSpec) -> p.value))\n |> Option.map (String.concat \",\")\n |> Option.defaultValue \"\" )\n (\n if detail.dataType.name = \"choose in list\" then\n span\n [\n attr.``data-`` \"myowndb-action\" \"edit\"\n on.click (fun _el _ev -> step.Set 1)\n ]\n [\n fontAwesomeIcon \"edit\"\n ]\n else\n Doc.Empty\n )\n ]\n // Step 1: edition of the propositions\n | 1 ->\n // Define the model which will hold the propositions\n let propositionsModel =\n ListModel.Create\n (fun p -> p.detailValuePropositionId )\n []\n // Initialise the model with the propositions from the spec\n propositionsModel.Set (detail.propositions|> Option.get )\n let lis =\n // Using DocLens gives us a Var we can use to modify its value with a form field eg\n propositionsModel.DocLens\n (fun _k vp ->\n li\n []\n [\n Doc.InputType.TextV [] vp.V.value\n ]\n )\n // Content of the table cell\n span\n []\n [\n ul\n []\n [ lis ]\n span\n [\n on.click\n (fun _el _ev ->\n async {\n // Filter out values that are empty\n let newSpec = {detail with propositions = Some (propositionsModel.Value|>List.ofSeq|> List.filter(fun p -> p.value<>\"\"))}\n let! res = Server.Database.updateDetail newSpec\n match res with\n | Ok s ->\n detailsCollection.Add (entitiesNames,s|>List.head)\n step.Set 0\n | Error es ->\n detailsResultVar.Set (dangerBox (es|>Error.toString|>text))\n } |> Async.Start\n )\n attr.``data-`` \"myowndb-action\" \"apply-propositions-changes\"\n ]\n [\n fontAwesomeIcon \"check\"\n ]\n span\n [ on.click (fun _el _ev -> step.Set 0)\n attr.``data-`` \"myowndb-action\" \"cancel-propositions-changes\"\n ]\n [\n fontAwesomeIcon \"times\"\n ]\n span\n [ on.click (fun _el _ev ->\n match propositionsModel.Value |> Seq.tryFind (fun p -> p.detailValuePropositionId.IsNone && p.value=\"\") with\n // No new empty proposition, add a new one\n | None ->\n let newProposition = Specs.DetailValuePropositionItemSpec.Init()\n propositionsModel.Add newProposition\n // There is already a new empty proposition, do not add another one\n | Some _ -> ()\n )\n attr.``data-`` \"myowndb-action\" \"add-proposition\"\n ]\n [\n fontAwesomeIcon \"plus\"\n ]\n ]\n | _ -> Doc.Empty\n )\n\n\n let detailsTableRows =\n detailsCollection.View.DocSeqCached (fun (entitiesNames:string,d:Specs.DetailSpec) ->\n tr\n []\n [\n td\n [classes [BS.``table-sm``]]\n [\n (displayEditableName entitiesNames d).V\n ]\n td\n [classes [BS.``table-sm``; \"myowndb-detail-datatype\"]]\n [ t.tt(d.dataType.name) ]\n td\n [classes [BS.``table-sm``;\"myowndb-detail-propositions\"]]\n [\n (displayEditablePropositions entitiesNames d).V\n ]\n td\n [classes [BS.``table-sm``; \"myowndb-detail-entities\"]]\n [ text entitiesNames ]\n td\n [classes [BS.``table-sm``]]\n // Translate strings \"Active\" and \"Inactive\"\n [ text (d.status|> sprintf \"%A\" |> t.t)]\n ]\n\n )\n\n let detailsTableVar = Var.Create(\n div\n []\n [\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id \"DetailsTable\"]\n [\n thead\n []\n [\n tr\n []\n [\n th\n []\n [\n t.tt(\"Name\")\n ]\n th\n []\n [\n t.tt(\"Datatype\")\n ]\n th\n []\n [\n t.tt(\"Value propositions\")\n ]\n th\n []\n [\n t.tt(\"Used in entities\")\n ]\n th\n []\n [\n t.tt(\"Status\")\n ]\n ]\n ]\n tbody\n []\n [\n detailsTableRows\n ]\n ]\n ]\n )\n\n let datatypeSpecs:Specs.DataTypeSpec list = web.ClientHelpers.dataTypes |> List.map(fun dt -> dt.toSpec() )\n let initialiseDetailSpec() :Specs.DetailSpec=\n {\n detailId = None\n name = \"\"\n dataType = datatypeSpecs[0]\n propositions = None\n status = DetailStatus.Active\n databaseId = Ids.DatabaseId databaseId\n }\n\n\n return div\n []\n [\n div\n [ classes [\"myowndb-entities-section\"]]\n [\n h1 [] [t.tt \"Entities administration\"]\n Doc.Button\n (t.t(\"Add new\"))\n [classes [BS.btn; BS.``btn-primary``]]\n (fun () ->\n entitiesResultVar.Set Doc.Empty\n editedEntity.Set (Some(Specs.EntitySpec.Init())))\n editionformView().V\n entitiesResultVar.V\n entitiesTable.V\n ]\n div\n [ classes [\"myowndb-details-section\"]]\n [\n h1 [] [t.tt(\"Details\")]\n detailsResultVar.V\n web.admin.EntityDetail.addNewDetailSection (initialiseDetailSpec)(Server.Database.createNewDetail) (refreshDetailsList) (t.tt(\"Add new detail\"))\n detailsTableVar.V\n ]\n ]\n }\n", "namespace web.admin\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen web.ClientI18n\nopen web.HtmlHelpers\nopen web.WSExtensions\nopen web.Css\n\n[]\nmodule EntityDisplay =\n open web\n\n // Distinguish first render from subsequent updates to avoid flashing all elements at first render\n type RenderCycle = |First |Update\n // This is called by the ClientContent.clientBody() to render the body of the page\n // according to the client-side router state.\n let pageBody (entityId:int) (pageInfo:web.PageInfo.Admin.Entity.PageInfo)= async {\n let t = JStr()\n\n //********************************************************************************\n // Setup data used in multiple sections below\n //********************************************************************************\n let renderCycleVar = Var.Create First\n // Feedback Var\n let resultVar=Var.Create Doc.Empty\n // We initialise the entity details list and the linkable details list at the top level\n // because those have interactions: and a linked detail is unlinked it should appear in\n // the linkable list, and vice-versa.\n // Initialise an empty ListModel that we will populate with the list above\n let collection =\n ListModel.Create\n (fun (ed:Entity.EntityDetail) -> ed.id)\n []\n // Initialise empty linkable details list\n let linkableDetailsListModel:ListModel =\n ListModel.Create\n (fun d -> let (Ids.DetailId id) = d.id in id)\n []\n let refreshLinkableDetailsList () = async {\n let! linkableDetailsResult = Server.Entity.linkableDetails entityId\n match linkableDetailsResult with\n | Error es ->\n resultVar.Set(dangerBox (es|>Error.toString|>text))\n linkableDetailsListModel.Set []\n | Ok details ->\n linkableDetailsListModel.Set details\n }\n //////////////////////////////////////////// _ _ _ _\n // __| | ___| |_ __ _(_) |___\n // / _` |/ _ \\ __/ _` | | / __|\n // | (_| | __/ || (_| | | \\__ \\\n // \\__,_|\\___|\\__\\__,_|_|_|___/\n /////////////////////////////////////////////\n\n\n //********************************************************************************\n // Display currently linked details\n //********************************************************************************\n // Define the
  • list from the collection based on the collection's view\n // We do it separately from the
      so we don't recall DocSeqCached when we will\n // update the lu, as it would prevent the render of only updated entries\n let lis :Doc=\n collection.View.DocSeqCached\n // The collection holds a sequence of which we map individual elements to an
    • \n (fun (entityDetail:Entity.EntityDetail) ->\n\n let deleteElement (entity2detailId:string)(refreshFunction:unit->unit)=\n DeleteConfirmation.deleteConfirmation \"detail\" (\n (fun () -> async {\n match! (Server.Entity.UnlinkDetail (int entity2detailId)) with\n | Ok _ ->\n refreshFunction()\n do! refreshLinkableDetailsList()\n // signal success\n return true\n | Error _ ->\n // signal failure\n return false\n })\n )\n\n\n\n\n li\n // Set attribute according to render cycle. At first render, do not flash element.\n // But for update, flash the rendered element.\n (\n match renderCycleVar.Value with\n | First -> []\n | Update -> flashExclusiveAttributes()\n )\n [\n // Detail name in the first row with an Edit icon\n div\n [classes [BS.``d-flex``; BS.``flex-row``]]\n [\n div [classes [BS.``p-2``;\"myowndbdetailname\"]] [text (entityDetail.name); fontAwesomeIconWithClasses [BS.``ms-1``] \"edit\" ]\n ]\n\n // Actions row\n div\n [classes [BS.``d-flex``; BS.``flex-row``]]\n [\n\n div\n [classes [BS.``d-flex``; BS.``flex-row``]]\n [\n // Visibility in list\n div [classes [BS.``p-2``;\"myowndbdisplayinlistview\"]]\n [\n (entityDetail.displayed_in_list_view\n |> (fun b ->\n let setVisibility (b:bool)=\n async {\n let! r = Server.Entity.setListVisibility entityDetail.id b\n match r with\n | Ok [ed] ->\n collection.Add ed\n resultVar.Set(successBox (t.tt(\"Saved successfully.\")))\n | _ ->\n resultVar.Set(dangerBox (t.tt(\"An error occured\")))\n ()\n }|> Async.Start\n if b then\n div\n [on.click (fun el ev -> setVisibility false)\n attr.``data-`` \"myowndb-action\" \"hide-in-list\";\n ]\n [\n t.tt(\"Displayed in list view\")\n fontAwesomeIconWithClasses [BS.``ms-1``] \"toggle-on\"\n ]\n else\n div\n [on.click (fun el ev -> setVisibility true)\n attr.``data-`` \"myowndb-action\" \"show-in-list\";\n ]\n [\n t.tt(\"Not displayed in list view\")\n fontAwesomeIconWithClasses [BS.``ms-1``] \"toggle-off\"\n ]\n ))\n ]\n // Remove detail from entity\n div [classes [BS.``p-2``;\"myowndbentitydetailremove\"]\n attr.``data-`` \"myowndb-action\" \"delete\";\n ]\n [\n a [] [(deleteElement(string entityDetail.id) (fun () -> collection.Remove(entityDetail))).V]\n ]\n // Move up in display order\n div [classes [BS.``p-2``];\n attr.``data-`` \"myowndb-action\" \"up\";\n on.click (fun _el _ev ->\n let rec up (l:List)(i:Entity.EntityDetail) = async {\n match l with\n | h::snd::t ->\n if snd = i then\n let newFirst = {snd with display_order = h.display_order}\n let newSecond = {h with display_order = snd.display_order}\n let! res = Server.Entity.updateEntityDetailsDisplayOrder [newFirst;newSecond]\n match res with\n | Ok _ ->\n return newFirst::newSecond::t\n | Error es ->\n resultVar.Set(dangerBox (es |> Error.toString|>text))\n return l\n else\n // This is not tail recursive, but ok as 2 elements list\n let! newTail = (up (snd::t) i)\n return h :: newTail\n | _ -> return l\n }\n\n async {\n let! updatedList = up (collection.Value|>List.ofSeq) entityDetail\n collection.Set (updatedList|>Seq.ofList)\n } |> Async.Start\n\n )\n ]\n [\n fontAwesomeIcon \"arrow-up\"\n ]\n // Move down in display order\n div [classes [BS.``p-2``];\n attr.``data-`` \"myowndb-action\" \"down\";\n on.click (fun _el _ev ->\n let rec down (l:List)(i:Entity.EntityDetail) = async {\n match l with\n | h::snd::t ->\n if h = i then\n let newFirst = {snd with display_order = h.display_order}\n let newSecond = {h with display_order = snd.display_order}\n let! res = Server.Entity.updateEntityDetailsDisplayOrder [newFirst;newSecond]\n match res with\n | Ok _ ->\n return newFirst::newSecond::t\n | Error es ->\n resultVar.Set(dangerBox (es |> Error.toString|>text))\n return l\n else\n // This is not tail recursive, but ok as 2 elements list\n let! newTail = (down (snd::t) i)\n return h :: newTail\n | _ -> return l\n }\n\n async {\n let! updatedList = down (collection.Value|>List.ofSeq) entityDetail\n collection.Set (updatedList|>Seq.ofList)\n } |> Async.Start\n )\n ]\n [\n fontAwesomeIcon \"arrow-down\"\n ]\n ]\n ]\n ]\n )\n\n // Var holding the
        with the list of details of this entity\n let ulVar = Var.Create Doc.Empty\n // Define the function retrieving entity details from the backend and updating the collection\n // used by DocSeqCached\n let refreshEntityDetails (cycle:RenderCycle) = async {\n // Set the var used by the DocSeqCached mapping to
      • s so it know if it needs to flash elements\n renderCycleVar.Set cycle\n // Get list from the backend\n let! entityDetailsResult = Server.Entity.getEntityDetails entityId\n match entityDetailsResult with\n | Error es-> resultVar.Set (infobox InfoBoxKind.Danger (es|>Error.toString|>text))\n | Ok entityDetails ->\n collection.Set(entityDetails|>Seq.ofList)\n // Build the
      • s to put inside the
          \n // put the
        • s in the
            \n ulVar.Set(\n ul\n [attr.id \"entityDetails\"]\n [lis]\n )\n }\n // Call the function immediately for initial display\n do! refreshEntityDetails(First)\n\n //********************************************************************************\n // Link an existing details\n //********************************************************************************\n let buildLinkExistingDetailSection() = async {\n do! refreshLinkableDetailsList()\n let linkThisDetail (detail:Detail.Detail) = async {\n let! res = Server.Entity.linkExistingDetail entityId detail\n match res with\n | Ok l ->\n collection.Set l\n linkableDetailsListModel.Remove detail\n | Error es ->\n resultVar.Set(dangerBox (es|>Error.toString|>text))\n\n }\n let rows =\n linkableDetailsListModel.View.DocSeqCached (fun (d:Detail.Detail) ->\n tr\n []\n [\n td\n []\n [ text d.name]\n td\n [on.click (fun _el _ev ->\n async {\n do! linkThisDetail d\n } |> Async.Start);\n attr.``data-`` \"myowndb-action\" \"link\"\n ]\n [\n li [ classes [\"fas\"; \"fa-link\"; BS.``me-5``;\"myowndb-action-cell\"]] []\n ]\n ]\n )\n return\n buttonRevealingContent\n {|\n buttonTextWhenVisible = t.tt(\"Hide existing details\")\n buttonTextWhenHidden = t.tt(\"Define field with existing detail\")\n |}\n (\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id \"adminUsableDetails\" ]\n [\n thead []\n [\n tr []\n [\n th [classes [ BS.``w-25``]]\n [\n div [classes [AppCss.``th-inner``]] [t.tt(\"Name\")]\n ]\n\n ]\n\n ]\n\n tbody []\n [\n rows\n ]\n ]\n )\n }\n let! linkExistingDetailSection =\n buildLinkExistingDetailSection()\n\n ///////////////////////////////////////////////// _ _ _\n // _ __ ___| | __ _| |_(_) ___ _ __ ___\n // | '__/ _ \\ |/ _` | __| |/ _ \\| '_ \\/ __|\n // | | | __/ | (_| | |_| | (_) | | | \\__ \\\n // |_| \\___|_|\\__,_|\\__|_|\\___/|_| |_|___/\n ///////////////////////////////////////////////// _ _ _\n\n //********************************************************************************\n // Existin relations\n //********************************************************************************\n let buildRelationsTable (relationDirection:Server.Relation.RelationDirection) =\n let targetString = sprintf \"%A\" relationDirection\n let renderCycleVar = Var.Create First\n let relationsCollection =\n ListModel.Create\n (fun (r:Specs.RelationSpec,_targetName:string) -> r.relationId)\n []\n // We create a Var holding an Option of Var\n // The outer Var is so that we can updated to a None or Some _ to toggle form display\n // The inner Var holds the RelationSpec from which we derive lenses that we linke to the form fields.\n // Define it here so it can be called from the table rows for relation edition\n let editedRelationVar:Var>> = Var.Create None\n // Define Var for rows so on ly rows are updated by DocSeqCached\n let tableRows =\n relationsCollection.View.DocSeqCached (fun (r:Specs.RelationSpec,targetName:string) ->\n tr\n []\n [\n td\n [classes [BS.``table-sm``]]\n [ text targetName ]\n td\n [classes [BS.``table-sm``]]\n [ text r.childToParentName ]\n td\n [classes [BS.``table-sm``]]\n [ text r.parentToChildName ]\n td\n [classes [BS.``table-sm``]]\n // Translate strings \"One\" and \"Many\"\n [ text (r.childSideType|> sprintf \"%A\" |> t.t)]\n td\n [classes [BS.``table-sm``]]\n // Translate strings \"One\" and \"Many\"\n [ text (r.parentSideType|> sprintf \"%A\" |> t.t) ]\n td\n [\n classes [BS.``table-sm``]\n attr.``data-`` \"myowndb-action\" \"edit-relation\";\n on.click\n (fun _e _ev ->\n editedRelationVar.Set (Some (Var.Create r))\n )\n ]\n // Translate strings \"One\" and \"Many\"\n [ fontAwesomeIcon \"edit\"]\n ]\n\n )\n let relationForm =\n let rowClasses = classes [ BS.row;BS.``mb-3``;BS.``align-items-center``]\n let labelClasses = classes [BS.``col-sm-4``;BS.``col-form-label``]\n let fieldClasses = classes [BS.``form-control``]\n let wrapLabel l = div [classes [BS.``col-sm-4``]] [l]\n let wrapField l = div [classes [BS.``col-sm-8``]] [l]\n\n // Function returning the form for the RelationsSpec wrapped in the Var passed as argument.\n let formForRelation (r:Var) =\n // Define lenses on the records fields so these can be used in the form\n let targetVar =\n r.Lens\n (fun rel ->\n match relationDirection with\n // If working on relations to parents, we are the child and it is the entity with the parentId that is the target\n | Server.Relation.ToParents -> pageInfo.entitiesInDB |> List.filter (fun i -> i.id = rel.parentId) |> List.head\n // If working on relations to children, we are the parent and it is the entity with the childId that is the target\n | Server.Relation.ToChildren -> pageInfo.entitiesInDB|> List.filter (fun i -> i.id = rel.childId) |> List.head\n )\n (fun rel newFieldValue ->\n match relationDirection with\n // If working on relations to parents, update the parent id when the targetVar is updated\n | Server.Relation.ToParents -> { rel with parentId = newFieldValue.id }\n // If working on relations to children, update the child id when the targetVar is updated\n | Server.Relation.ToChildren -> { rel with childId = newFieldValue.id }\n )\n let childToParentNameVar= r.LensAuto (fun rel -> rel.childToParentName)\n let parentToChildNameVar = r.LensAuto (fun rel -> rel.parentToChildName)\n let parentSideTypeVar =\n r.LensAuto\n (fun rel -> rel.parentSideType)\n let childSideTypeVar =\n r.LensAuto\n (fun rel -> rel.childSideType)\n // The error Var specific to this relation form\n let relationErrorVar = Var.Create Doc.Empty\n //Helper to disable relation side type changes when we edit a relation that is \"To many\" as switching it to \"To one\"\n // requires special care (it should be impossible to switch to \"To One\" if there are instances that are \"To many\")\n let disableArityChangeIfNeeded (relVar:Var)(sideTypeVar:Var)=\n if (relVar.Value.relationId.IsSome && sideTypeVar.Value = Specs.RelationSideType.Many)\n then\n attr.disabled \"disabled\"\n else\n Attr.Empty\n // Cannot change target of an existing relation\n let disableTargetChangeIfEditing (relVar:Var)=\n if (relVar.Value.relationId.IsSome)\n then\n attr.disabled \"disabled\"\n else\n Attr.Empty\n let appendHelpForDisabledSidetypeChangeIfNeeded (relVar:Var)(sideTypeVar:Var)(doc:Doc)=\n if (relVar.Value.relationId.IsSome && sideTypeVar.Value = Specs.RelationSideType.Many) then\n Doc.Append\n doc\n (helpIcon (t.t(\"It is not possible to edit the arity of a relation when it is accepting multiple targets.\")))\n else\n doc\n let appendHelpForDisabledTargetChangeInEdition (relVar:Var)(doc:Doc)=\n if (relVar.Value.relationId.IsSome) then\n Doc.Append\n doc\n (helpIcon (t.t(\"It is not possible to edit the target of an existing relation.\")))\n else\n doc\n\n // Return the form Doc\n div\n [classes [BS.card];attr.id (sprintf \"relationForm%s\" targetString)]\n [\n div\n [classes [BS.``card-body``]]\n [\n // Target entity\n div\n [rowClasses]\n [\n label\n [labelClasses;attr.``for`` \"target\"]\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n t.tt(\"parent\")\n | Server.Relation.ToChildren ->\n t.tt(\"child\")\n ]\n |> wrapLabel\n Doc.InputType.Select [attr.id \"target\";fieldClasses; disableTargetChangeIfEditing r] (fun (e:Entity.Entity) -> e.name) pageInfo.entitiesInDB targetVar\n |> appendHelpForDisabledTargetChangeInEdition r\n |> wrapField\n ]\n // Relation name from parent to child\n div\n [rowClasses]\n [\n label\n [labelClasses;attr.``for`` \"parentToChildName\"]\n [\n (\n match relationDirection with\n | Server.Relation.ToParents ->\n // We are the child\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Name from %1 (parent) to %2\", target.name, pageInfo.entity.name)\n )\n | Server.Relation.ToChildren ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Name from %1 (parent) to %2\", pageInfo.entity.name, target.name)\n )\n ).V\n ]\n |> wrapLabel\n Doc.InputType.Text [fieldClasses; attr.id \"parentToChildName\"] parentToChildNameVar\n |> wrapField\n ]\n // Relation name from child to parent\n div\n [rowClasses]\n [\n label\n [labelClasses;attr.``for`` \"childToParentName\"]\n [\n (\n match relationDirection with\n | Server.Relation.ToParents ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Name from %1 (child) to %2\", pageInfo.entity.name, target.name)\n )\n | Server.Relation.ToChildren ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Name from %1 (child) to %2\", target.name, pageInfo.entity.name)\n )\n ).V\n ]\n |> wrapLabel\n Doc.InputType.Text [attr.id \"childToParentName\"; fieldClasses] childToParentNameVar\n |> wrapField\n ]\n // As determining the labels for the relation side types can be cumbersome, here's a helper schema:\n //\n //\n // parent side type: Can one employee (child,current) have multiple companies (parent, target)\n // /\n // /\n // /\n // to parents\n // / (eg employee to company: employee is child and currently displayed, company is parent and target)\n // / \\\n // / \\\n // / \\\n // / \\\n // . \\ child side type: Can one company (parent, target) have multiple employees (child, current)\n // \\\n // \\\n // \\\n // \\ parent side type: Can one employee (child, target) have multiple companies (parent,current)\n // \\ /\n // \\ /\n // \\ /\n // \\ to children\n // (eg company to employee, company is parent and currently displayed, employee is child and target)\n // \\\n // \\\n // \\\n // child side type: Can one company (parent, current) have multiple employees (child, target)\n //\n //\n\n // Parent side type\n div\n [rowClasses]\n [\n label\n [labelClasses;attr.``for`` \"parentSideType\"]\n [\n (match relationDirection with\n | Server.Relation.ToParents ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Can one %1 (child) be linked to multiple %2 (parent)?\", pageInfo.entity.name, target.name)\n )\n | Server.Relation.ToChildren ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Can one %1 (child) be linked to multiple %2 (parent)?\", target.name, pageInfo.entity.name)\n )\n ).V\n ]\n |> wrapLabel\n\n Doc.InputType.Select [attr.id \"parentSideType\"; fieldClasses; disableArityChangeIfNeeded r parentSideTypeVar;] (function |Specs.RelationSideType.Many -> t.t(\"Yes\");|Specs.RelationSideType.One -> t.t(\"No\")) [Specs.RelationSideType.Many;Specs.RelationSideType.One] parentSideTypeVar\n |> appendHelpForDisabledSidetypeChangeIfNeeded r parentSideTypeVar\n |> wrapField\n ]\n // Child side type\n div\n [rowClasses]\n [\n label\n [labelClasses;attr.``for`` \"childSideType\"]\n [\n (match relationDirection with\n | Server.Relation.ToParents ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Can one %1 (parent) be linked to multiple %2 (child)?\", target.name, pageInfo.entity.name)\n )\n | Server.Relation.ToChildren ->\n targetVar.View\n |> View.Map (fun target ->\n t.tt(\"Can one %1 (parent) be linked to multiple %2 (child)?\", pageInfo.entity.name, target.name)\n )\n ).V\n ]\n |> wrapLabel\n\n Doc.InputType.Select [attr.id \"childSideType\";fieldClasses; disableArityChangeIfNeeded r childSideTypeVar] (function |Specs.RelationSideType.Many -> t.t(\"Yes\");|Specs.RelationSideType.One -> t.t(\"No\")) [Specs.RelationSideType.Many;Specs.RelationSideType.One] childSideTypeVar\n |>appendHelpForDisabledSidetypeChangeIfNeeded r childSideTypeVar\n |> wrapField\n ]\n button\n [\n classes [BS.btn; BS.``btn-primary``]\n on.click\n (fun _el _ev ->\n async {\n let! specResult =Server.Relation.updateRelation r.Value\n match specResult with\n | Ok [spec] ->\n relationErrorVar.Set Doc.Empty\n // Extract the target entity name as it is needed for the display of the list of relations\n let targetName =\n match relationDirection with\n | Server.Relation.ToParents ->\n pageInfo.entitiesInDB|> List.filter (fun i -> i.id = spec.parentId) |> List.map (fun i -> i.name) |> List.head\n | Server.Relation.ToChildren ->\n pageInfo.entitiesInDB|> List.filter (fun i -> i.id = spec.childId) |> List.map (fun i -> i.name) |> List.head\n // Add the pair to the collection, which will update the list\n relationsCollection.Add (spec,targetName)\n // Hide form\n editedRelationVar.Set None\n | Ok _ -> relationErrorVar.Set (dangerBox (t.tt(\"An error occured\")))\n | Error es -> relationErrorVar.Set (dangerBox (text (es |> Error.toString)))\n } |> Async.Start\n )\n ]\n [t.tt(\"Submit\")]\n relationErrorVar.V\n ]\n\n\n\n ]\n // This is the View allowing us to hide the form simply by setting the editedRelationVar to None\n let relationFormView =\n editedRelationVar.View\n |> View.Map(fun specVarOption ->\n match specVarOption with\n | None -> Doc.Empty\n | Some specVar -> formForRelation specVar\n\n )\n let shouldDisplayRelationFormView =\n editedRelationVar.View\n |> View.Map (fun o -> o.IsSome)\n let displayFormButtonText =\n shouldDisplayRelationFormView\n |> View.Map (fun b -> if b then t.tt(\"Hide form\") else t.tt(\"Add relation\") )\n let blankRelationSpec:Specs.RelationSpec =\n {\n relationId = None\n parentSideType = Specs.RelationSideType.Many\n childSideType = Specs.RelationSideType.Many\n parentToChildName = \"\"\n childToParentName = \"\"\n parentId =\n match relationDirection with\n // We are the child so the target's id comes here. As initial target selection we take the first one\n | Server.Relation.ToParents -> pageInfo.entitiesInDB[0].id\n // We are the parent so our id comes here\n | Server.Relation.ToChildren -> pageInfo.entity.id\n childId =\n match relationDirection with\n // We are the child so our id comes here\n | Server.Relation.ToParents -> pageInfo.entity.id\n // We are the parent so the target's id comes here. As initial target selection we take the first one\n | Server.Relation.ToChildren -> pageInfo.entitiesInDB[0].id\n }\n\n div\n []\n [\n // Form\n button\n [\n classes [BS.btn;BS.``btn-primary``; ]\n attr.id (sprintf \"toggleRelationForm%s\" targetString)\n // Toggle the display of the form by setting the editedRelationVar to Some or None.\n on.click (fun _el _ev -> if editedRelationVar.Value.IsSome then editedRelationVar.Set None else editedRelationVar.Set (Some(Var.Create blankRelationSpec)))\n ]\n [displayFormButtonText.V]\n relationFormView.V\n ]\n // Var containing Doc displaying the relations. It brings together the form and the table listing existing relations\n let tableVar = Var.Create(\n div\n []\n [\n relationForm\n table\n [ classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; ];attr.id $\"{targetString}Relations\"]\n [\n thead\n []\n [\n tr\n []\n [\n // Related entity name\n th\n []\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n t.tt(\"parent name\")\n | Server.Relation.ToChildren ->\n t.tt(\"child name\")\n ]\n // Relation name from child to parent\n th\n []\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n // We are the child\n t.tt(\"name from %1 to parent\",pageInfo.entity.name)\n | Server.Relation.ToChildren ->\n // We are the parent\n t.tt(\"name from child to %1\",pageInfo.entity.name)\n ]\n // Relation name from parent to child\n th\n []\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n // We are the child\n t.tt(\"name from parent to %1\",pageInfo.entity.name)\n | Server.Relation.ToChildren ->\n // We are the parent\n t.tt(\"name from %1 to child\",pageInfo.entity.name)\n ]\n // Child side type\n th\n []\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n // We are the child\n t.tt(\"%1 side type\",pageInfo.entity.name)\n | Server.Relation.ToChildren ->\n // We are the parent\n t.tt \"child side type\"\n ]\n // Parent side type\n th\n []\n [\n match relationDirection with\n | Server.Relation.ToParents ->\n // We are the child\n t.tt \"parent side type\"\n | Server.Relation.ToChildren ->\n // We are the parent\n t.tt(\"%1 side type\",pageInfo.entity.name)\n ]\n ]\n ]\n tbody\n []\n [\n tableRows\n ]\n ]\n ]\n )\n\n // Function to be called to refresh relations list by calling RPC\n let refreshParentRelations (cycle:RenderCycle) = async {\n // Set the var used by the DocSeqCached mapping to
          • s so it know if it needs to flash elements\n renderCycleVar.Set cycle\n // Get list from the backend\n let! rpcResult = Server.Relation.getRelations entityId relationDirection\n match rpcResult with\n | Error es-> resultVar.Set (infobox InfoBoxKind.Danger (es|>Error.toString|>text))\n | Ok relationsSpecs ->\n relationsCollection.Set(relationsSpecs|>Seq.ofList)\n // Build the
          • s to put inside the
              \n // put the
            • s in the
                \n }\n\n tableVar,refreshParentRelations\n\n // Call function creating relations management elements\n let toParentsVar,refreshToParentRelations = buildRelationsTable Server.Relation.ToParents\n let toChildrenVar,refreshToChildrenRelations = buildRelationsTable Server.Relation.ToChildren\n // And trigger the RPC call for first display\n do! refreshToParentRelations First\n do! refreshToChildrenRelations First\n let datatypeSpecs:Specs.DataTypeSpec list = web.ClientHelpers.dataTypes |> List.map(fun dt -> dt.toSpec() )\n let initialiseDetailSpec() :Specs.EntityDetailSpec=\n {\n detailId = None\n name = \"\"\n dataType = datatypeSpecs[0]\n propositions = None\n status = DetailStatus.Active\n }\n // return the content of the page\n return\n div\n []\n [\n h1\n []\n [text pageInfo.entity.name]\n resultVar.V\n ulVar.V\n // ServerCall : Server.Entity.linkNewDetail entityId\n // refreshList: refreshEntityDetails(Update)\n web.admin.EntityDetail.addNewDetailSection initialiseDetailSpec (Server.Entity.linkNewDetail entityId ) (fun () -> async { do! refreshEntityDetails Update}) (t.tt(\"Add field based on new detail\"))\n linkExistingDetailSection\n // Relations\n h1 [] [t.tt(\"Relations to parents\")]\n toParentsVar.V\n h1 [] [t.tt(\"Relations to children\")]\n toChildrenVar.V\n ]\n }\n", "namespace web\n\nopen WebSharper\n\n[]\nmodule FormHelpers =\n open Specs\n // We have different behaviour according to the form type. This type\n // enables to distinguish on which type of form ware are currently working.\n type LinkFormInfo = {\n relationId: int\n dirAndId: LinkedInstancesTypes.RelatedInDirectionForIntInstanceId\n }\n type FormKind = |Creation |Edition |Public |Link of LinkFormInfo\n open WebSharper.UI\n open WebSharper.UI.Html\n open ClientI18n\n open HtmlHelpers\n open Css\n let valueToString (v:Value) =\n match v with\n | ServerValidated sv ->\n match sv with\n | ServerValue.Simple (Some sv) -> sv\n | ServerValue.Simple None -> \"\"\n | ServerValue.LongText (Some sv) -> sv\n | ServerValue.LongText None -> \"\"\n | ServerValue.Integer (Some i) -> string i\n | ServerValue.Integer None -> \"\"\n | ServerValue.Email (Some e) -> e |> Email.toString\n | ServerValue.Email None -> \"\"\n | ServerValue.WebURL (Some u) -> u |> WebURL.toString\n | ServerValue.WebURL None -> \"\"\n | ServerValue.DdlValueChoice (Some c) -> c |> DdlChoice.toString\n | ServerValue.DdlValueChoice None -> \"\"\n | ServerValue.DateAndTime (Some dt) ->\n let dateTime = dt |> DateAndTime.get\n // javascript translation does not have ToString(\"format\")\n (dateTime.get_Year()|> sprintf \"%04d\")\n + \"-\"\n + (dateTime.get_Month()|> sprintf \"%02d\")\n + \"-\"\n + (dateTime.get_Day()|> sprintf \"%02d\")\n + \" \"\n + (dateTime.get_Hour()|> sprintf \"%02d\")\n + \":\"\n + (dateTime.get_Minute()|> sprintf \"%02d\")\n + \":\"\n + (dateTime.get_Second()|> sprintf \"%02d\")\n | ServerValue.DateAndTime None -> \"\"\n // For file attachment, we serialise the FileAttachment record to transmit all info to the field formatter\n | ServerValue.FileAttachment (Some info) -> Json.Serialize(info)\n | ServerValue.FileAttachment None -> Json.Serialize(ServerFileAttachment.New())\n | ClientProposed cp ->\n match cp with\n | ClientValue.Simple (Some v) -> v\n | ClientValue.Simple None -> \"\"\n | ClientValue.LongText (Some v) -> v\n | ClientValue.LongText None -> \"\"\n | ClientValue.Integer (Some i) -> i\n | ClientValue.Integer None -> \"\"\n | ClientValue.Email (Some e) -> e\n | ClientValue.Email None -> \"\"\n | ClientValue.WebURL (Some u) -> u\n | ClientValue.WebURL None -> \"\"\n | ClientValue.DdlValueChoice (Some c) -> c |> string\n | ClientValue.DdlValueChoice None -> \"\"\n | ClientValue.DateAndTime (Some d) -> d\n | ClientValue.DateAndTime None -> \"\"\n | ClientValue.FileAttachment None -> Json.Serialize(ServerFileAttachment.New())\n | ClientValue.FileAttachment (Some s) -> s\n\n\n\n let InitialiseNewDetailValue (Ids.DataTypeId dataTypeId) =\n // A new empty value is initialised to a ServerValue so it is not handled by the server\n // if left unmodified by the user\n match dataTypeId with\n | 1 -> ServerValue.Simple None\n | 2 -> ServerValue.LongText None\n | 3 -> ServerValue.DateAndTime None\n | 4 -> ServerValue.Integer None\n | 5 -> ServerValue.DdlValueChoice None\n | 6 -> ServerValue.Email None\n | 7 -> ServerValue.WebURL None\n | 8 -> ServerValue.FileAttachment None\n | _ -> failwith \"unknown data type id\"\n |> ServerValidated\n\n // Adds detailValuesSpec to an InstanceSpec for details it has no value for\n let addMissingDetailValues (spec:InstanceSpec) (detailsWithoutValue:list)=\n {spec with\n detailValues =\n // Fold with initial value the spec with existing values, and the\n // list to traverse being the details without value.\n // At each step of the fold we add an empty ClientProposed detail value to the list.\n List.fold\n (fun dvs (detailSpec:DetailSpec) ->\n let item =\n { detailId=(detailSpec.detailId|>Option.get);\n values=\n [\n { detailValueId=None;\n value=InitialiseNewDetailValue detailSpec.dataType.dataTypeId\n }\n ]\n }\n item::dvs\n )\n spec.detailValues\n detailsWithoutValue\n }\n\n\n // Build the lens Map where the key is the detailId, and the value is the lens to the ValueSpec for this detail id.\n // The specs supports multiple values for one detail id but this is not used yet, so the lens focuses on the first\n // ValueSpec in the list.\n let buildLensMap (fullSpecVar:Var) =\n // Create a map of lenses into the detail values of the instance\n let lensMap = ref Map.empty\n fullSpecVar.Value.detailValues\n // We iterate on the detail values with the index.\n // We cannot use the detail value item passed to our function by iteri to define lenses because\n // the functions defining the lens get as argument the spec, and it is that spec that\n // we must use in the lens definition. That is the reason why we use iteri, so that in the lens definition\n // we can get to the detail value of index i.\n |> List.iteri (fun i dv ->\n // define the lens for detail value i\n let lens =\n fullSpecVar.Lens\n // Get the string representation of a Value\n (fun s->\n s.detailValues[i].values[0])\n // update function for detail value #i\n (fun s v ->\n {\n s with\n // only update the detailValues field\n detailValues =\n s.detailValues\n |> List.mapi\n (fun index dvToMap ->\n // only touch detail value with index i (set by iteri)\n if index = i then\n { dvToMap with\n values = [v]\n }\n else\n dvToMap\n )\n }\n )\n // add the lens we just created to the map, under the key of the detail value's detailId\n lensMap.Value <- (Map.add dv.detailId lens lensMap.Value)\n )\n lensMap\n\n // Template used to display updates applied by a form submission\n type UpdatesTemplate = Templating.Template<\"templates/form/UpdatesFeedback.html\">\n type UpdatesTemplateInRow = Templating.Template<\"templates/form/UpdatesFeedbackInRow.html\">\n\n let updateFeedbackForDetail (formKind: FormKind) (dspec:DetailSpec) (spec:InstanceSpec) =\n spec.detailValues\n // Extract detailValue for detail dspec\n |> List.filter (fun dv ->\n dspec.detailId\n |> Option.map (fun detailSpecDetailId ->\n detailSpecDetailId = dv.detailId\n )\n |> Option.defaultValue false\n )\n // Get the detail value's string representation\n |> List.map (fun dv -> valueToString dv.values.Head.value)\n // Extract the file attachment's name from the json string\n |> List.map (fun s ->\n if dspec.dataType.className = \"FileAttachmentDetailValue\" then\n let info:ServerFileAttachment.FileAttachmentWithOptionalIndb = Json.Deserialize s\n info.filename\n else\n s\n )\n // Filter out empty value for creation as those are not saved. However, keep them\n // for edition as thos have to be displayed as new values.\n |> List.filter (fun s ->\n match formKind with\n |Creation|Public|Link _ -> s.Length>0\n |Edition -> true\n )\n // Map the string to a Doc. We introduce the span so that we have the same hierarchy for\n // fields changed and those unchanged (facilitates testing too)\n |> List.map (fun s -> span [] [text s])\n // If we end up with an empty list, replace it by a list of one Doc indicating no change was done\n // on this field\n |> (fun l ->\n if List.length l > 0 then\n l\n else\n let str =\n match formKind with\n |Creation|Public|Link _ -> t.tt(\"Left Empty\")\n |Edition -> t.tt(\"No change\")\n [ span [attr.``class`` \"opacity-25\" ] [str] ]\n )\n // As we have a list of Docs, concatenate them to get one Doc\n |> Doc.Concat\n\n\n // Generates the list of Docs that are the rows of the \"grid\" displaying the updates applied by a form submission\n let specInGridFields (formKind:FormKind)(detailsSpecs:DetailSpec list)(spec:InstanceSpec) =\n detailsSpecs\n |> List.map (fun dspec ->\n UpdatesTemplate.Field()\n .Key(dspec.name)\n .Value(\n updateFeedbackForDetail formKind dspec spec\n )\n .DetailName(dspec.name)\n .Doc()\n )\n\n // Generates the list of Docs is the table displaying the update summary:\n // - first row is the column headers with the details names\n // - second row is the values\n let specInRow (formKind:FormKind)(detailsSpecs:DetailSpec list)(spec:InstanceSpec) =\n let keys =\n detailsSpecs\n |> List.map (fun dspec ->\n UpdatesTemplateInRow.KeyCell()\n .Key(dspec.name)\n .Doc()\n )\n let values =\n detailsSpecs\n |> List.map (fun dspec ->\n UpdatesTemplateInRow.ValueCell()\n .Value(\n updateFeedbackForDetail formKind dspec spec\n )\n .DetailName(dspec.name)\n .Doc()\n )\n [UpdatesTemplateInRow.FeedbackTable()\n .FieldsRow(keys)\n .ValuesRow(values)\n .Doc()]\n\n // Displays the infobox of a successful form submission\n let displaySavedMessage(displayer)(formKind:FormKind)(detailsSpecs:DetailSpec list)(spec:InstanceSpec) =\n let title =\n formKind\n |> function\n |Creation|Public|Link _ -> t.t(\"New entry overview\")\n |Edition -> t.t(\"Updates overview\")\n infobox (InfoBoxKind.SuccessBox)\n (div\n []\n [div [classes [BS.``pb-3``; BS.``fw-bold``]] [t.tt \"Saved successfully\"]\n UpdatesTemplate()\n .CardTitle(title)\n .Fields(displayer formKind detailsSpecs spec |> Doc.Concat)\n .Doc()\n ]\n )\n let displaySavedMessageInGrid (formKind:FormKind)(detailsSpecs:DetailSpec list)(spec:InstanceSpec) =\n displaySavedMessage specInGridFields formKind detailsSpecs spec\n\n let displaySavedMessageCompact (formKind:FormKind)(detailsSpecs:DetailSpec list)(spec:InstanceSpec) =\n displaySavedMessage specInRow formKind detailsSpecs spec", "namespace web\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen HtmlHelpers\nopen Css\n\n[]\nmodule DetailvalueFormater =\n // We need to define the type explicitely as the object expression\n //\n // let crate = { new Entity.IMarkupCrate with\n // member _.Apply (v:Entity.IMarkupEvaluator<_>) =\n // v.Eval s (detail.class_name)\n // }\n //\n // causes the error\n //\n // Method not found in JavaScript compilation: (Apply<_> : Entity+MarkupEvaluator`1<'?> -> '?), Candidates: (Apply<_> : Entity+MarkupEvaluator`1<'T0> -> 'T0)\n //\n // Defining the type explicitly and instanciating it like this:\n // let crate = new DataTableValueCrate(v)\n // works fine though.\n open HtmlHelpers\n open Css\n open WSExtensions\n open FormHelpers\n open Specs\n let stringOfValue (v:obj) =\n if isNull v then\n \"\"\n else\n string v\n\n // function to extract values from the yaml of a file attachment\n let extractFieldFromValue(v:obj) (field:string)=\n // We know this is a string\n let s:string = unbox v\n // this is yaml formatted, with one file per line\n s.Split([|'\\n'|])\n // extract the (unique) line with the key we're looking for\n |> Array.filter (fun s -> s.StartsWith(\":\"+field))\n // we split on ':', and take index 2 because the key starts with ':' too\n |> Array.map (fun s -> s.Split(':').[2])\n // trim spaces and quotes, in case the value was quoted (as is the case\n // sometimes for devail_value_id)\n |> Array.map (fun s -> s.Trim([|' ';'\"'|]))\n // don't return the array but its (unique) element\n |> Array.head\n\n // get the detail_value_id. We only have access to the value here, and\n // detail_value_id is stored under the key \":detail_value_id\"\n let extractDetailValueIdFromAttachmentValue (v:obj) =\n let s:string = unbox v\n if s.StartsWith(\"---\") then\n extractFieldFromValue v \"detail_value_id\"\n |> int\n else\n let info:ServerFileAttachment.FileAttachmentWithOptionalIndb = WebSharper.Json.Deserialize(s)\n info.detail_value_id |> Option.get\n\n\n // get the filename of the attachment\n let extractFileNameFromAttachmentValue (v:obj) =\n let s:string = unbox v\n if s.StartsWith(\"---\") then\n extractFieldFromValue v \"filename\"\n else\n let info:ServerFileAttachment.FileAttachmentWithOptionalIndb = WebSharper.Json.Deserialize(s)\n info.filename\n\n type DataTableValueCrate(s:string) =\n interface Entity.IMarkupCrate with\n member _.Apply (v:Entity.IMarkupEvaluator<_>) =\n v.Eval s\n type DataTableCellMarkupEvaluator(class_name:string) =\n interface Entity.IMarkupEvaluator with\n member _.Eval (value): Doc =\n match class_name with\n | \"EmailDetailValue\" -> a [attr.href $\"mailto:{stringOfValue value}\"] [text (stringOfValue value)]\n | \"WebUrlDetailValue\" -> a [attr.href (stringOfValue value)] [text (stringOfValue value)]\n | \"FileAttachmentDetailValue\" ->\n // this test of null values was added with file attachment display, when other deta types\n // were already done for a long time. It could be added before the \"match class_name\", but it causes trouble:\n // some tests check the number of links present in a page, and even if a web url detail value has\n // a null value, it is displayed as a link with empty text. Not displaying an empty link for a nul weburl detail value\n // will cause the tests to fail.\n // The solution would be to update the expected html, but it seems too big an effort for the benefit at this time.\n if isNull (unbox value) then\n Doc.Empty\n else\n a [attr.href (Routing.router.Link (GetAttachment (extractDetailValueIdFromAttachmentValue value)))] [text (extractFileNameFromAttachmentValue value)]\n | _ -> text (stringOfValue value)\n type FormFieldCrate(s:Var) =\n interface Entity.IMarkupCrate with\n member _.Apply (v:Entity.IMarkupEvaluator<'ret>) =\n // box argument otherwise type system requests a type constraint to Var\n v.Eval (box s)\n module private UploadHelpers =\n let t = ClientI18n.t\n let uploadFiles\n (fileVar:Var)\n (progressVar:Var)\n (fileUploadId:Var)\n (isValidVar:Var)\n (validationTextVar:Var)\n (cancelFunction:refunit>) =\n\n // Function setting the isValidVar to false and the corresponding validationTextVar\n let markInvalid(xhr:WebSharper.JavaScript.XMLHttpRequest) =\n isValidVar.Set false\n let translatedStatus = t.t(xhr.StatusText)\n let message = t.t(\"An error occured: %1. (Status = %2).\", translatedStatus, xhr.Status)\n validationTextVar.Set message\n\n let files = fileVar.Get()\n match files|>List.ofSeq with\n // if no file to be uploaded, do not send request, but still change the id for that field.\n // An empty string will be detected as no file uploaded. In prod, use DU!\n | [] -> fileUploadId.Set (Some \"\")\n | _ -> // We need to build a FormData and append the file to be uploaded\n let formData = JavaScript.FormData()\n files\n |> Array.iter (fun f -> formData.Append(f.Name,f))\n\n // We will send an xhr request to upload the file\n let xhr = new JavaScript.XMLHttpRequest();\n // set the cancel function to abort this xhr\n cancelFunction.Value <- (fun () ->\n xhr.Abort()\n // Reset progress to None, as it is used to decide the display of the file selection element\n progressVar.Set None\n )\n // Compute progress\n xhr.Upload.Onprogress <-\n (fun (ev) ->\n let progressEvent = downcast ev : JavaScript.ProgressEvent\n progressVar.Set( Some (int ((float progressEvent.Loaded) / (float progressEvent.Total)*100.0)))\n )\n // This callback is sent when the upload is finished (also when interrupted by server when file too big\n // but whole file was already sent)\n xhr.Onload <-\n (fun ev ->\n // Check status as a connection status 413 Payload Too Large can still end up here\n if xhr.Status<300 then\n isValidVar.Set true\n let response = xhr.Response\n // The server returns a simple JSON. We use anonymous records here, but in prod we could/should\n // use a proper record type shared by client and server.\n let fileInfo:{|id:string|} = unbox (WebSharper.JavaScript.JSON.Parse (unbox response))\n fileUploadId.Set (Some fileInfo.id)\n else\n markInvalid xhr\n\n )\n // This is called in case of error, eg the file sent it too big\n xhr.Onerror <-\n (fun ev ->\n markInvalid xhr\n )\n let uploadLink = Routing.router.Link HandleUpload\n // Do not set the content type here, it prevents the browser setting\n // data boundaries https://developer.mozilla.org/en-US/docs/Web/API/FormData/Using_FormData_Objects#sending_files_using_a_formdata_object\n // Now that we have defined all prerequisites like callback and formData, issue the xhr request\n xhr.Open(\"post\",uploadLink)\n xhr.Send(formData)\n open UploadHelpers\n // The form field formatted returns for each fied on instance of this type, which communicates to\n // the caller the state of each field, so it can deduce a global form state (eg is form submittable)\n type FormFieldInfo =\n {\n isValid: View\n waitingValidation: View\n // prepareSubmit is used to upload files before other fields are submitted\n // The bool indicates if the call was successful and if form submission can proceed\n // according to this field\n prepareSubmit: unit -> View\n cancelSubmit: refunit>\n // A function called after the form submission was handled on the server, the bool indicates if submission was successful\n // Introduced to reset file selection in forms after submission\n afterSubmissionCallback: bool*FormKind->unit\n reset : unit -> unit\n }\n type FormFieldMarkupEvaluator(detailSpec:Specs.DetailSpec) =\n // The evaluator returns the Doc of the field, a bool view indicating if the field holds a valid value and\n // a bool indicating if the field is still awaiting validation (due to a change)\n // Returning the validity view enables to prevent form submission if a field has an invalid value.\n interface Entity.IMarkupEvaluator with\n member _.Eval (var): Doc*FormFieldInfo =\n // The field's id including a random suffix. The field id is referenced by the label's `for` attribute.\n // It was initially simply the detail name. However, we could end up with a page having multiple forms for one entity\n // and including a rancom string in the id should avoid any problem.\n let fieldId = $\"{detailSpec.name}-{ClientHelpers.randomIntString 10000}\"\n\n // Wrap the field to display its label in the firls \"column\"\n let wrapField (field:Doc) =\n div [ classes [BS.row; BS.``mb-3``; BS.``align-items-center``] ]\n [\n div [classes [BS.``col-sm-4``]] [\n label [ attr.``for`` fieldId; classes [BS.``col-sm-4``; BS.``col-form-label``] ] [text detailSpec.name]\n ]\n div [classes [BS.``col-sm-8``]] [\n field\n ]\n ]\n // helper to combine the Doc and awaitingValidation view of the debounced field returned by the debouncedInput function\n // with the validity View defined locally\n let buildFieldInfo isValidView (resetFunction) (field,awaitingValidation) =\n wrapField field\n |> (fun field ->\n field,\n { isValid= isValidView;\n waitingValidation = awaitingValidation;\n prepareSubmit = (fun () -> View.Const true);\n cancelSubmit = ref (fun () -> ());\n afterSubmissionCallback = (fun _ -> ())\n reset = resetFunction\n })\n // The validation function is async so that both client side and server side validation\n // can be handled by this function.\n let validatedFieldAfterDelay (delay:int)(validationFunction:string->Async) (inputVar:Var) (resetFunction:unit->unit)=\n let isValidView =\n inputVar.View\n // do a RPC to validate, because WS does not translate Regexps to JavaScript\n |> View.MapAsync validationFunction\n let fieldClasses =\n isValidView\n |> View.Map (fun valid ->\n if valid then\n BS.``form-control``\n else\n [BS.``form-control``;BS.``is-invalid``]\n |> String.concat \" \"\n\n )\n // The DebouncedInput returns a triplet:\n // - the doc to display\n // - the awaitingValidation View\n // - a thunk to be used to reset the field. This is needed because the DebouncedInput uses an internal var that is not reset\n // when inputVar is reset, which is the case when the cretion form was submitted and fields are reset. Not resetting the\n // DebouncedInput internal var introduces an inconsistency: the ValueSpec is set to \"\" but the field still displays the (now obsolete) value\n // held by the internal var.\n Doc.debouncedInput [attr.id fieldId; attr.classDyn fieldClasses] delay inputVar\n |> (fun (doc,awaitingValidation,resetDebounced) -> buildFieldInfo isValidView (fun () -> resetFunction(); resetDebounced()) (doc,awaitingValidation) )\n // Define functions for client side (no delay) and server side (500ms delay) validations\n let serverSideValidatedField = validatedFieldAfterDelay 500\n let clientSideValidatedField = validatedFieldAfterDelay 0\n\n // Helper to update the value spec with the new client value\n let setClientProposed (old:ValueSpec) (cstructor:string option -> ClientValue) (value:string option) =\n // Replace empty string values by None\n // This makes that detail values updates to an empty value are actually erased from the database\n let cleanedUpValue = match value with |Some \"\" -> None | _ -> value\n {old with value = ClientProposed (cstructor cleanedUpValue)}\n\n\n // This uses WebSharper's IntInput for integer values.\n let validatedIntField (valueSpecVar:Var)(resetFunction:unit->unit) =\n let clientVar:Var =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v ->\n setClientProposed old ClientValue.Integer (Some v)\n )\n // the validity is based on the IntInput's var value\n let isValidView =\n clientVar.View\n |> View.Map\n (fun v ->\n // empty value is ok\n if v = \"\" then\n true\n else\n // refuse space-only value\n if v.Trim() = \"\" then\n false\n else\n match System.Int64.TryParse v with\n | true, _ -> true\n | _ -> false\n )\n let fieldClasses =\n isValidView\n |> View.Map (fun valid ->\n if valid then\n BS.``form-control``\n else\n [BS.``form-control``;BS.``is-invalid``]\n |> String.concat \" \"\n\n )\n Doc.InputType.Text [attr.id fieldId; attr.classDyn fieldClasses] clientVar\n |> (fun doc -> buildFieldInfo isValidView resetFunction (doc, View.Const false))\n\n // Helper to get the reset function for the var of the ValueSpec used by a form field.\n // Resetting the valueVar (corresponding most of the time to the string in the field is not sufficient as\n // it would retain the detail_value_id, meaning that the value of the previous detail valu would be overriden)\n let resetValueSpecThunk (var:Var) =\n (fun () -> var.Set (var.Value.Reset()))\n // Helper function to transform he doc of a field to a tuple indicating an always valid field\n // (i.e. not needing validation before submission)\n let makeAlwaysValid (resetFun)(doc:Doc) : Doc * FormFieldInfo=\n doc,\n {\n isValid=View.Const true;\n waitingValidation = View.Const false;\n prepareSubmit = (fun () -> View.Const true);\n cancelSubmit = ref (fun () -> ())\n afterSubmissionCallback = (fun _ -> () )\n reset= resetFun\n }\n\n match detailSpec.dataType.className with\n // the unbox var gives us a Var\n | \"DdlDetailValue\" ->\n let valueIds =\n detailSpec.propositions\n |>Option.get\n |>List.map\n (fun p ->\n //p.value\n let (Ids.DetailValuePropositionId propId) = p.detailValuePropositionId.Value\n propId\n )\n let displayOptionFor (optionId)=\n detailSpec.propositions\n |>Option.get\n |>List.map\n (fun p ->\n let (Ids.DetailValuePropositionId propId) = p.detailValuePropositionId.Value\n (p.value, propId)\n )\n |> List.filter (fun (_,id) -> optionId=id)\n |> List.head\n |> fst\n let getpropositionIdFromValue (v:Value) =\n match v with\n | ServerValidated sv ->\n match sv with\n |ServerValue.DdlValueChoice propOption -> propOption|>Option.map (fun o -> DdlChoice.toId o)\n | other -> failwithf \"unexpected server validated value %A where DdlValueChoice expected\" other\n | ClientProposed cp ->\n match cp with\n | ClientValue.DdlValueChoice intOption -> intOption\n | other -> failwithf \"unexpected client proposed value %A where DdlValueChoice expected\" other\n let valueSpecVar:Var = unbox var\n let valueVar = Var.Lens valueSpecVar\n (fun v ->\n getpropositionIdFromValue v.value\n )\n\n (fun old fromDdl ->\n {old with value = ClientProposed ((ClientValue.DdlValueChoice) fromDdl)}\n )\n let noneText = t.t(\"None\")\n Doc.InputType.SelectOptional [attr.id fieldId; classes [BS.``form-control``;BS.``form-select``]] noneText displayOptionFor valueIds valueVar\n |>wrapField\n |>makeAlwaysValid (resetValueSpecThunk valueSpecVar)\n | \"LongTextDetailValue\" ->\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.LongText (Some v))\n Doc.InputType.TextArea [attr.id fieldId; classes [BS.``form-control``]] valueVar\n |> wrapField\n |> makeAlwaysValid (resetValueSpecThunk valueSpecVar)\n | \"SimpleDetailValue\" ->\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.Simple (Some v))\n Doc.InputType.Text [attr.id fieldId; classes [BS.``form-control``]] valueVar\n |> wrapField\n |> makeAlwaysValid (resetValueSpecThunk valueSpecVar)\n | \"EmailDetailValue\" ->\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.Email (Some v))\n serverSideValidatedField Server.isEmailValid valueVar (resetValueSpecThunk valueSpecVar)\n | \"IntegerDetailValue\" ->\n let valueSpecVar:Var = unbox var\n validatedIntField valueSpecVar (resetValueSpecThunk valueSpecVar)\n | \"WebUrlDetailValue\" ->\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.WebURL (Some v))\n serverSideValidatedField Server.isWebURLValid valueVar (resetValueSpecThunk valueSpecVar)\n | \"DateDetailValue\" ->\n let dateValidationAsync (s:string) = async {\n return DateAndTime.isValid s\n }\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.DateAndTime (Some v))\n clientSideValidatedField dateValidationAsync valueVar (resetValueSpecThunk valueSpecVar)\n | \"FileAttachmentDetailValue\" ->\n let valueSpecVar:Var = unbox var\n // If the file gets deleted, we need to set the detailValueId of the ValueSpec to None. This Var enables this\n let valueSpecDetailValueIdVar =\n valueSpecVar.Lens\n (fun v -> v.detailValueId)\n (fun old v -> {old with detailValueId = v })\n // Attention:\n // As this var is used as a lens source for other vars below, changing one of thess vars below will change this var\n // to be a ClientProposed value. Vars derived from this one should thus not be changed if this field value is not changed\n let specValueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v ->\n setClientProposed old ClientValue.FileAttachment (Some v))\n\n // Keep the initial value in case the user resets the file selection when a file is already saved on the server\n // for this detail value\n let serverValueVar = Var.Create (specValueVar.Get())\n // Define a lens var holding the FileAttachment record, result of deserialising the specValueVar\n let fileAttachmentVar:Var=\n specValueVar.Lens\n // getter\n (fun v ->\n Json.Deserialize(v)\n )\n // writer\n (fun v fromField ->\n Json.Serialize fromField\n )\n // Define a lens var for each field of the FileAttachment\n let filenameVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.filename)\n let filetypeVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.filetype)\n let s3KeyVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.s3_key)\n let uploadedVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.uploaded)\n let inDbVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.indb)\n let detailValueIdVar =\n fileAttachmentVar.LensAuto\n (fun r -> r.detail_value_id)\n\n // Validity variables\n // coommunicate to form if field is valid\n let isValidVar = Var.Create true\n // message to be displayed when field is invalid\n let validationTextVar = Var.Create \"\"\n\n // View of the Doc to be displayed with the error. Empty Doc if no error.\n let errorBoxView =\n View.Map2\n (fun isValid validationText ->\n match isValid with\n | false -> infobox Danger (span [] [text validationText])\n | true -> Doc.Empty\n )\n isValidVar.View\n validationTextVar.View\n\n // Define a lens var (jsFilesVar) holding an array of javascript file objects, to be passed to the Doc.InputType.File.\n let jsFilesVar:Var = Var.Create [||]\n // Define var to hold the upload progress\n let progressVar:Var = Var.Create None\n // Define var to hold the upload id, which is returned by the server.\n // This identifies the file on the server side and has to be sent when the form is submitted.\n let uploadIdVar:Var = Var.Create None\n // This function is used to cancel an ongoing upload. It is a ref because it needs to be set in the function uploadFiles\n // which is issuing the xhr.\n let cancelFunction:refunit> = ref (fun () -> ())\n\n // Function to reset the file selector.\n // Beware that changing a var derived from specValueVar will changed this field as a ClientProposed\n // and thus will be included it in the form processing.\n let resetFileSelectionField () =\n // Set uploadIdVar to None, otherwise the upload is considered as uploaded\n uploadIdVar.Set None\n // Set progressVar to None so the file selection element is shown\n progressVar.Set None\n // Set jsVarFilesVar to an empty array so the file selection element is reset\n jsFilesVar.Set [||]\n let resetToServerValue() =\n resetFileSelectionField()\n // When the user resets the field, we reset it to the value currently save for this detailvalue on the server\n specValueVar.Set (serverValueVar.Get())\n // Reinitialise field, eg after deletion\n let reinitialiseFileSelectionField()=\n resetFileSelectionField()\n // Reset to empty file\n fileAttachmentVar.Set (ServerFileAttachment.New())\n // Also reset the value considered as initially on the server\n serverValueVar.Set(specValueVar.Get())\n\n // Resetting a file input element is done by setting its value to \"\"\n // This can only be done by working with the element in javascript.\n // I wanted to reset the file input element only by setting the Var to an empty array.\n // To that end, I watch the changes on the Var, and if it is set to an empty array,\n // the value of the file input is set to \"\". To identify the file input, it is assigned a randomly generated data-*\n // attribute getting a random value. These are used with Document.QuerySelector\n let resettableFileInput attrs (jsFilesVar: Var) (progressVar:Var)=\n let randomAttributeSuffix = ClientHelpers.randomIntString 10000\n let randomString = ClientHelpers.randomIntString 10000\n jsFilesVar.View |> View.Sink\n (fun v ->\n if Seq.isEmpty v then\n let fileElt = (downcast JavaScript.JS.Document.QuerySelector($\"[data-{randomAttributeSuffix}=\\\"{randomString}\\\"]\"): WebSharper.JavaScript.HTMLInputElement)\n if not (isNull fileElt) then\n fileElt.Value <- \"\"\n\n )\n div []\n [\n Client.Doc.InputType.File (attrs |> Seq.append [|Attr.Create $\"data-{randomAttributeSuffix}\" randomString|] ) jsFilesVar\n // The reset button is only displayed when a file is selected.\n jsFilesVar.View\n |> View.Map (fun files ->\n if Array.length files = 0 then\n span [] []\n else\n button\n [\n attr.``class`` \"btn btn-secondary\"\n on.click (fun ev el->\n // When the user resets the field, we reset it to the value currently saved for this detailvalue on the server\n resetToServerValue ()\n )\n ]\n [t.tt(\"Reset\")]\n ) |> Doc.EmbedView\n ]\n\n\n // When the file selection is modified, we update the FileAttachment Var accordingly\n jsFilesVar.View\n |> View.Sink\n (function\n // If no file is selected, set all values of FileAttachment to empty\n | [||] ->\n // Do not reset vars if the file is uploaded, as it would reset the vars when receiving the\n // ServerValidation spec at render of the page\n // This should not cause trouble as if the uploaded is true, the file selectionis not displayed\n // Also, do not reset if the filename is empty. This happens at first show of the field. Not testing\n // This \"filename empty\" condition makes that we then would update a var derived from valueSpecVar, which\n // then triggers a change of the ValueSpec to a ClientProposed, which is not fine at first render of the\n // form (the field would be considered as changed as it has become a ClientProposed)\n if not uploadedVar.Value && filenameVar.Value <> \"\" then\n filenameVar.Set \"\"\n filetypeVar.Set None\n uploadedVar.Set false\n isValidVar.Set true\n s3KeyVar.Set None\n // When a file is selected, set its name and type, and reset key and uploaded (needed\n // as this is a new file that is selected and it is not uploaded)\n | [|jsFileInfo|] ->\n // IMPORTANT: keep the update to inDbVar as first change as it triggers different behaviour for\n // later changes (it allows to keep non-modifified file fields as ServerValidated. See updateValue in\n // InstanceForm.fs for FileAttachment)\n inDbVar.Set false\n uploadedVar.Set false\n s3KeyVar.Set None\n filenameVar.Set jsFileInfo.Name\n filetypeVar.Set (Some jsFileInfo.Type)\n // When a file is selected, check its size is acceptable\n if jsFileInfo.Size > JavaScript.JS.Inline(\"window.myowndb_fileAttachments_maxBytes\") then\n isValidVar.Set false\n validationTextVar.Set (t.t(\"File too big\"))\n else\n isValidVar.Set true\n validationTextVar.Set (\"\")\n\n | _ ->\n raise (System.Exception(\"multiple files selected but this is not supported\"))\n )\n // When the upload id is set, the file has been uploaded, and we update the uploaded field accordingly.\n // This is probably redundant legacy, but left as is for the moment.\n // We also set the s3key to the upload id, with the plan to clean it later (using a proper field name)\n uploadIdVar.View\n |> View.Sink\n (fun idOption ->\n match idOption with\n // If the upload id is empty, this means no file was uploaded because no file was selected.\n | Some \"\" -> ()\n // Only update the Vars if the upload has effectively taken place so that the FileAttachment instance\n // is updated accordingly\n | Some uploadId ->\n uploadedVar.Set true\n s3KeyVar.Set idOption\n | None -> ()\n\n )\n\n // We need to reuse the same input element so that selected files are kept when canceling an upload.\n let fileInputElement =\n div []\n [\n resettableFileInput [attr.id fieldId] jsFilesVar progressVar\n ]\n\n // The View indicating if the file selector should be displayed\n let shouldDisplayFileSelector =\n View.Map2\n (fun (progress: int option) indb -> not progress.IsSome && not indb\n )\n progressVar.View\n inDbVar.View\n\n\n div [] [\n // Here is the UI shown to the user\n // We keep the file selection element always in the document, otherwise the afterSubmissionCallback might not work\n // because it is working with havascript's document element selection\n div [attr.classDynPredBoth \"d-block\" \"d-none\" shouldDisplayFileSelector ] [fileInputElement]\n // Display other elements related to the file selection (progress or uploaded filename). These should be displayed only\n // when the file selection element is not shown, so make sure the conditions checked are opposite to the previous div's class display.\n progressVar.View\n |> View.Map\n (function\n |Some progress ->\n if progress < 100 then\n div [] [text (sprintf \"%d%%\" progress)]\n else\n div [] []\n |None ->\n div [] []\n )\n |> Doc.EmbedView\n View.Map3\n (fun filename indb progress->\n match progress with\n |Some progress ->\n if progress < 100 then\n div [] [text (sprintf \"%d%%\" progress)]\n else\n div [] []\n |None ->\n let deleteElement ()=\n DeleteConfirmation.deleteConfirmation \"attachment\" (\n (fun () -> async {\n match! Server.deleteAttachment (fileAttachmentVar.Get()) with\n | Ok _ ->\n reinitialiseFileSelectionField()\n valueSpecDetailValueIdVar.Set None\n // signal success\n return true\n | Error _ ->\n // signal failure\n return false\n })\n )\n\n if indb then\n detailValueIdVar.Get()\n |> Option.map (fun detailValueId ->\n div []\n [ t.tt \"File currently saved in the database\"\n text \":\"\n a [classes [BS.``pe-1``]; attr.href (Routing.router.Link (GetAttachment (int64 detailValueId)))] [text filename]\n // FIXME: this element causes flickering when the user clicks no\n deleteElement().V\n ]\n )\n // For the creation form the detailValueIdVar value is None, in which case we display an empty doc\n |> Option.defaultValue (div [] [])\n else\n div [] []\n )\n filenameVar.View\n inDbVar.View\n progressVar.View\n |> Doc.EmbedView\n errorBoxView.V\n ]\n |> wrapField\n ,\n { isValid = isValidVar.View\n waitingValidation =View.Const false\n // The prepareSubmit function for a file field uploads the file and returns a View which will\n // be true when the file has been uploaded. This View is built from the Var holding the uploadId returned\n // by the server\n prepareSubmit = fun () ->\n uploadFiles jsFilesVar progressVar uploadIdVar isValidVar validationTextVar cancelFunction\n uploadIdVar.View |> View.Map (fun o -> o.IsSome)\n cancelSubmit = cancelFunction\n afterSubmissionCallback =\n fun (success:bool,formKind:FormKind) ->\n if formKind = Edition then\n resetFileSelectionField()\n else\n (resetValueSpecThunk valueSpecVar)()\n reset = resetFileSelectionField\n }\n | _ ->\n let valueSpecVar:Var = unbox var\n let valueVar =\n valueSpecVar.Lens\n (fun v -> valueToString (valueSpecVar.Value.value))\n (fun old v -> setClientProposed old ClientValue.Simple (Some v))\n Doc.InputType.Text [attr.readonly \"readonly\"; attr.id fieldId; classes [BS.``form-control``]] valueVar\n |> wrapField\n , {\n isValid=View.Const true;\n waitingValidation = View.Const false;\n prepareSubmit = (fun () -> View.Const true);\n cancelSubmit = ref (fun () -> ())\n afterSubmissionCallback = (fun _ -> ())\n reset = (resetValueSpecThunk valueSpecVar)\n }\n let memoizedEvaluatorGetter () =\n let mutable cache= new Map([||])\n let getEvaluator (class_name:string) =\n match cache.TryFind class_name with\n | Some ev ->\n ev\n | None -> let ev = DataTableCellMarkupEvaluator(class_name)\n cache <- cache.Add(class_name,ev)\n ev\n getEvaluator\n\n let displayDetailValue (d:Entity.EntityDetail) value =\n let getEvaluator = memoizedEvaluatorGetter()\n let crate = DataTableValueCrate(value)\n let evaluator = getEvaluator(d.class_name)\n d.display crate evaluator\n", "namespace web\n\nopen WebSharper.UI.Html\nopen WebSharper\nopen NGettext\nopen WebSharper.UI\nopen WebSharper.UI.Client\nopen ClientI18n\nopen HtmlHelpers\nopen WSExtensions\nopen Css\n\n[]\nmodule InstanceForm =\n open Specs\n open FormHelpers\n let t=JStr()\n\n open FormHelpers\n\n module private Helpers =\n let buildInstanceForm\n (formKind:FormKind)\n // callback that returns a doc displayed under the form to signal successful save\n (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)\n (entityId:Ids.EntityId)\n (detailsSpecs:DetailSpec list)\n (lensMap:ref>>)\n (specVar:Var)\n (additionalButtons:Doc)\n =\n // Define form and collect field information in the list of records `infos`\n // Collecting all records in the list `infos` makes it more flexible: we can add a field to the record and use it by iterating\n // over the records.\n let form, infos =\n // work with detailsSpecs because the instance spec does not include enough information\n // regarding the details (eg name, value propositions)\n detailsSpecs\n |> List.map (fun detailSpec ->\n let fieldVarOption = (Map.tryFind (detailSpec.detailId|>Option.get) (lensMap.Value))\n let fieldVar =\n match fieldVarOption with\n | Some v ->\n v\n | None ->\n // This should never occur as we added empty detail values for details which had none\n failwith \"A detail without value was encountered at a point where this shoud not be possible\"\n let evaluator = DetailvalueFormater.FormFieldMarkupEvaluator detailSpec\n // explicitly type annotate with the interface so .Apply can be called on it\n let crate:Entity.IMarkupCrate = DetailvalueFormater.FormFieldCrate(fieldVar)\n crate.Apply evaluator\n )\n // for each field we get a tuple (doc,fieldIsValidView,fieldIsChangedView,prepareSubmit). Here we split these in lists\n |> (fun l ->\n List.fold\n (fun (docs,infos)(doc,info:DetailvalueFormater.FormFieldInfo) ->\n List.append docs [doc] ,\n List.append infos [info]\n )\n ([],[])\n l\n )\n\n // Define aggregated view from info received from the form fields\n // (sequence transforms a list of views in a view of a list)\n let validityViews = infos |>List.map(fun r -> r.isValid)\n let validityView = View.sequence validityViews\n let awaitingValidationViews = infos |> List.map (fun r -> r.waitingValidation)\n let awaitingValidationView = View.sequence awaitingValidationViews\n\n // Define helper functions to run callbacks we got from form fields\n // We need to wait for all preparation functions to be done\n let runPrepareFunctions() = infos\n |> List.map (fun r-> r.prepareSubmit())\n // Transform list of view to view of list\n |> View.Sequence\n // Map the sequence of bools to one bool value indicating if\n // all preparetion calls are done\n |> View.Map (fun s -> s|> Seq.forall id)\n // Beware, this is not a call to the method Value(), but retrieving the function in the ref\n // and then calling it!\n let runCancelCallbacks() = infos |> List.iter (fun r -> r.cancelSubmit.Value())\n let runSuccessCallbacks() = infos |> List.iter (fun r -> r.afterSubmissionCallback(true,formKind))\n let runFailureCallbacks() = infos |> List.iter (fun r -> r.afterSubmissionCallback(false,formKind))\n let resetForm() = infos |> List.iter (fun info -> info.reset())\n\n\n // The form is invalid if any field is invalid\n let formIsInvalid =\n validityView\n |> View.Map (List.contains false)\n\n // The a field was edited but not yet validated\n let formHasFieldAwaitingValidation =\n awaitingValidationView\n |> View.Map (List.contains true)\n\n // An invalid button has the additional class disabled\n let buttonClasses =\n View.Map2\n (fun isInvalid awaitsValidation ->\n if isInvalid || awaitsValidation then\n // Disable submission if invalid or waiting for validation to occur\n // (Server validation delayed to not do it at every key press)\n String.concat \" \" [BS.btn; BS.``btn-primary``; BS.disabled]\n else\n String.concat \" \" [BS.btn; BS.``btn-primary``]\n\n )\n formIsInvalid\n formHasFieldAwaitingValidation\n let isDisabled =\n View.Map2\n (fun isInvalid awaitsValidation -> isInvalid || awaitsValidation )\n formIsInvalid\n formHasFieldAwaitingValidation\n\n // User feedback regarding form submission\n let resultVar = Var.Create Doc.Empty\n // Var indicating if preparation (attachment uploads) is currently occuring. Used to enable canceling uploads\n let isPreparing = Var.Create false\n let t = JStr()\n div [ attr.``data-`` \"form-entity-id\" (Ids.EntityId.Get entityId |> string) ]\n [\n div [] form; br [] [];\n Doc.Button (t.t(\"Save\"))\n [attr.``class`` buttonClasses.V ; attr.disabledBool isDisabled]\n (fun () ->\n async {\n // We call the prepareSubmit functions of all fields. These each return a View indicating if\n // form submission can proceed. We combine these by a logical AND to get a global View indicating\n // if all fields are ready for form submission to proceed.\n isPreparing.Set true\n let prepareSubmitDone = runPrepareFunctions()\n // We wait until prepareSubmitDone has value true\n let! _ = prepareSubmitDone |> View.AsyncAwait id\n isPreparing.Set false\n // prepareSubmit is done for all fields (file attachments have been uploaded) and we can now submit\n // the instance spec to the server.\n try\n // Our client side only FormKind has no parameter, but is not known by the servre. The server side FormKind\n // required an argument, which we pass here\n let entityIdInt = (entityId|>Ids.EntityId.Get)\n let serverFormKind =\n match formKind with\n | Creation -> Server.FormKind.CreationForm entityIdInt\n |Edition ->\n let instanceIdFromSpec = specVar.Value.instanceId |> Option.get |> Ids.InstanceId.Get\n Server.FormKind.EditionForm instanceIdFromSpec\n | Public ->Server.FormKind.PublicForm entityIdInt\n | Link linkFormInfo -> Server.FormKind.LinkForm {entityId=entityIdInt; relationId = linkFormInfo.relationId; dirAndId=linkFormInfo.dirAndId}\n let! res = Server.createOrUdpdateInstance serverFormKind (specVar.Get())\n match res with\n | Ok [spec] ->\n spec.detailValues\n // Update the values in the instance spec to enable re-edition of fields\n |> List.iter (fun dv ->\n (lensMap.Value.[dv.detailId]).Set(dv.values[0])\n )\n runSuccessCallbacks()\n resultVar.Set (successDocCallback formKind detailsSpecs spec)\n // For public form, redirect to a success message replacing the form\n if formKind = Public then\n ClientRouting.installedRouter.Value <- PublicFormSubmitted entityIdInt\n | Ok l ->\n runFailureCallbacks()\n JavaScript.Console.Log(sprintf \"%A\" l)\n resultVar.Set (infobox (InfoBoxKind.Danger)(div [] [t.tt \"Saving resulted in an inconsistent state\"]))\n | Error e ->\n runFailureCallbacks()\n resultVar.Set (infobox (InfoBoxKind.Danger)(div [] [text (e|> Error.toString)]))\n with\n | e ->\n resultVar.Set (infobox (InfoBoxKind.Danger)(div [] [t.tt \"Error communicating with server.\"; text (e.Message)]))\n runFailureCallbacks()\n raise e\n // Reset form if needed\n match formKind with\n // Creation forms are reset so new entries can be created tapidly\n | Creation | Public | Link _-> resetForm()\n // The edition form is not reset so the instance can immediately be re-edited if needed.\n | Edition -> ()\n } |> Async.Start\n );\n Doc.Button (t.t(\"Cancel\"))\n [attr.classDynPredBoth (\"d-inline btn btn-secondary\")(\"d-none btn btn-secondary\") isPreparing.View]\n (fun () ->\n // uploads are canceled so the form is not preparing submission anymore, and this buttin can be hidden\n isPreparing.Set false\n runCancelCallbacks()\n )\n additionalButtons\n span [] [resultVar.V]\n ]\n open Helpers\n\n let instanceFormForSpecFromServer\n (formKind:FormKind)\n // callback that returns a doc displayed under the form to signal successful save\n (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)\n (instanceSpecOption:option>) =\n match instanceSpecOption with\n | Some (spec,detailsSpecs) ->\n let detailIdsWithValue =\n spec.detailValues\n |> List.map ( fun dv -> dv.detailId\n )\n // buidl list of details which have no value\n let detailsWithoutValue =\n detailsSpecs\n |> List.filter (fun (item:DetailSpec) -> not (List.contains (item.detailId|>Option.get) detailIdsWithValue ) )\n // update spec with detailValues for details without values\n // This is necessary so that we can have lenses to details which currently have no value\n let fullSpec = addMissingDetailValues spec detailsWithoutValue\n\n // Create a Var wrapping the fullSpec so we can define a lens for each detail value.\n let specVar = Var.Create fullSpec\n // To DEBUG, uncomment this and follow the updates to the spec to be sent to the server\n // specVar.View |> View.Sink (fun spec -> printfn \"specvar content: %A\" spec)\n\n // Build a map of lenses zooming in the full instance spec\n let lensMap = buildLensMap specVar\n let additionalButton =\n match spec.instanceId with\n | Some instanceId ->\n a\n [ classes [BS.btn;BS.``btn-primary``]\n attr.href (Routing.router.Link (EndPoint.Instance (instanceId|>Ids.InstanceId.Get, None) ))\n ]\n [\n t.tt(\"View\")\n ]\n | _ ->\n match formKind with\n | Public ->\n a\n [ attr.target \"_blank\"\n attr.href \"https://www.myowndb.com\"\n classes [ BS.``fw-lighter``; BS.``p-3`` ] ]\n [ text \"Powered by MyOwndb\" ]\n | _ -> Doc.Empty\n\n buildInstanceForm formKind successDocCallback (spec.entityId) detailsSpecs lensMap specVar additionalButton\n | None ->\n div [] [text \"problem getting spec\"]\n\n // Display the instance creation form\n let displayCreate id (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)= async {\n // Display form for edition of an existing instance\n let! instanceSpecOption = Server.getInstanceAndDetailsSpec (Server.CreationForm id)\n return instanceFormForSpecFromServer Creation successDocCallback instanceSpecOption\n }\n\n // Display the instance edition form\n let displayEdit id (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)= async {\n let! instanceSpecOption = Server.getInstanceAndDetailsSpec (Server.EditionForm id)\n return instanceFormForSpecFromServer Edition successDocCallback instanceSpecOption\n\n }\n\n // Display the public form\n let displayPublic id (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)= async {\n let! instanceSpecOption = Server.getInstanceAndDetailsSpec (Server.PublicForm id)\n return instanceFormForSpecFromServer Public successDocCallback instanceSpecOption\n }\n\n // Display the linked instance creation form\n let displayLink id formKind (successDocCallback:FormKind ->list -> InstanceSpec -> Doc)= async {\n // Display form for edition of an existing instance\n let! instanceSpecOption = Server.getInstanceAndDetailsSpec (Server.CreationForm id)\n return instanceFormForSpecFromServer formKind successDocCallback instanceSpecOption\n }\n", "namespace web\n\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Html\n// needed for UI.Html.attr.disableDynPred\nopen WebSharper.UI.Client\nopen HtmlHelpers\nopen Css\nopen WebSharper.JavaScript\nopen System\nopen ClientI18n\n\n[]\nmodule Datatable =\n open DatatableTypes\n open FormHelpers\n\n // We set the number of pagination links to an even number. We display half that number of\n // navigation links before the current page \"link\", and half after.\n // We need to handle the situation near the first and last pages.\n // We look how many links are missing in front (resp. at the end), and\n // add those ot the end (resp; the front) if possible\n // Page numbers are 1 based.\n // We illustrate with N=6 navigations links, ie 3 before and 3 after\n // links marked with n are links that are normal cases, those marked with -\n // are links to non existing pages so not displayed, and links marked + are\n // those added to compensate for missing links at the other side.\n // .........._____________________\n // |-2| | | 1| 2| 3| 4| 5| 6| 7| (a)\n // - - - p n n n + + +\n // ......._____________________\n // | | | 1| 2| 3| 4| 5| 6| 7| (b)\n // - - n p n n n + +\n // ...._____________________\n // | | 1| 2| 3| 4| 5| 6| 7| (c)\n // - n n p n n n +\n // When the current page p, we computer the absolute first, ie the page number of the\n // first link without paying attention to the limits to respect\n // We see that the missing links before are -absoluteFirst+1.\n // The normal last link is p + N /2 to which we add the links missing in front.\n // As we need to not go further than the number of pages available, we take the minimum with\n // of both.\n // Similar logic applies to links added in front.\n let paginatedPagesBoundaries numberOfLinks currentPageValue numberOfPagesValue=\n let absoluteFirst = currentPageValue - numberOfLinks/2\n let absoluteLast = currentPageValue + numberOfLinks/2\n let missingBefore = max ( -absoluteFirst + 1 ) 0\n let missingAfter = max (absoluteLast - numberOfPagesValue ) 0\n let firstLinkNumber = (max (currentPageValue - numberOfLinks/2 - missingAfter) 1)\n let lastLinkNumber = min (currentPageValue + numberOfLinks/2 + missingBefore) numberOfPagesValue\n (firstLinkNumber,lastLinkNumber)\n let computeNumberOfPages totalRows rowsPerPage =\n int ( ceil ((float totalRows) / (float rowsPerPage)))\n\n // ********************\n // Pagination links\n // returns the list of pagination links\n // includes links to\n // - first\n // - previous\n // - x direct page links\n // - next\n // - last\n // the argument currentPage is actually Lenses from argument paginationState.\n // I pass both as argument rather than re-Lens into paginationState.\n let getNavigationLinks (paginationState:Var) numberOfPages =\n let currentPage = paginationState.LensAuto (fun v -> v.currentPage)\n // initialise data and Views\n let (<*>) f s = View.Apply f s\n let onNumberClick(n) = (fun (_el:Dom.Element) (e:Dom.MouseEvent) -> e.PreventDefault();currentPage.Set (n))\n\n let computePaginationLinks currentPageValue numberOfPagesValue =\n let numberOfLinks = 6\n let firstLinkNumber,lastLinkNumber = paginatedPagesBoundaries numberOfLinks currentPageValue numberOfPagesValue\n seq { for i in firstLinkNumber .. lastLinkNumber do\n yield i\n }\n |> Seq.map (fun i ->\n let isCurrentPage = currentPageValue = i\n let activeClass = if isCurrentPage then \"active\" else \"\"\n li [classes [BS.``page-item``; activeClass; \"myowndbpaginationnumber\"]\n UI.Html.attr.disabledDynPred (View.Const \"disabled\") (View.Const isCurrentPage )\n ]\n [a [attr.``class`` \"page-link\" ; attr.href \"#\"; UI.Html.on.click (onNumberClick i)]\n // FIXME: double digits page numbers links are winder than single digit page number links\n [ text $\"{i}\" ]\n ]\n )\n |> Doc.Concat\n let paginationLinks = View.Const computePaginationLinks <*> currentPage.View <*> numberOfPages\n\n // Start of content building\n let first = paginationState.View |> View.MapCached (fun r ->\n let onClick = (fun (_el:Dom.Element) (e:Dom.MouseEvent) -> e.PreventDefault(); if currentPage.Get()<>1 then currentPage.Set 1)\n li [ attr.``class`` \"page-item\"\n UI.Html.attr.classDyn (V(if numberOfPages.V = 0 || currentPage.V=1 then \"page-item disabled\" else \"page-item\"))\n // only act if we are not on the first page already.\n // asiigning the disabled CSS class does not disable the link action\n ]\n [ a [classes [BS.``page-link``; \"myowndbpaginationfirst\"]; attr.href \"#\"; UI.Html.on.click onClick]\n [text \"|«\"]\n ]\n )\n // previous page button\n let previous = paginationState.View |> View.MapCached (fun r ->\n let onClick = (fun (_el:Dom.Element) (e:Dom.MouseEvent) -> e.PreventDefault(); if currentPage.Get()<>1 then currentPage.Set (currentPage.Value-1))\n li [ attr.``class`` \"page-item\"\n UI.Html.attr.classDyn (V(if numberOfPages.V = 0 || currentPage.V=1 then \"page-item disabled\" else \"page-item\"))\n // only act if we are not on the first page already.\n // asiigning the disabled CSS class does not disable the link action\n ]\n [ a [classes [BS.``page-link``;\"myowndbpaginationprevious\"] ; attr.href \"#\"; UI.Html.on.click onClick ]\n [text \"‹\"]\n ]\n )\n // next page button\n let next = paginationState.View |> View.MapCached (fun r ->\n let onClick = (fun (_el:Dom.Element) (e:Dom.MouseEvent) -> e.PreventDefault();numberOfPages |> View.Get (fun n -> if n>0 && currentPage.Get() <> n then currentPage.Set (currentPage.Value+1)))\n li [attr.``class`` \"page-item\"\n UI.Html.attr.classDyn (V(if numberOfPages.V = 0 || currentPage.V=numberOfPages.V then \"page-item disabled\" else \"page-item\"))\n // only act if we are not on the last page already.\n // asiigning the disabled CSS class does not disable the link action\n ]\n [a [classes [BS.``page-link``; \"myowndbpaginationnext\"]; attr.href \"#\"; UI.Html.on.click onClick]\n [text \"›\"] ]\n )\n // last page button\n let last = paginationState.View |> View.MapCached (fun r ->\n let onClick = (fun (_el:Dom.Element) (e:Dom.MouseEvent) -> e.PreventDefault(); numberOfPages |> View.Get (fun n -> if n>0 then currentPage.Set n) )\n li [attr.``class`` \"page-item\"\n UI.Html.attr.classDyn (V(if numberOfPages.V = 0 || currentPage.V=numberOfPages.V then \"page-item disabled\" else \"page-item\"))\n // only act if we are not on the last page already.\n // asiigning the disabled CSS class does not disable the link action\n ]\n [a [classes [BS.``page-link``; \"myowndbpaginationlast\"]; attr.href \"#\"; UI.Html.on.click onClick]\n [text \"»|\"] ]\n )\n [ first; previous ; paginationLinks ; next; last;]\n\n // ********************\n // Rows per page select\n let getPerPageSelect (paginationState:Var) (count:View)=\n // use another var for handling user choice in a drop down list.\n // This is needed to properly handle the case when increasing the\n // rows per page leads to the currentPage being out of range\n let perPageDdl = Var.Create (paginationState.Value.perPage)\n\n // function to ensure we display a valid page when the user changes\n // the number of rows displayed per page.\n let constrainCurrentPage (el:JavaScript.Dom.Element) (ev:JavaScript.Dom.Event) =\n // access the value of a view with View.Get (fun currentValue -> ...)\n // and do work in the function passed.\n count\n |> View.Get (fun c ->\n // compute total pages with new perPage selected\n let newTotalPages = (computeNumberOfPages c (perPageDdl.Value))\n // we can now set the pagination state to a consitent value\n paginationState.Set {currentPage = (min (paginationState.Value.currentPage) newTotalPages)\n perPage = perPageDdl.Value\n }\n )\n li [attr.``class`` \"page-item\"] [\n Doc.InputType.Select [ classes [BS.``form-select-sm`` ; BS.``page-link`` ; \"myowndbperpageddl\"] ;\n UI.Html.on.change constrainCurrentPage ]\n string\n [10; 20;30;50;100;300;500]\n perPageDdl\n ]\n\n // *************\n // Search fields\n let getSearchFields (detailsResult:Result,string>) (paginationState:Var) (searchCriteria:Var) =\n\n let currentPage = paginationState.LensAuto (fun v -> v.currentPage)\n let columnSearched = searchCriteria.LensAuto (fun v -> v.column)\n let valueSearched = searchCriteria.LensAuto (fun v -> v.value)\n let valueTyped = Var.Create valueSearched.Value\n let submitOnEnter () = on.keyUp (fun el ev -> if ev.KeyCode = 13 then\n valueSearched.Set valueTyped.Value\n currentPage.Set 1\n\n )\n let clearOnClick () = on.click (fun el ev -> valueTyped.Set \"\"; valueSearched.Set \"\")\n\n // search form\n let columnSearchedDdl =\n li [classes [BS.``page-item``; ] ] [\n Doc.InputType.Select [ classes [BS.``form-select-sm`` ; BS.``page-link`` ; \"myowndbsearchddl\"] ]\n string\n (detailsResult\n |> Result.map (List.map (fun d -> d.name ))\n |> (function\n | Ok l -> l\n | Error _ -> [\"\"]\n )\n )\n columnSearched\n ]\n let valueSearchedInput =\n [\n li [attr.``class`` \"page-item\"\n\n ]\n [\n Doc.InputType.Text [\n classes [BS.``form-select-sm`` ; BS.``page-link``; \"myowndbsearchvalue\" ];\n submitOnEnter()\n Attr.Create \"placeholder\" (t.t(\"Press Enter to search\"))\n ]\n valueTyped\n ]\n span [attr.``class`` \"input-group-text myowndbclearsearch\"; clearOnClick()] [li [attr.``class`` \"fas fa-backspace page-item\"] []]\n ] |> Doc.Concat\n\n [ columnSearchedDdl; valueSearchedInput; ]\n\n // ************************\n // number of rows indicator\n let rowsCountIndicator (count:View) =\n li [ classes [BS.``page-item``; \"myowndb-table-rows-count\"];]\n [ a [ attr.``class`` \"page-link\" ; attr.href \"#\"]\n [ textView (count|> View.MapCached (fun c -> t.n(\"There is %1 row\",\"There are %1 rows\",c) )) ]\n ]\n\n // get information from database\n let queryDatabaseRows (tableType: TableType) (id:int) (searchCriteria:Var) (sortCriteria:Var) (stateVar:Var)=\n let paginationState =\n let defaultValue = {currentPage=1; perPage=10}\n in\n stateVar.Lens\n (fun state ->\n match state with\n | None -> defaultValue\n | Some s ->\n match s.paginationState with\n | Some pagination -> pagination\n | _ -> defaultValue\n\n )\n (fun state newPagination ->\n match state with\n | None -> Some {PageState.Datatable.Empty with paginationState = Some newPagination; pushOnHistory= true}\n | Some s -> Some {s with paginationState = Some newPagination; pushOnHistory= true}\n )\n // Request the data and rows count, and collect possible error\n let dt_countViewWithoutSort = View.MapAsync2 (fun paginationState search -> async {\n return Server.InstancesDataTableJSON tableType id paginationState search\n })\n paginationState.View\n searchCriteria.View\n let dt_countView = View.MapAsync2 (fun f sort-> f sort)\n dt_countViewWithoutSort\n sortCriteria.View\n let dt = dt_countView |> View.MapCached (fun v -> match v with |Ok (data,_) -> JsonHelpers.deserialiseDataTable data\n | Error e -> JsonHelpers.deserialisedEmptyDataTable )\n let numberOfRows = dt_countView |> View.MapCached (fun v -> match v with | Ok (_,i) -> i\n | Error e -> 0L)\n let numberOfPages = View.Map2 (fun totalRows paginationState ->\n computeNumberOfPages totalRows paginationState.perPage) numberOfRows paginationState.View\n let dtError = dt_countView |> View.MapCached (fun v -> match v with |Ok _ -> None\n |Error e -> Some e)\n\n (dt,paginationState,numberOfRows,numberOfPages,dtError)\n\n // returns href value to download csv of current table rows\n let downloadCSVLink\n (tableType: TableType)\n (id:int)\n (paginationState:Var)\n (searchCriteria:Var)\n (sortCriteria:Var)=\n View.Map3 (fun paginationStateValue (searchCriteriaValue:SearchCriteria) sortCriteriaValue ->\n Routing.router.Link (GetTableCsv\n (tableType,\n id,\n paginationStateValue.currentPage,\n paginationStateValue.perPage,\n searchCriteriaValue.column,\n searchCriteriaValue.value,\n sortCriteriaValue.column,\n sortCriteriaValue.direction\n )))\n paginationState.View searchCriteria.View sortCriteria.View\n\n let getTHead(detailsResult:Result)(stateVar:Var) =\n let sortCriteria =\n let defaultSortCriteria = {column= None; direction= Asc}\n in\n stateVar.Lens\n (fun state ->\n match state with\n | None -> defaultSortCriteria\n | Some s ->\n match s.sortCriteria with\n | Some criteria -> criteria\n | _ -> defaultSortCriteria\n )\n (fun state newSortCriteria ->\n JavaScript.Console.Log($\"\"\"second lens function called with {sprintf \"%A\" state} and {sprintf \"%A\" newSortCriteria}\"\"\")\n match state with\n | None -> Some { PageState.Datatable.Empty with sortCriteria = Some newSortCriteria; pushOnHistory= true}\n | Some s -> Some {s with sortCriteria = Some newSortCriteria; pushOnHistory= true}\n )\n\n let sortColumn = sortCriteria.LensAuto (fun v -> v.column)\n let sortDirection = sortCriteria.LensAuto (fun v -> v.direction)\n\n let cssForColumn (column:string) =\n sortCriteria.View\n |> View.MapCached (fun {column = sortColumnOption ; direction = d} ->\n match sortColumnOption with\n | Some sortColumn when sortColumn=column -> d |> function |Asc -> \"desc\" |Desc -> \"asc\"\n | _ -> \"both\"\n )\n\n {| sortCriteria = sortCriteria\n markup = thead [] [\n detailsResult\n |> Result.map (List.map (fun d ->\n th []\n [ div [ (cssForColumn (d.name))\n |> View.MapCached (fun klass -> $\"th-inner sortable {klass}\")\n |> attr.classDyn\n UI.Html.on.click (fun el ev ->\n if sortCriteria.Value.column = Some d.name then\n // switch direction\n match sortCriteria.Value.direction with\n | Asc -> sortCriteria.Value <- {column=Some d.name; direction = Desc}\n | Desc -> sortCriteria.Value <- {column=Some d.name; direction = Asc}\n else\n sortCriteria.Value <- {column=Some d.name; direction = Asc}\n )\n ]\n [ text d.name ]\n ]\n ))\n |> ( function | Ok d -> d |> Doc.Concat\n | Error e -> Doc.Empty\n )\n ]\n |}\n\n // Returns a refresh button that will execute refreshFunction when clicked\n let refreshButton refreshFunction =\n span\n [\n on.click (fun ev el -> refreshFunction());\n classes [BS.``input-group-text``;\"myowndbrefreshtable\"]\n ]\n [\n li [attr.``class`` \"fas fa-sync page-item\"] []\n ]\n\n let getImportButton (entityId:int) =\n button\n [\n attr.title (t.t(\"Import CSV\"))\n on.click (fun _el _ev -> ClientRouting.installedRouter.Value <- Import entityId)\n classes [BS.btn;BS.``btn-primary``;\"myowndbimportcsv\"]\n ]\n [\n t.tt(\"Import CSV\")\n fontAwesomeIcon \"file-import\"\n ]\n\n let getNotificationsButton (entityId:int) = async {\n let! subscriptionsResult = Server.getInstanceNotifications entityId\n return\n match subscriptionsResult with\n | Error e-> dangerBox (text (e|>Error.toString))\n | Ok subscriptions ->\n let feedbackVar = Var.Create Doc.Empty\n let listModel = ListModel.Create (fun (s:Server.NotificationSubscriptionSpec) -> s.id) (subscriptions|> Seq.ofList)\n // Do not create text nodes here, as such a node can only be used once as a child (which we do here)\n let labelForThisEvent = t.t(\"For this event\")\n let labelNotifyBy = t.t(\"Notify by\")\n let labelRecipient = t.t(\"Recipient\")\n ////////////////////////////////\n // Existing Subscriptions list\n ///////////////////////////////\n let existingSubscriptionsTable =\n listModel.View\n |> View.MapCached (fun l ->\n table\n [classes [BS.table;BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``; \"myowndb-instance-subscriptions-list\"]]\n [\n thead\n []\n [\n th\n [Attr.Create \"scope\" \"col\"]\n [\n text labelForThisEvent\n ]\n th\n [Attr.Create \"scope\" \"col\"]\n [\n text labelNotifyBy\n ]\n th\n [Attr.Create \"scope\" \"col\"]\n [\n text labelRecipient\n ]\n ]\n l\n |> Seq.map (fun subs ->\n tr\n []\n [\n td [classes [ BS.``table-sm``]] [text (translateNotificationEvent subs.event)]\n td [classes [ BS.``table-sm``]] [text (translateNotificationProtocol subs.protocol)]\n td [classes [ BS.``table-sm``]] [text (sprintf \"%s\" subs.destination)]\n td\n [\n classes [ \"myowndbactioncell\" ]\n ]\n [(DeleteConfirmation.deleteConfirmation \"notification_subscription\" (fun () ->\n async {\n let! r = Server.deleteInstanceNotification subs.id\n match r with\n | Ok _ ->\n listModel.Remove subs\n return true\n | Error es ->\n feedbackVar.Set(dangerBox (es|> Error.toString |> text))\n return false\n }\n )).V]\n ]\n )\n |> Doc.Concat\n ]\n )\n ////////////////////////////////\n // New subscription form\n ///////////////////////////////\n let newSubscriptionForm =\n let eventVar = Var.Create (NotificationSubscriptionCriteria.Event.AfterCreate)\n let protocolVar = Var.Create (NotificationSubscriptionCriteria.Protocol.Smtp)\n div\n []\n [\n div\n [classes [ BS.container; \"myowndb-instance-subscription-form\"]]\n [\n div\n [classes [ BS.row] ]\n [\n div\n [classes [BS.col; BS.``col-lg-2``]]\n [\n text labelForThisEvent\n ]\n div\n [classes [BS.col; BS.``col-lg-2``]]\n [\n Doc.InputType.Select [attr.``id`` \"notification_event\"; classes [BS.``form-select``;BS.``form-select-sm``]] (translateNotificationEvent) [NotificationSubscriptionCriteria.Event.AfterCreate] eventVar\n ]\n ]\n div\n [classes [ BS.row] ]\n [\n div\n [classes [BS.col; BS.``col-lg-2``]]\n [\n text labelNotifyBy\n ]\n div\n [classes [BS.col; BS.``col-lg-2``]]\n [\n Doc.InputType.Select [attr.``id`` \"notification_protocol\"; classes [BS.``form-select``;BS.``form-select-sm``]] (translateNotificationProtocol) [NotificationSubscriptionCriteria.Protocol.Smtp] protocolVar\n ]\n ]\n div\n [classes [ BS.row; BS.``col-lg-2``] ]\n [\n button\n [\n classes [BS.btn; BS.``btn-primary``]\n on.click (fun _ev _el ->\n async {\n let! res = Server.createInstanceNotification entityId eventVar.Value protocolVar.Value\n match res with\n | Ok [s] ->\n feedbackVar.Set Doc.Empty\n listModel.Add s\n | Error es ->\n // The right text has been set server side\n feedbackVar.Set (dangerBox (es|> Error.toString |> text ))\n | Ok _ ->\n // This should never occur as only one subscription is created at a time\n feedbackVar.Set (dangerBox (t.tt(\"An error occurred\")))\n }\n |> Async.Start\n )\n ]\n [ t.tt(\"Save\")]\n ]\n\n ]\n\n ]\n span\n [ classes [\"myowndbmanagenotifications\"] ]\n [\n buttonRevealingContent\n {|\n buttonTextWhenVisible = t.tt \"Hide notifications\"\n buttonTextWhenHidden = t.tt \"Manage notifications\"\n |}\n (\n div\n [classes [BS.card; \"myowndb-instance-subscription-section\"]]\n [\n div [ classes [BS.``card-body``]]\n [\n feedbackVar.V\n (\n // Currently we only support one type of notification, so once there is a subscription in the list,\n // no new subscription can be created as it would be a duplicate, so we hide the form.\n // When there are more notifications, just put newSubscriptionForm here\n (listModel.View |> View.MapCached (fun l -> if Seq.length l > 0 then Doc.Empty else newSubscriptionForm)).V\n )\n existingSubscriptionsTable.V\n ]\n ]\n )\n ]\n }\n\n // *********************************\n // function displaying the datatable\n let displayValidListTable (tableType:TableType) (entityId:int) (detailsResult:Result,string>) (detailsError:Option) (actionsFunction:Map->(unit->unit)->Doc)(stateVar:Var): Async= async {\n\n // get the details list for the selection of the\n // searched column\n let initialSearchedColumn = detailsResult\n |> function\n | Ok ds -> ds |> List.map (fun d -> d.name) |> List.tryHead |> Option.defaultValue \"\"\n | Error _ -> \"\"\n // Search criteria Var\n let searchCriteria =\n let defaultValue = { column = initialSearchedColumn; value= \"\"}\n in\n stateVar.Lens\n (fun state ->\n match state with\n | None -> defaultValue\n | Some s ->\n match s.searchCriteria with\n | Some criteria -> criteria\n | _ -> defaultValue\n )\n (fun state newCriteria ->\n match state with\n | None -> Some {PageState.Datatable.Empty with searchCriteria = Some newCriteria; pushOnHistory= true}\n | Some s -> Some {s with searchCriteria = Some newCriteria; pushOnHistory= true}\n )\n // We use the searchCriteria Var as a gateway to a table refresh. The function queryDatabaseRows below takes as argument\n // this Var, and maps its view to generate the query of rows from the server. Triggering an update will request the new\n // data from the server.\n let refreshFunction() =\n searchCriteria.Update id\n\n // table head\n let headInfo = getTHead detailsResult stateVar\n let tableHead = headInfo.markup\n let sortCriteria = headInfo.sortCriteria\n\n // query database and get views of information to display\n let rows,paginationState,numberOfRows,numberOfPages,dataError = queryDatabaseRows tableType entityId searchCriteria sortCriteria stateVar\n\n\n // collect elements displayed before the table\n let navigationLinks = getNavigationLinks paginationState numberOfPages\n let perPageSelect = getPerPageSelect paginationState numberOfRows\n let searchFields = getSearchFields detailsResult paginationState searchCriteria\n let rowsCount = rowsCountIndicator numberOfRows\n\n // The csv link is only displayed for main tables, not for linked instance datatables,\n // because the generation of the link by websharper is incorrect when this parameter is set as a query parameter.\n // This is needed because our authorization code maps WS endpoints to ASP.Net endpoints. However, the Main and Linked\n // cases generate different numbers of path elements, which seems hard to replicate outside of WebSharper.\n // Putting it as a GET query parameter thus seems required.\n let csvLink =\n match tableType with\n |Main ->\n let csvUrlView = downloadCSVLink tableType entityId paginationState searchCriteria sortCriteria\n csvUrlView\n |> View.MapCached\n (fun url ->\n // We wrap the CSV link in a span as an easy fix for tests. Datatable tests compare html captured\n // at the time the tests were written to what is generated dureing the test. Not wrapping this in\n // a span breaks the check of number of navigation elements.\n // App code should not be influenced by tests, but bear with me here: it's much quicker this way\n // and not a big deal I think.\n span [] [\n ul [ classes [BS.pagination] ] [\n li [classes [BS.``page-item``] ] [\n a [attr.href url; classes [\"myowndb_csv_download_link\"; BS.``page-link``] ]\n [ text \"CSV\"; text \" \"; i [attr.``class`` \"fas fa-file-csv\"] []]\n ]\n ]\n ]\n )\n | Linked _ -> View.Const Doc.Empty\n | Linkable _ -> View.Const Doc.Empty\n\n // we build and return the table and accompanying widgets\n let doc =\n div [attr.id $\"table_{tableType.ToString()}_entity_{entityId}\"] [\n Doc.Element \"nav\" [Attr.Create \"aria-label\" \"data-table-pagination\"] [\n ul [attr.``class`` \"pagination pagination-sm\"] [\n navigationLinks\n |> List.map Doc.EmbedView\n |> (fun l -> List.append [rowsCount] l)\n |> (fun l -> List.append l [perPageSelect])\n |> (fun l -> List.append l searchFields)\n |> (fun l -> List.append l [ csvLink.V ] )\n |> (fun l -> List.append l [ refreshButton refreshFunction] )\n |> Doc.Concat\n ]\n ]\n\n // informational\n ((View.Const detailsError ), dataError)\n ||> View.Map2 (fun detailsErr dtErr ->\n match detailsErr, dtErr with\n |None, None ->\n table [classes [BS.table; BS.``table-bordered``; BS.``table-striped``; BS.``table-hover``; BS.``table-sm``]] [\n\n tableHead\n tbody [] [\n rows |> View.MapCached ( // get memoized evaluator generating the markup for the detail_value's data type\n // this avoids an evaluator instanciation for each value displayed\n let getEvaluator = DetailvalueFormater.memoizedEvaluatorGetter()\n // then map rows to tr markup\n Array.map (fun (r:Map) ->\n // each data row is mapped to a table row\n tr [] [\n // colums are take from the details list\n detailsResult\n // the item of the map corresponding to the column (d.name) is mapped to a td\n |> Result.map (List.map (fun d ->\n let value = r.Item (d.name)\n td [ classes [\"myowndbdatacell\"; BS.``table-sm``]]\n [ (DetailvalueFormater.displayDetailValue d value)]))\n // all tds need to be concatenated in one Doc\n |> Result.map Doc.Concat\n // finally extract the result\n |> function |Ok v -> v |Error e -> Doc.Empty\n // datacell are above, now add action cells\n actionsFunction r refreshFunction\n ]\n )\n\n // concatenate all rows in one doc\n >> Doc.Concat\n // Embed the View of all rows in the page\n ) |> Doc.EmbedView\n ]\n ]\n | Some e1 , _ -> text (e1)\n | _ , Some e2 -> text (e2)\n )\n |> Doc.EmbedView\n ]\n return\n {\n doc = doc\n refresh = refreshFunction\n numberOfRows = numberOfRows\n }\n }\n\n\n let displayListTable (tableType:TableType) (entityId:int) (actionsFunction:Map->(unit->unit)->Doc) (tableState:Var)= async {\n // request details, and collect the possible error\n let! detailsResult = Server.EntityDetails entityId true\n match detailsResult with\n // FIXME: translate strings\n // We return the Doc and a refreshFunction that can trigger a refresh of the datatable content\n | Ok [] ->\n return\n TableDocInfo.fromDoc\n (div [] [text \"empty details list\"])\n | Ok _ ->\n // FIXME: pass state\n let! tableDocInfo = displayValidListTable (tableType:TableType) (entityId:int) detailsResult None actionsFunction tableState\n return tableDocInfo\n | Error e ->\n return\n TableDocInfo.fromDoc\n (div [] [text \"details list error\"])\n }\n // This returns the refresh function in addition to the table itself\n let displayRefreshableListTable (tableType:TableType) (entityId:int) (actionsFunction:Map->(unit->unit)->Doc)(stateVar:Var)= async {\n // request details, and collect the possible error\n let! detailsResult = Server.EntityDetails entityId true\n match detailsResult with\n // FIXME: translate strings\n // We return the Doc and a refreshFunction that can trigger a refresh of the datatable content\n | Ok [] -> return TableDocInfo.fromDoc (div [] [text \"empty details list\"])\n | Ok _ -> return! displayValidListTable (tableType:TableType) (entityId:int) detailsResult None actionsFunction stateVar\n | Error e -> return TableDocInfo.fromDoc (div [] [text \"details list error\"])\n }\n\n // Function returning section above a datatable to add new instances.\n let addInstanceSection (entityId:int) (formKind:FormHelpers.FormKind) refreshFunction=\n let afterSaveCallback (formKind) (detailsSpecs)(instanceSpec)=\n refreshFunction()\n FormHelpers.displaySavedMessageCompact formKind detailsSpecs instanceSpec\n div\n [attr.id \"add_instance_section\"]\n [\n buttonRevealingContent\n {|\n buttonTextWhenVisible = t.tt \"Hide form\"\n buttonTextWhenHidden = t.tt \"Add new\"\n |}\n (\n div\n [classes [BS.card]]\n [\n div [ classes [BS.``card-body``]]\n [\n match formKind with\n | Creation -> InstanceForm.displayCreate entityId afterSaveCallback |> Doc.Async\n | Link _ -> InstanceForm.displayLink entityId formKind afterSaveCallback |> Doc.Async\n | _ -> Doc.Empty\n\n ]\n ]\n )\n // We display the import button only if the from above is a instance creation form. For a\n // linking form, we do not display the import button\n // Same for notification subscriptions button\n (\n match formKind with\n | FormHelpers.Creation ->\n [\n getImportButton entityId\n getNotificationsButton entityId |> Doc.Async\n ]\n |> Doc.Concat\n | FormHelpers.Link _ | FormHelpers.Edition | FormHelpers.Public -> Doc.Empty\n )\n ]\n\n let displayMainListTable (id:int) (pageInfo:PageInfo.Instances.PageInfo) (stateVar:Var)= async{\n\n let deleteElement (instanceId:string)(refreshFunction:unit->unit)=\n DeleteConfirmation.deleteConfirmation \"instance\" (\n (fun () -> async {\n match! (Server.deleteInstance (int instanceId)) with\n | Ok _ ->\n refreshFunction()\n // signal success\n return true\n | Error _ ->\n // signal failure\n return false\n })\n )\n let mainActionsFunction (r:Map) (refreshFunction:unit->unit) =\n [\n td [attr.``class`` \"myowndbactioncell\"]\n [ a [ attr.``data-`` \"myowndb-action\" \"view\"; attr.href (Routing.router.Link (Instance(int (r.Item \"id\"), None) ) )]\n [li [attr.``class`` \"fas fa-search\"] []]]\n td [attr.``class`` \"myowndbactioncell\"]\n [a [ attr.``data-`` \"myowndb-action\" \"edit\"; attr.href (Routing.router.Link (EditInstance(int (r.Item \"id\")) ) )]\n [li [attr.``class`` \"fas fa-edit\"] []]]\n td\n [attr.``class`` \"myowndbactioncell\"]\n [\n span\n [classes [ BS.``btn-link``] ]\n [(deleteElement (r.Item \"id\") refreshFunction).V]\n ]\n ]\n |> Doc.Concat\n let! tableDocInfo = displayRefreshableListTable Main id mainActionsFunction stateVar\n let additionSection = addInstanceSection id Creation tableDocInfo.refresh\n let content =\n div\n []\n [\n additionSection\n tableDocInfo.doc\n ]\n return content\n\n }\n", "namespace web\n\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Html\n// needed for UI.Html.attr.disableDynPred\nopen WebSharper.UI.Client\nopen HtmlHelpers\nopen Css\nopen ClientI18n\nopen WebSharper.UI.Templating\nopen WebSharper.JavaScript\n\ntype InstanceShowTemplate = Template<\"templates/instance/Show.html\">\n\n[]\nmodule InstanceDisplay =\n let t=JStr()\n\n let instanceField(key:string,value:Doc) =\n InstanceShowTemplate.Field()\n .Key(key)\n .Value(value)\n .Doc()\n\n let instanceMapToHtml (instanceId:int)(title:string) (details:list) (instance:Map) =\n let title = t.t(\"Record from table %1\",title)\n InstanceShowTemplate()\n .CardTitle(string title)\n .EditLink(Routing.router.Link (EndPoint.EditInstance instanceId))\n .Edit(t.t(\"Edit\"))\n .Fields(\n //// This code does not display fields with null values like rails version\n //instance\n //|> Map.filter (fun k v -> v<>null)\n //|> Map.toList\n //|> List.map instanceField\n // This code displays all fields, even those without value\n // I use this version now to possibly add inplace editing of all fields.\n details\n |> List.map (fun d -> match instance.TryGetValue(d.name) with\n | true, v -> d.name, (if isNull v then Doc.Empty else DetailvalueFormater.displayDetailValue d v)\n | _ -> d.name, Doc.Empty\n )\n |> List.map instanceField\n )\n .Doc()\n\n open LinkedInstancesTypes\n open DatatableTypes\n\n let displayLinkableInstances (tableType:DatatableTypes.TableType) (entityId:Ids.EntityId)(actionsFunction: Map->(unit->unit) -> Doc) (tableState:Var)= async {\n match tableType with\n | Main ->\n return TableDocInfo.fromDoc (div [] [text \"error\"])\n | Linked info\n | Linkable info ->\n let linkableTableType = Linkable info\n let! tableDocInfo = web.Datatable.displayListTable linkableTableType (entityId|> Ids.EntityId.Get) actionsFunction tableState\n return tableDocInfo\n }\n\n let displayLinkedInstances (dirAndId:RelatedInDirectionForIntInstanceId) (stateVar:Var) = async {\n let titleForRelation (dirAndId:RelatedInDirectionForIntInstanceId) (relation:Relation.Relation) =\n match dirAndId with\n | ChildrenFor sourceId -> relation.from_parent_to_child_name\n | ParentsFor sourceId -> relation.from_child_to_parent_name\n\n // Get relation ids from server\n let! relationsToLinkedResult =\n match dirAndId with\n | ChildrenFor sourceId -> Server.getChildrenRelations sourceId\n | ParentsFor sourceId -> Server.getParentsRelations sourceId\n\n let displayLinkedAndLinkableTables (relation_destination_type:int)(relationId:Ids.RelationId)(entityId:Ids.EntityId)(linked:TableDocInfo)(setupLinkable:unit -> Async) =\n // Initialise these vars outside the View.Map so that they aren't reinitialised each time the View.Map function is run.\n // Var indicating if the linkable list is visible\n let linkableVisible = Var.Create false\n // As initially we don't retrieve the linkable instances table from the server, we store None in this Var.\n // When it is retrieved, it is set to Some, and won't change after that.\n let linkableTableDocInfoOption:Var> = Var.Create None\n linked.numberOfRows\n |> View.Map (fun numberOfLinkedInstances ->\n if numberOfLinkedInstances = 1 && relation_destination_type = 1 then\n linked.doc\n else\n let linkableVisibilityClass =\n linkableVisible.View\n |> View.Map\n (fun isVisible ->\n if isVisible then\n String.concat \" \" [BS.``d-block``; BS.card; BS.``w-75``]\n else\n String.concat \" \" [BS.``d-none``; BS.card]\n )\n let buttonText =\n linkableVisible.View\n |> View.Map (fun visible->\n if visible then\n t.tt \"Finish linking existing entry\"\n else\n t.tt \"Link existing entry\"\n\n )\n // View to insert in the DOM according to the linkableTableDocInfoOption content\n let linkableDocView =\n linkableTableDocInfoOption.View\n |> View.Map(\n function\n | None -> Doc.Empty\n | Some i -> i.doc\n )\n // A view combining both visibility and retrieved status\n let isVisibleIsRetrieved =\n View.Map2 (fun visible (doc:Option) -> (visible,doc.IsSome))\n linkableVisible.View\n linkableTableDocInfoOption.View\n //Function that will be called by a click on the button\n let displayLinkableTable (visible,retrieved) = async {\n match visible,retrieved with\n // If visible, just hide it. It must have been retrieved at that point.\n | true, _ ->\n linkableVisible.Set (not visible)\n // if it was alredy retrieved (by a previous click on the button), just make it visible again after refreshing it\n | false, true ->\n // Refresh the linkable table to be sure it is up to date\n linkableTableDocInfoOption.Value |> Option.iter (fun i -> i.refresh())\n // Make it visible\n linkableVisible.Set (not visible)\n | false, false ->\n // Call the thunk we got to setup the linkable table, we get a TableDocInfo value\n let! linkable = setupLinkable()\n // Update the Vars accordingly\n linkableTableDocInfoOption.Set (Some linkable)\n linkableVisible.Set (not visible)\n }\n\n let additionSection = Datatable.addInstanceSection (entityId|>Ids.EntityId.Get) (FormHelpers.Link {relationId=relationId|>Ids.RelationId.Get; dirAndId=dirAndId}) linked.refresh\n\n div []\n [\n button\n [\n classes [BS.btn; BS.``btn-primary``; BS.``m-2``]\n on.clickView isVisibleIsRetrieved (fun _ev _el isVisibleIsRetrieved-> (displayLinkableTable isVisibleIsRetrieved)|> Async.StartImmediate )\n ]\n [ buttonText.V\n ]\n additionSection\n div [attr.classDyn linkableVisibilityClass ]\n [\n div [ classes [BS.``card-body``; BS.``d-flex``; BS.``justify-content-center``]]\n [\n linkableDocView.V\n ]\n ]\n linked.doc\n ]\n )\n\n // for each relation display a div with the list of linked instances\n return\n relationsToLinkedResult\n |> DBResult.map (fun (relation,tableType) ->\n // We create Vars to store the refresh function of each table because each table calls the refresh of the other and\n // assigning both with a let is not possible I think (let .. and is not available because it is async, so needs `let!`)\n let linkedRefreshFunction = Var.Create (fun () -> ())\n let linkableRefreshFunction = Var.Create (fun () -> ())\n // Id used to assign a CSS id to the card, and as a key in the page state map\n let tableId = tableType.ToString()\n // We define a Var holding this table state by lensing into the page state's map.\n // This Var will be updated everytime the page state is modified. This means that\n // everytime another table on the page changes state, all tables of the page have their\n // rawTableState updated.\n // To avoid this, we define another Var that will only be updated when the rawTableState\n // gets a different value.\n let rawTableState =\n stateVar.Lens\n (fun s ->\n match s with\n | None -> None\n | Some state ->\n state.map.TryFind tableId\n )\n (fun s newTableState ->\n match s with\n | None ->\n let initState = PageState.InstanceDisplay.Empty\n Some { initState with map = Map.add tableId (newTableState|>Option.defaultValue PageState.Datatable.Empty) initState.map }\n | Some state ->\n Some { state with map = Map.add tableId (newTableState|>Option.defaultValue PageState.Datatable.Empty) state.map}\n )\n\n // Define that table state actually passed down to the datatable functions.\n let tableState:Var = (Var.Create (rawTableState.Value))\n // Run a sink to update the tableState when a *different* value is set in the page state.\n // This is how we avoid to have an redisplay if our state didn't change.\n rawTableState.View\n |> View.Sink (fun newTableState ->\n if tableState.Value <> newTableState then\n tableState.Set newTableState\n )\n // Run a sink to update the rawTableState as this is used to update the page state that is reflected in the URL.\n // Without this sink, the page state in the URL would never be updated.\n tableState.View\n |> View.Sink (fun newTableState ->\n if rawTableState.Value <> newTableState then\n rawTableState.Set newTableState\n )\n // FIXME: we get the int from the entity id only to again build the EntityId inside the function call\n let table =\n match dirAndId with\n // Both branches of the match have very similar code, but differing each time on the argument being the parent of the child id.\n // It seems more approachable to leave it like this rather than refactor to remove repetition at the prive of making it more\n // complex to understand.\n |ChildrenFor parentId ->\n\n\n // Function called on click of the link icon in the linkable instances list\n // It takes as only argument the childId, which will be specific for each row, and passed to the call of this\n // function by the click handler, which has access to the row's values map from which the childId will be extracted.\n let linkableLinkAction childId= async {\n let! linkIdResult = Server.linkInstances relation.id parentId childId\n match linkIdResult with\n | Ok _ ->\n // This is a call to the function stored in the Var, not a call to Value() method!\n linkedRefreshFunction.Value()\n linkableRefreshFunction.Value()\n | Error es -> JavaScript.Console.Log($\"Failed linking instances:{es|> Error.toString}\")\n }\n let linkedUnlinkAction childId= async {\n let! linkIdResult = Server.unlinkInstances relation.id parentId childId\n match linkIdResult with\n | Ok _ ->\n // This is a call to the function stored in the Var, not a call to Value() method!\n linkedRefreshFunction.Value()\n linkableRefreshFunction.Value()\n | Error es -> JavaScript.Console.Log($\"Failed unlinking instances:{es|> Error.toString}\")\n }\n // Function that returns the action cell to unlink an instances. It is thus used in the linked instances table\n let linkedActionsFunction (r:Map) (refreshFunction:unit->unit) =\n [\n td [attr.``class`` \"myowndbactioncell\"]\n [ a [ attr.``data-`` \"myowndb-action\" \"view\"; attr.href (Routing.router.Link (Instance(int (r.Item \"id\"),None) ) )]\n [li [attr.``class`` \"fas fa-search\"] []]]\n\n td [attr.``class`` \"myowndbactioncell\"; on.click (fun _el ev -> ev.PreventDefault(); linkedUnlinkAction (int (r.Item \"id\")) |> Async.StartImmediate )]\n [\n a\n [attr.``data-`` \"myowndb-action\" \"unlink\"; attr.href \"#\";]\n [li [attr.``class`` \"fas fa-unlink\"] []]\n ]\n ]\n |> Doc.Concat\n // Function that returns the action cell to link an instances. It is thus used in the linkable instances table\n let linkableActionsFunction (r:Map) (refreshFunction:unit->unit)=\n [\n td [attr.``class`` \"myowndbactioncell\"]\n [ a [ attr.``data-`` \"myowndb-action\" \"view\"; attr.href (Routing.router.Link (Instance(int (r.Item \"id\"),None) ) )]\n [li [attr.``class`` \"fas fa-search\"] []]]\n\n td [attr.``class`` \"myowndbactioncell\"; on.click (fun el ev ->ev.PreventDefault(); linkableLinkAction (int (r.Item \"id\")) |> Async.StartImmediate)]\n [\n a\n [attr.``data-`` \"myowndb-action\" \"link\"; attr.href \"#\";]\n [\n li [attr.``class`` \"fas fa-link\"] []\n ]\n ]\n ]\n |> Doc.Concat\n\n async {\n // Get the entityId of the instances linked through this relation\n let entityId = (Ids.EntityId.Get relation.child_id)\n // Get the tableInfo for linked instances and set its refresh function in the right var\n let! linkedTableInfo = web.Datatable.displayListTable tableType entityId linkedActionsFunction tableState\n linkedRefreshFunction.Set linkedTableInfo.refresh\n // Get the tableInfo for linkable instances and set its refresh function in the right var\n let setupLinkable() = async {\n let! linkableTableInfo = displayLinkableInstances tableType relation.child_id linkableActionsFunction tableState\n linkableRefreshFunction.Set linkableTableInfo.refresh\n return linkableTableInfo\n }\n // return the doc\n return displayLinkedAndLinkableTables relation.child_side_type_id relation.id relation.child_id linkedTableInfo setupLinkable |> Doc.EmbedView\n } |> Doc.Async\n |ParentsFor childId ->\n // Function called on click of the link icon in the linkable instances list\n // It takes as only argument the parentId, which will be specific for each row, and passed to the call of this\n // function by the click handler, which has access to the row's values map from which the childId will be extracted.\n let linkableLinkAction parentId= async {\n let! linkIdResult = Server.linkInstances relation.id parentId childId\n match linkIdResult with\n | Ok _ ->\n // This is a call to the function stored in the Var, not a call to Value() method!\n linkedRefreshFunction.Value()\n linkableRefreshFunction.Value()\n | Error es -> JavaScript.Console.Log($\"Failed linking instances:{es|> Error.toString}\")\n }\n let linkedUnlinkAction parentId= async {\n let! linkIdResult = Server.unlinkInstances relation.id parentId childId\n match linkIdResult with\n | Ok _ ->\n // This is a call to the function stored in the Var, not a call to Value() method!\n linkedRefreshFunction.Value()\n linkableRefreshFunction.Value()\n | Error es -> JavaScript.Console.Log($\"Failed unlinking instances:{es|> Error.toString}\")\n }\n // Function that returns the action cell to unlink an instances. It is thus used in the linked instances table\n let linkedActionsFunction (r:Map) (refreshFunction:unit->unit) =\n [\n td [attr.``class`` \"myowndbactioncell\"]\n [ a [ attr.href (Routing.router.Link (Instance(int (r.Item \"id\"),None) ) )]\n [li [attr.``class`` \"fas fa-search\"] []]]\n\n td [attr.``class`` \"myowndbactioncell\"; on.click (fun _el ev -> ev.PreventDefault(); linkedUnlinkAction (int (r.Item \"id\")) |> Async.StartImmediate )]\n [\n a\n [attr.``data-`` \"myowndb-action\" \"unlink\"; attr.href \"#\";]\n [li [attr.``class`` \"fas fa-unlink\"] []]\n ]\n ] |> Doc.Concat\n\n // Function that returns the action cell to link an instances. It is thus used in the linkable instances table\n let linkableActionsFunction (r:Map) (refreshFunction:unit->unit) =\n [\n td [attr.``class`` \"myowndbactioncell\"]\n [ a [ attr.href (Routing.router.Link (Instance(int (r.Item \"id\"),None) ) )]\n [li [attr.``class`` \"fas fa-search\"] []]]\n\n td [attr.``class`` \"myowndbactioncell\"; on.click (fun el ev ->ev.PreventDefault(); linkableLinkAction (int (r.Item \"id\")) |> Async.StartImmediate)]\n [\n a\n [attr.``data-`` \"myowndb-action\" \"link\"; attr.href \"#\"]\n [li [attr.``class`` \"fas fa-link\"] []]\n ]\n ]\n |> Doc.Concat\n\n async {\n // Get the entityId of the instances linked through this relation\n let entityId = (Ids.EntityId.Get relation.parent_id)\n // Get the tableInfo for linked instances and set its refresh function in the right var\n let! linkedTableInfo = web.Datatable.displayListTable tableType entityId linkedActionsFunction tableState\n linkedRefreshFunction.Set linkedTableInfo.refresh\n // Get the tableInfo for linkable instances and set its refresh function in the right var\n let setupLinkable () =async {\n let! linkableTableInfo = displayLinkableInstances tableType relation.parent_id linkableActionsFunction tableState\n linkableRefreshFunction.Set linkableTableInfo.refresh\n return linkableTableInfo\n }\n return displayLinkedAndLinkableTables relation.parent_side_type_id relation.id relation.parent_id linkedTableInfo setupLinkable |> Doc.EmbedView\n }|>Doc.Async\n wrapInCard $\"card_{tableId}\" (titleForRelation dirAndId relation) table\n )\n |> (function\n | DBResult.DBResult.Ok docList ->\n docList\n | DBResult.DBResult.Error e ->\n // FIXME: report error\n [ div [] [text \"error\"]]\n )\n\n }\n let displayInstance id (pageInfo:PageInfo.Instance.PageInfo) (stateVar:Var)= async {\n try\n let! detailsResult = Server.InstanceDetails id\n let! dtResult = Server.getInstanceDatatable id\n let! children = displayLinkedInstances (ChildrenFor id) stateVar\n let! parents = displayLinkedInstances (ParentsFor id) stateVar\n\n match detailsResult,dtResult with\n |Ok details,Some data ->\n return JsonHelpers.deserialiseDataTable data\n |> Array.head\n // parents.[1] causes trouble, I don't know why\n |> instanceMapToHtml id pageInfo.entity.name details\n |> (fun body ->\n div []\n (parents\n |> List.append children\n |> List.append [ h1 [] [t.tt(\"Related Records\")]]\n |> List.append [body]))\n |_,_ -> return div [] [ t.tt(\"Instance could not be retrieved.\") ]\n with\n | e -> return div [] [text e.Message]\n }\n", "namespace web\n\nopen WebSharper\nopen WebSharper.UI\nopen WebSharper.UI.Html\n// needed for *DynPred attributes\nopen WebSharper.UI.Client\nopen HtmlHelpers\nopen Css\n\nopen ClientI18n\n\n[]\nmodule ImportPage =\n\n\n type ImportStep =\n |Init\n |Uploaded of Ids.ImportId * Specs.DetailSpec list * string array\n |Imported of DBResult.DBResult>>*Ids.ImportId\n |Undone of int\n let t=JStr()\n\n let step = Var.Create Init\n\n // Step 1: upload form\n // *******************\n let uploadForm (entityIdInt:int) =\n let fileVar:Var = Var.Create [||]\n let textVar:Var = Var.Create \"\"\n let resultMessage = Var.Create \"\"\n\n div [] [\n Client.Doc.InputType.Text [] textVar\n Client.Doc.InputType.File [classes [\"myowndbfileselection\"]] fileVar\n button\n [ on.click (fun el ev ->\n let f = fileVar.Get()[0]\n async {\n let! buffer = f.ArrayBuffer() |>WebSharper.JavaScript.Promise.AsAsync\n // Get a Uint8Array from ArrayBuffer\n let q = WebSharper.JavaScript.Uint8Array(buffer)\n // Get the bytes for each Uint8Array element\n // This gives us a byte array we can send to the server side\n let d = [| for i in 1..q.Length do q.Get(i-1) |]\n try\n match! Server.handleImportUpload entityIdInt (f.Name) d with\n | Ok [importId,detailsSpecs,columns] ->\n step.Set (Uploaded (importId,detailsSpecs,columns))\n |Ok _\n |DBResult.DBResult.Error _ ->\n resultMessage.Set (t.t(\"An error occurred\"))\n with\n | _e -> resultMessage.Set (t.t(\"An error occurred in the upload\"))\n\n return ()\n } |> Async.StartImmediate\n )\n classes [BS.btn; BS.``btn-primary``;\"myowndbuploadfile\"]\n ]\n [t.tt(\"Submit\")]\n div [] [text resultMessage.V]\n ]\n\n // Step 2: map csv columns to details\n // **********************************\n let mappingsForm (importId:Ids.ImportId)(columns:string array)(detailsSpecs:Specs.DetailSpec list) =\n let resultMessage = Var.Create \"\"\n // build form element for each csv column\n let choices =\n detailsSpecs\n // We cannot import a file attachment from a csv\n |> List.filter (fun spec -> spec.dataType.className <> \"FileAttachmentDetailValue\")\n |> List.map (fun spec ->\n // If a column is found with the same name as the detail, use it as pre-filled mapping\n let defaultMapping =\n columns\n |> Array.tryFind (fun col -> col = spec.name)\n // The Var holding the user's choice of mapping for column col\n let choice:Var> =\n Var.Create defaultMapping\n // The