From 647a9ebc98fb3da1276ff338f427256706d59132 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Mon, 22 Jun 2026 17:17:18 +0200 Subject: [PATCH] fix(developer): prevent clone of legacy keyboards with no source If a Keyman Cloud keyboard is legacy and has no source available, make this more obvious to the author when they attempt to clone it. Add also messages to help the author complete the other required steps to clone a keyboard. Fixes: #15606 Test-bot: skip --- .../delphi/general/Upload_Settings.pas | 9 + ....UfrmCloneKeymanCloudProjectParameters.dfm | 246 +++++++++--------- ....UfrmCloneKeymanCloudProjectParameters.pas | 134 +++++++++- 3 files changed, 269 insertions(+), 120 deletions(-) diff --git a/common/windows/delphi/general/Upload_Settings.pas b/common/windows/delphi/general/Upload_Settings.pas index 8811ec6f10..2763a042be 100644 --- a/common/windows/delphi/general/Upload_Settings.pas +++ b/common/windows/delphi/general/Upload_Settings.pas @@ -86,6 +86,8 @@ function API_UserAgent: string; // = 'Keyman for Windows/...' function API_UserAgent_Developer: string; // = 'Keyman Developer/...' function API_UserAgent_Diagnostics: string; +function API_Path_Keyboard(const id: string): string; + function KeymanCom_Protocol_Server: string; // = 'https://keyman.com'; function MakeAPIURL(path: string): string; @@ -121,6 +123,8 @@ const S_KeymanCom_Staging = 'https://keyman.com'; // #7227 disabling: 'https://keyman-staging.com'; S_APIServer_Staging = 'api.keyman.com'; // #7227 disabling: 'api.keyman-staging.com'; + S_API_Path_Keyboard = '/keyboard/%0:s'; + const URLPath_PackageDownload_Format = '/go/package/download/%0:s?platform=windows&tier=%1:s&bcp47=%2:s&update=%3:d'; URL_KeymanDeveloper_HelpKmcMessage_Format = S_Host_KmnSh+'/%0:s'; @@ -187,4 +191,9 @@ begin Result := Format(URL_KeymanDeveloper_HelpKmcMessage_Format, [id.ToLower]); end; +function API_Path_Keyboard(const id: string): string; +begin + Result := Format(S_API_Path_Keyboard, [id]); +end; + end. diff --git a/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.dfm b/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.dfm index fb286bccc3..e06066a2e1 100644 --- a/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.dfm +++ b/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.dfm @@ -1,119 +1,127 @@ -inherited frmCloneKeymanCloudProjectParameters: TfrmCloneKeymanCloudProjectParameters - BorderIcons = [biSystemMenu, biMaximize] - Caption = 'Clone Project from Keyman Cloud' - ClientHeight = 506 - ClientWidth = 840 - Position = poScreenCenter - ExplicitWidth = 856 - ExplicitHeight = 545 - PixelsPerInch = 96 - TextHeight = 13 - object cmdOK: TButton - Left = 680 - Top = 473 - Width = 73 - Height = 25 - Anchors = [akRight, akBottom] - Caption = 'OK' - Default = True - TabOrder = 2 - OnClick = cmdOKClick - end - object cmdCancel: TButton - Left = 759 - Top = 473 - Width = 73 - Height = 25 - Anchors = [akRight, akBottom] - Cancel = True - Caption = 'Cancel' - ModalResult = 2 - TabOrder = 3 - end - object panWebHost: TPanel - Left = 0 - Top = 0 - Width = 842 - Height = 334 - Anchors = [akLeft, akTop, akRight, akBottom] - BevelOuter = bvNone - TabOrder = 0 - end - object gbNewProjectDetails: TGroupBox - Left = 8 - Top = 340 - Width = 823 - Height = 129 - Anchors = [akLeft, akRight, akBottom] - Caption = 'New Project Details' - TabOrder = 1 - object lblFileName: TLabel - Left = 16 - Top = 24 - Width = 76 - Height = 13 - Caption = '&New project ID:' - FocusControl = editKeyboardID - end - object lblProjectFilename: TLabel - Left = 16 - Top = 102 - Width = 101 - Height = 13 - Caption = 'New project &filename' - FocusControl = editProjectFilename - end - object lblPath: TLabel - Left = 16 - Top = 75 - Width = 83 - Height = 13 - Caption = 'Destination &path:' - FocusControl = editPath - end - object editKeyboardID: TEdit - Left = 148 - Top = 21 - Width = 205 - Height = 21 - TabOrder = 0 - OnChange = editKeyboardIDChange - end - object editProjectFilename: TEdit - Left = 148 - Top = 99 - Width = 669 - Height = 21 - TabStop = False - ParentColor = True - ReadOnly = True - TabOrder = 4 - OnChange = editKeyboardIDChange - end - object cmdBrowse: TButton - Left = 744 - Top = 72 - Width = 73 - Height = 21 - Caption = '&Browse...' - TabOrder = 3 - OnClick = cmdBrowseClick - end - object editPath: TEdit - Left = 148 - Top = 72 - Width = 590 - Height = 21 - TabOrder = 2 - OnChange = editPathChange - end - object chkRelocateExternal: TCheckBox - Left = 148 - Top = 48 - Width = 257 - Height = 17 - Caption = 'Relocate &external files into new project folder' - TabOrder = 1 - end - end -end +inherited frmCloneKeymanCloudProjectParameters: TfrmCloneKeymanCloudProjectParameters + BorderIcons = [biSystemMenu, biMaximize] + Caption = 'Clone Project from Keyman Cloud' + ClientHeight = 506 + ClientWidth = 840 + Position = poScreenCenter + ExplicitWidth = 856 + ExplicitHeight = 545 + PixelsPerInch = 96 + TextHeight = 13 + object lblMessage: TLabel + Left = 8 + Top = 478 + Width = 314 + Height = 13 + Caption = 'The keyboard %0:s has no source available. It cannot be cloned.' + FocusControl = editPath + end + object cmdOK: TButton + Left = 680 + Top = 473 + Width = 73 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'OK' + Default = True + TabOrder = 2 + OnClick = cmdOKClick + end + object cmdCancel: TButton + Left = 759 + Top = 473 + Width = 73 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 3 + end + object panWebHost: TPanel + Left = 0 + Top = 0 + Width = 842 + Height = 334 + Anchors = [akLeft, akTop, akRight, akBottom] + BevelOuter = bvNone + TabOrder = 0 + end + object gbNewProjectDetails: TGroupBox + Left = 8 + Top = 340 + Width = 823 + Height = 129 + Anchors = [akLeft, akRight, akBottom] + Caption = 'New Project Details' + TabOrder = 1 + object lblFileName: TLabel + Left = 16 + Top = 24 + Width = 76 + Height = 13 + Caption = '&New project ID:' + FocusControl = editKeyboardID + end + object lblProjectFilename: TLabel + Left = 16 + Top = 102 + Width = 101 + Height = 13 + Caption = 'New project &filename' + FocusControl = editProjectFilename + end + object lblPath: TLabel + Left = 16 + Top = 75 + Width = 83 + Height = 13 + Caption = 'Destination &path:' + FocusControl = editPath + end + object editKeyboardID: TEdit + Left = 148 + Top = 21 + Width = 205 + Height = 21 + TabOrder = 0 + OnChange = editKeyboardIDChange + end + object editProjectFilename: TEdit + Left = 148 + Top = 99 + Width = 669 + Height = 21 + TabStop = False + ParentColor = True + ReadOnly = True + TabOrder = 4 + OnChange = editKeyboardIDChange + end + object cmdBrowse: TButton + Left = 744 + Top = 72 + Width = 73 + Height = 21 + Caption = '&Browse...' + TabOrder = 3 + OnClick = cmdBrowseClick + end + object editPath: TEdit + Left = 148 + Top = 72 + Width = 590 + Height = 21 + TabOrder = 2 + OnChange = editPathChange + end + object chkRelocateExternal: TCheckBox + Left = 148 + Top = 48 + Width = 257 + Height = 17 + Caption = 'Relocate &external files into new project folder' + TabOrder = 1 + end + end +end diff --git a/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.pas b/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.pas index c3f09a6406..36014446b0 100644 --- a/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.pas +++ b/developer/src/tike/project/Keyman.Developer.UI.Project.UfrmCloneKeymanCloudProjectParameters.pas @@ -46,6 +46,7 @@ type cmdBrowse: TButton; editPath: TEdit; chkRelocateExternal: TCheckBox; + lblMessage: TLabel; procedure cmdOKClick(Sender: TObject); procedure editSourceProjectFilenameChange(Sender: TObject); procedure FormCreate(Sender: TObject); @@ -57,6 +58,7 @@ type cef: TframeCEFHost; dlgBrowse: TBrowse4Folder; FKeymanID: string; + FSourceAvailable: Boolean; frmDownloadProgress: TfrmDownloadProgress; function GetBasePath: string; function GetKeyboardID: string; @@ -64,6 +66,7 @@ type procedure EnableControls; procedure SetKeyboardID(const Value: string); procedure UpdateProjectFilename; + procedure UpdateMessage; function GetProjectFilename: string; function GetSourceProjectFilename: string; function GetRelocateExternal: Boolean; @@ -71,6 +74,7 @@ type procedure cefLoadEnd(Sender: TObject); procedure DownloadCallback(Owner: TfrmDownloadProgress; var Result: Boolean); procedure DownloadWrapperCallback(var Cancelled: Boolean); + function IsKeyboardSourceAvailable(const id: string): Boolean; protected function GetHelpTopic: string; override; public @@ -86,9 +90,11 @@ function ShowCloneKeymanCloudProjectParameters(Owner: TComponent): Boolean; implementation uses + System.JSON, System.Net.UrlClient, Vcl.ComCtrls, + HttpUploader, KeymanDeveloperOptions, Keyman.Developer.System.KmcWrapper, Keyman.Developer.System.HelpTopics, @@ -182,6 +188,7 @@ begin dlgBrowse.Root := Desktop; dlgBrowse.Title := 'Select folder to save project to'; + UpdateMessage; EnableControls; end; @@ -201,9 +208,97 @@ begin not u.Path.StartsWith(URLSubPath_KeymanDeveloper_Clone_Keyboards_Custom) then FKeymanID := u.Path.Substring(URLSubPath_KeymanDeveloper_Clone_Keyboards.Length) else FKeymanID := ''; + + FSourceAvailable := IsKeyboardSourceAvailable(FKeymanID); + UpdateMessage; EnableControls; end; +function TfrmCloneKeymanCloudProjectParameters.IsKeyboardSourceAvailable(const id: string): Boolean; + + function GetKeyboardDataFromApiServer(const id: string): string; + var + http: THTTPUploader; + begin + http := THTTPUploader.Create(nil); + try + http.Request.HostName := API_Server; + http.Request.Protocol := API_Protocol; + http.Request.UrlPath := API_Path_Keyboard(id); + try + http.Upload; + except + // Silently swallow network errors + on E:Exception do Exit(''); + end; + + if (http.Response.StatusCode < 200) or (http.Response.StatusCode > 299) then + begin + // Keyboard not found or invalid response + Exit(''); + end; + + Result := UTF8ToString(PAnsiChar(http.Response.MessageBodyAsString)); + finally + FreeAndNil(http); + end; + end; + + function GetSourcePathFromBody(const body: string): string; + var + val: TJSONValue; + obj: TJSONObject; + begin + try + val := TJSONObject.ParseJSONValue(body); + except + // Not a valid response + Exit(''); + end; + + if not (val is TJSONObject) then + begin + // Not a valid response + Exit(''); + end; + + obj := val as TJSONObject; + val := obj.Values['sourcePath']; + if not Assigned(val) or not (val is TJSONString) then + begin + // no sourcePath property + Exit(''); + end; + + Result := (val as TJSONString).Value; + end; + +var + body, sourcePath: string; +begin + if id = '' then + begin + Exit(False); + end; + + body := GetKeyboardDataFromApiServer(id); + if body = '' then + begin + Exit(False); + end; + + sourcePath := GetSourcePathFromBody(body); + if sourcePath = '' then + begin + Exit(False); + end; + + // Keyboards in legacy/ do not have source available. Keyboards in + // release/ and experimental/ have source, and other new categories will + // also have source in future. + Result := not sourcePath.startsWith('legacy'); +end; + procedure TfrmCloneKeymanCloudProjectParameters.cmdBrowseClick(Sender: TObject); begin dlgBrowse.InitialDir := editPath.Text; @@ -221,22 +316,26 @@ end; procedure TfrmCloneKeymanCloudProjectParameters.editKeyboardIDChange(Sender: TObject); begin UpdateProjectFilename; + UpdateMessage; EnableControls; end; procedure TfrmCloneKeymanCloudProjectParameters.editSourceProjectFilenameChange(Sender: TObject); begin + UpdateMessage; EnableControls; end; procedure TfrmCloneKeymanCloudProjectParameters.editPathChange(Sender: TObject); begin UpdateProjectFilename; + UpdateMessage; EnableControls; end; procedure TfrmCloneKeymanCloudProjectParameters.editVersionChange(Sender: TObject); begin + UpdateMessage; EnableControls; end; @@ -248,7 +347,8 @@ begin (FKeymanID <> '') and (Trim(editPath.Text) <> '') and (Trim(editKeyboardID.Text) <> '') and - TKeyboardUtils.IsValidKeyboardID(Trim(editKeyboardID.Text), True); + TKeyboardUtils.IsValidKeyboardID(Trim(editKeyboardID.Text), True) and + FSourceAvailable; cmdOK.Enabled := e; end; @@ -292,9 +392,41 @@ end; procedure TfrmCloneKeymanCloudProjectParameters.SetKeyboardID(const Value: string); begin editKeyboardID.Text := Value; + UpdateMessage; EnableControls; end; +procedure TfrmCloneKeymanCloudProjectParameters.UpdateMessage; +var + msg: string; +begin + if FKeymanID = '' then + begin + msg := 'Please choose a keyboard from the search form above.'; + end + else if not FSourceAvailable then + begin + msg := Format('The keyboard %0:s has no source available. It cannot be cloned.', [FKeymanID]); + end + else if Trim(editPath.Text) = '' then + begin + msg := 'A valid destination path must be selected.'; + end + else if Trim(editKeyboardID.Text) = '' then + begin + msg := 'Please enter a valid new project identifier.'; + end + else if not TKeyboardUtils.IsValidKeyboardID(Trim(editKeyboardID.Text), True) then + begin + msg := 'Please enter a valid new project identifier.'; + end + else + begin + msg := ''; + end; + lblMessage.Caption := msg; +end; + procedure TfrmCloneKeymanCloudProjectParameters.UpdateProjectFilename; begin editProjectFilename.Text :=