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
2026-08-05 00:15:32 +00:00 · 2026-06-22 17:17:18 +02:00 · 2026-06-22 17:17:18 +02:00 · 647a9ebc98
commit 647a9ebc98
parent 58a565be21
3 changed files with 269 additions and 120 deletions
--- 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/<ver>...'
 function API_UserAgent_Developer: string; // = 'Keyman Developer/<ver>...'
 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.
--- 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
--- 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 :=