Synapse/cli/lib/doctor.ml

type opts = { dev_script : bool }
type parsed = Parsed_doctor of opts
type action = Doctor of { script_path : Cli_primitive.path option }
type check_status = Ok | Warning | Error

type check = {
  id : Cli_primitive.keyword;
  status : check_status;
  code : Error.code option;
  message : string;
  path : Cli_primitive.path option;
  servers : Melange_edn_melange.any Rrbvec.t;
  raw : Melange_edn_melange.any option;
}

type report = { status : check_status; checks : check Rrbvec.t }

let command_id _ = Command_id.Doctor
let validate_parsed _ = Stdlib.Ok ()

let status_value = function
  | Ok -> Edn_util.keyword "ok"
  | Warning -> Edn_util.keyword "warning"
  | Error -> Edn_util.keyword "error"

let check_value (check : check) =
  let fields =
    Vec.of_array
      [|
        (Edn_util.keyword "id", Edn_util.any check.id);
        (Edn_util.keyword "status", status_value check.status);
        (Edn_util.keyword "message", Edn_util.string check.message);
      |]
  in
  let fields =
    match check.code with
    | Some code ->
        Vec.push_back fields
          (Edn_util.keyword "code", Edn_util.any (Error.code_to_keyword code))
    | None -> fields
  in
  let fields =
    match check.path with
    | Some path ->
        Vec.push_back fields (Edn_util.keyword "path", Edn_util.string path)
    | None -> fields
  in
  let fields =
    if Vec.is_empty check.servers then fields
    else
      Vec.push_back fields
        (Edn_util.keyword "servers", Edn_util.vector_vec check.servers)
  in
  let fields =
    match check.raw with
    | Some raw -> Vec.push_back fields (Edn_util.keyword "raw", raw)
    | None -> fields
  in
  Edn_util.map_vec fields

let check_db_worker_script (Doctor { script_path }) =
  let path =
    Option.value script_path
      ~default:(Server_runtime.db_worker_runtime_script_path ())
  in
  if not (Cli_unix.file_exists path) then
    {
      id = Edn_util.keyword_t "db-worker-script";
      status = Error;
      code = Some Error.Doctor_script_missing;
      message = "db-worker script is missing: " ^ path;
      path = Some path;
      servers = Vec.empty;
      raw = None;
    }
  else if Cli_unix.is_directory path then
    {
      id = Edn_util.keyword_t "db-worker-script";
      status = Error;
      code = Some Error.Doctor_script_unreadable;
      message = "db-worker script path is not a file: " ^ path;
      path = Some path;
      servers = Vec.empty;
      raw = None;
    }
  else
    try
      ignore (Cli_unix.read_text_file path);
      {
        id = Edn_util.keyword_t "db-worker-script";
        status = Ok;
        code = None;
        message = "Found readable file: " ^ path;
        path = Some path;
        servers = Vec.empty;
        raw = None;
      }
    with exn ->
      {
        id = Edn_util.keyword_t "db-worker-script";
        status = Error;
        code = Some Error.Doctor_script_unreadable;
        message =
          "db-worker script is not readable: " ^ path ^ " ("
          ^ Printexc.to_string exn ^ ")";
        path = Some path;
        servers = Vec.empty;
        raw = None;
      }

let ensure_dir path =
  if Cli_unix.file_exists path then () else Cli_unix.mkdir path 0o755

let check_root_dir config =
  let path = config.Cli_config.root_dir in
  try
    ensure_dir path;
    let probe = Filename.concat path ".logseq-cli-doctor-check" in
    Cli_unix.write_text_file probe "ok";
    Cli_unix.remove_tree probe;
    {
      id = Edn_util.keyword_t "root-dir";
      status = Ok;
      code = None;
      message = "Read/write access confirmed: " ^ path;
      path = Some path;
      servers = Vec.empty;
      raw = None;
    }
  with exn ->
    {
      id = Edn_util.keyword_t "root-dir";
      status = Error;
      code = Some Error.Root_dir_permission;
      message = "root-dir check failed: " ^ Printexc.to_string exn;
      path = Some path;
      servers = Vec.empty;
      raw = None;
    }

let server_status_value = function
  | Server_runtime.Starting -> Edn_util.keyword "starting"
  | Server_runtime.Ready -> Edn_util.keyword "ready"
  | Server_runtime.Error -> Edn_util.keyword "error"
  | Server_runtime.Unknown -> Edn_util.keyword "unknown"

let server_value (server : Server_runtime.server) =
  Edn_util.map_vec
    (Vec.of_array
       [|
         ( Edn_util.keyword "repo",
           Edn_util.string (Cli_primitive.string_of_repo server.repo) );
         ( Edn_util.keyword "graph",
           match server.graph with
           | Some graph -> Edn_util.string (Cli_primitive.string_of_graph graph)
           | None -> Edn_util.nil );
         (Edn_util.keyword "status", server_status_value server.status);
         (Edn_util.keyword "base-url", Edn_util.string server.base_url);
       |])

let check_running_servers config =
  Cli_effect.map
    (fun servers ->
      let starting =
        Vec.filter
          (fun (server : Server_runtime.server) ->
            server.status = Server_runtime.Starting)
          servers
      in
      if Vec.is_empty starting then
        {
          id = Edn_util.keyword_t "running-servers";
          status = Ok;
          code = None;
          message =
            (if Vec.is_empty servers then
               "No running db-worker servers detected"
             else "All running servers are ready");
          path = None;
          servers = Vec.map server_value servers;
          raw = None;
        }
      else
        {
          id = Edn_util.keyword_t "running-servers";
          status = Warning;
          code = Some Error.Doctor_server_not_ready;
          message =
            Humanize_types.format_count_with_noun (Vec.length starting) "server"
            ^ " still starting";
          path = None;
          servers = Vec.map server_value starting;
          raw = None;
        })
    (Server_runtime.list_servers config)

let report_status checks =
  if Vec.exists (fun (check : check) -> check.status = Error) checks then Error
  else if Vec.exists (fun (check : check) -> check.status = Warning) checks then
    Warning
  else Ok

let report_value checks =
  let status = report_status checks in
  Edn_util.map_vec
    (Vec.of_array
       [|
         (Edn_util.keyword "status", status_value status);
         ( Edn_util.keyword "checks",
           Edn_util.vector_vec (checks |> Vec.map check_value) );
       |])

let build ?registry:_ _ _ (Parsed_doctor opts) =
  let script_path =
    if opts.dev_script then Some (Filename.concat "static" "db-worker-node.js")
    else None
  in
  Stdlib.Ok (Doctor { script_path })

let execute_with_mode action config mode =
  let script_check = check_db_worker_script action in
  if script_check.status = Error then
    Cli_effect.pure
      (Output_mode.error ~command:Command_id.Doctor mode
         ~context:(report_value (Vec.singleton script_check))
         (Error.make
            ~context:(report_value (Vec.singleton script_check))
            (Option.value script_check.code ~default:Error.Doctor_error)
            script_check.message))
  else
    let root_check = check_root_dir config in
    if root_check.status = Error then
      let checks = Vec.of_array [| script_check; root_check |] in
      Cli_effect.pure
        (Output_mode.error ~command:Command_id.Doctor mode
           ~context:(report_value checks)
           (Error.make ~context:(report_value checks)
              (Option.value root_check.code ~default:Error.Doctor_error)
              root_check.message))
    else
      Cli_effect.map
        (fun server_check ->
          let checks =
            Vec.of_array [| script_check; root_check; server_check |]
          in
          Cli_result.ok ~command:Command_id.Doctor mode
            (Raw (report_value checks)))
        (check_running_servers config)

let metadata () =
  Vec.of_array
    [|
      {
        Command_registry.id = Command_id.Doctor;
        path = Command_id.to_path Command_id.Doctor;
        doc = "Run CLI diagnostics";
        long_doc = None;
        examples = Vec.empty;
        options = Vec.empty;
        category = Command_registry.Utilities;
        requires_graph = Command_id.requires_graph Command_id.Doctor;
        requires_auth = Command_id.requires_auth Command_id.Doctor;
        write_command = Command_id.is_write Command_id.Doctor;
        human_table_headers_order = Vec.empty;
      };
    |]

let execute action config =
  let (Output.Mode.Packed mode) = Output_mode.for_config config in
  execute_with_mode action config mode