(* libguestfs
 * Copyright (C) 2009-2025 Red Hat Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 *)

(* Please read generator/README first. *)

open Printf

open Std_utils
open Types
open Utils
open Pr
open Docstrings
open Optgroups
open Actions
open Structs
open C

let generate_header = generate_header ~inputs:["generator/daemon.ml"]

(* Generate daemon/actions.h. *)
let generate_daemon_actions_h () =
  generate_header CStyle GPLv2plus;

  pr "#ifndef GUESTFSD_ACTIONS_H\n";
  pr "#define GUESTFSD_ACTIONS_H\n";
  pr "\n";

  pr "#include \"guestfs_protocol.h\"\n";
  pr "#include \"daemon.h\"\n";
  pr "\n";

  List.iter (
    function
    | { style = _, _, [] } -> ()
    | { name = shortname; style = _, _, (_::_ as optargs) } ->
        List.iteri (
          fun i arg ->
            let uc_shortname = String.uppercase_ascii shortname in
            let n = name_of_optargt arg in
            let uc_n = String.uppercase_ascii n in
            pr "#define GUESTFS_%s_%s_BITMASK (UINT64_C(1)<<%d)\n"
              uc_shortname uc_n i
        ) optargs
  ) (actions |> daemon_functions |> sort);

  List.iter (
    fun { name; style = ret, args, optargs } ->
      let args_passed_to_daemon = args @ args_of_optargs optargs in
      let args_passed_to_daemon =
        List.filter (function String ((FileIn|FileOut), _) -> false | _ -> true)
                    args_passed_to_daemon in
      let style = ret, args_passed_to_daemon, [] in
      generate_prototype
        ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
        name style;
  ) (actions |> daemon_functions |> sort);

  pr "\n";
  pr "#endif /* GUESTFSD_ACTIONS_H */\n"

let generate_daemon_stubs_h () =
  generate_header CStyle GPLv2plus;

  pr "\
#ifndef GUESTFSD_STUBS_H
#define GUESTFSD_STUBS_H

";

  List.iter (
    fun { name } ->
      pr "extern void %s_stub (XDR *xdr_in);\n" name;
  ) (actions |> daemon_functions |> sort);

  pr "\n";
  pr "#endif /* GUESTFSD_STUBS_H */\n"

(* Generate the server-side stubs. *)
let generate_daemon_stubs actions () =
  generate_header CStyle GPLv2plus;

  pr {|#include <config.h>

#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <string.h>
#include <inttypes.h>
#include <errno.h>
#include <rpc/types.h>
#include <rpc/xdr.h>

#include "daemon.h"
#include "c-ctype.h"
#include "guestfs_protocol.h"
#include "actions.h"
#include "optgroups.h"
#include "stubs.h"
#include "stubs-macros.h"

|};

  List.iter (
    fun { name; style = ret, args, optargs; optional } ->
      (* Generate server-side stubs. *)
      let uc_name = String.uppercase_ascii name in

      let args_passed_to_daemon = args @ args_of_optargs optargs in
      let args_passed_to_daemon =
        List.filter (function String ((FileIn|FileOut), _) -> false | _ -> true)
                    args_passed_to_daemon in

      if args_passed_to_daemon <> [] then (
        pr "#define CLEANUP_XDR_FREE_%s_ARGS \\\n" uc_name;
        pr "    __attribute__((cleanup(cleanup_xdr_free_%s_args)))\n" name;
        pr "\n";
        pr "static void\n";
        pr "cleanup_xdr_free_%s_args (struct guestfs_%s_args *argsp)\n"
           name name;
        pr "{\n";
        pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) argsp);\n"
           name;
        pr "}\n";
        pr "\n";
        pr "\n"
      );

      pr "void\n";
      pr "%s_stub (XDR *xdr_in)\n" name;
      pr "{\n";
      (match ret with
       | RErr | RInt _ -> pr "  int r;\n"
       | RInt64 _ -> pr "  int64_t r;\n"
       | RBool _ -> pr "  int r;\n"
       | RConstString _ | RConstOptString _ ->
           failwithf "RConstString|RConstOptString cannot be used by daemon functions"
       | RString _ -> pr "  CLEANUP_FREE char *r = NULL;\n"
       | RStringList _ | RHashtable _ -> pr "  CLEANUP_FREE_STRING_LIST char **r = NULL;\n"
       | RStruct (_, typ) -> pr "  CLEANUP_FREE guestfs_int_%s *r = NULL;\n" typ
       | RStructList (_, typ) -> pr "  CLEANUP_FREE guestfs_int_%s_list *r = NULL;\n" typ
       | RBufferOut _ ->
           pr "  size_t size = 1;\n";
           pr "  CLEANUP_FREE char *r = NULL;\n"
      );

      if args_passed_to_daemon <> [] then (
        pr "  CLEANUP_XDR_FREE_%s_ARGS struct guestfs_%s_args args;\n"
           uc_name name;
        pr "  memset (&args, 0, sizeof args);\n";
        List.iter (
          function
          | String ((Device|Dev_or_Path), n) ->
            pr "  CLEANUP_FREE char *%s = NULL;\n" n
          | String ((Pathname|PlainString|Key|GUID), n)
          | OptString n ->
            pr "  const char *%s;\n" n
          | String ((Mountable|Mountable_or_Path), n) ->
            pr "  CLEANUP_FREE_MOUNTABLE mountable_t %s\n" n;
            pr "      = { .device = NULL, .volume = NULL };\n"
          | StringList ((PlainString|Filename|Pathname), n) ->
            pr "  char **%s;\n" n
          | StringList (Device, n) ->
            pr "  CLEANUP_FREE_STRING_LIST char **%s = NULL;\n" n
          | Bool n -> pr "  int %s;\n" n
          | Int n -> pr "  int %s;\n" n
          | Int64 n -> pr "  int64_t %s;\n" n
          | BufferIn n ->
              pr "  const char *%s;\n" n;
              pr "  size_t %s_size;\n" n
          | String ((FileIn|FileOut|Filename), _)
          | StringList ((Mountable|FileIn|FileOut|Key|GUID
                         |Dev_or_Path|Mountable_or_Path), _)
          | Pointer _ -> assert false
        ) args_passed_to_daemon
      );
      pr "\n";

      let is_filein =
        List.exists (function String (FileIn, _) -> true | _ -> false) args in

      (* Reject Optional functions that are not available (RHBZ#679737). *)
      (match optional with
      | Some group ->
        pr "  /* The caller should have checked before calling this. */\n";
        pr "  if (! optgroup_%s_available ()) {\n" group;
        if is_filein then
          pr "    cancel_receive ();\n";
        pr "    reply_with_unavailable_feature (\"%s\");\n" group;
        pr "    return;\n";
        pr "  }\n";
        pr "\n"
      | None -> ()
      );

      (* Reject unknown optional arguments.
       * Note this code is included even for calls with no optional
       * args because the caller must not pass optargs_bitmask != 0
       * in that case.
       *)
      if optargs <> [] then (
        let len = List.length optargs in
        let mask = Int64.lognot (Int64.pred (Int64.shift_left 1L len)) in
        pr "  if (optargs_bitmask & UINT64_C(0x%Lx)) {\n" mask;
        if is_filein then
          pr "    cancel_receive ();\n";
        pr "    reply_with_error (\"unknown option in optional arguments bitmask (this can happen if a program is compiled against a newer version of libguestfs, then run against an older version of the daemon)\");\n";
        pr "    return;\n";
        pr "  }\n";
      ) else (
        pr "  if (optargs_bitmask != 0) {\n";
        if is_filein then
          pr "    cancel_receive ();\n";
        pr "    reply_with_error (\"header optargs_bitmask field must be passed as 0 for calls that don't take optional arguments\");\n";
        pr "    return;\n";
        pr "  }\n";
      );
      pr "\n";

      (* Decode arguments. *)
      if args_passed_to_daemon <> [] then (
        pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
        if is_filein then
          pr "    cancel_receive ();\n";
        pr "    reply_with_error (\"daemon failed to decode procedure arguments\");\n";
        pr "    return;\n";
        pr "  }\n";
        let pr_args n =
          pr "  %s = args.%s;\n" n n
        in
        List.iter (
          function
          | String (Pathname, n) ->
              pr_args n;
              pr "  ABS_PATH (%s, %b, return);\n" n is_filein;
          | String (Device, n) ->
              pr "  RESOLVE_DEVICE (args.%s, %s, %b);\n" n n is_filein;
          | String (Mountable, n) ->
              pr "  RESOLVE_MOUNTABLE (args.%s, %s, %b);\n" n n is_filein;
          | String (Dev_or_Path, n) ->
              pr "  REQUIRE_ROOT_OR_RESOLVE_DEVICE (args.%s, %s, %b);\n"
                n n is_filein;
          | String (Mountable_or_Path, n) ->
              pr "  REQUIRE_ROOT_OR_RESOLVE_MOUNTABLE (args.%s, %s, %b);\n"
                n n is_filein;
          | String ((PlainString|Key|GUID), n) -> pr_args n
          | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
          | StringList ((PlainString|Filename|Pathname) as arg, n) ->
            (match arg with
            | Filename ->
              pr "  {\n";
              pr "    size_t i;\n";
              pr "    for (i = 0; i < args.%s.%s_len; ++i) {\n" n n;
              pr "      if (strchr (args.%s.%s_val[i], '/') != NULL) {\n" n n;
              if is_filein then
                pr "        cancel_receive ();\n";
              pr "        reply_with_error (\"%%s: '%%s' is not a file name\", __func__, args.%s.%s_val[i]);\n"
                n n;
              pr "        return;\n";
              pr "      }\n";
              pr "    }\n";
              pr "  }\n"
            | Pathname ->
              pr "  {\n";
              pr "    size_t i;\n";
              pr "    for (i = 0; i < args.%s.%s_len; ++i) {\n" n n;
              pr "      ABS_PATH (args.%s.%s_val[i], %b, return);\n"
                n n is_filein;
              pr "    }\n";
              pr "  }\n"
            | _ -> ()
            );
            pr "  /* Ugly, but safe and avoids copying the strings. */\n";
            pr "  %s = realloc (args.%s.%s_val,\n" n n n;
            pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
            pr "  if (%s == NULL) {\n" n;
            if is_filein then
              pr "    cancel_receive ();\n";
            pr "    reply_with_perror (\"realloc\");\n";
            pr "    return;\n";
            pr "  }\n";
            pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
            pr "  args.%s.%s_val = %s;\n" n n n
          | StringList (Device, n) ->
            pr "  /* Copy the string list and apply device name translation\n";
            pr "   * to each one.\n";
            pr "   */\n";
            pr "  %s = calloc (args.%s.%s_len+1, sizeof (char *));\n" n n n;
            pr "  {\n";
            pr "    size_t i;\n";
            pr "    for (i = 0; i < args.%s.%s_len; ++i)\n" n n;
            pr "      RESOLVE_DEVICE (args.%s.%s_val[i], %s[i], %b);\n"
               n n n is_filein;
            pr "    %s[i] = NULL;\n" n;
            pr "  }\n"
          | Bool n -> pr "  %s = args.%s;\n" n n
          | Int n -> pr "  %s = args.%s;\n" n n
          | Int64 n -> pr "  %s = args.%s;\n" n n
          | BufferIn n ->
              pr "  %s = args.%s.%s_val;\n" n n n;
              pr "  %s_size = args.%s.%s_len;\n" n n n
          | String ((FileIn|FileOut|Filename), _)
          | StringList ((Mountable|FileIn|FileOut|Key|GUID
                         |Dev_or_Path|Mountable_or_Path), _)
          | Pointer _ -> assert false
        ) args_passed_to_daemon;
        pr "\n"
      );

      (* this is used at least for do_equal *)
      if List.exists (function String (Pathname, _) -> true
                             | _ -> false) args then (
        (* Emit NEED_ROOT just once, even when there are two or
           more Pathname args *)
        pr "  NEED_ROOT (%b, return);\n" is_filein
      );

      (* Don't want to call the impl with any FileIn or FileOut
       * parameters, since these go "outside" the RPC protocol.
       *)
      let () =
        let args' =
          List.filter
            (function String ((FileIn|FileOut), _) -> false | _ -> true) args in
        let style = ret, args' @ args_of_optargs optargs, [] in
        pr "  r = do_%s " name;
        generate_c_call_args ~in_daemon:true style;
        pr ";\n" in

      (match ret with
       | RConstOptString _ -> assert false
       | RErr | RInt _ | RInt64 _ | RBool _
       | RConstString _
       | RString _ | RStringList _ | RHashtable _
       | RStruct (_, _) | RStructList (_, _) ->
           let errcode =
             match errcode_of_ret ret with
             | `CannotReturnError -> assert false
             | (`ErrorIsMinusOne | `ErrorIsNULL) as e -> e in
           pr "  if (r == %s)\n" (string_of_errcode errcode);
           pr "    /* do_%s has already called reply_with_error */\n" name;
           pr "    return;\n";
           pr "\n"
       | RBufferOut _ ->
           pr "  /* size == 0 && r == NULL could be a non-error case (just\n";
           pr "   * an ordinary zero-length buffer), so be careful ...\n";
           pr "   */\n";
           pr "  if (size == 1 && r == NULL)\n";
           pr "    /* do_%s has already called reply_with_error */\n" name;
           pr "    return;\n";
           pr "\n"
      );

      (* If there are any FileOut parameters, then the impl must
       * send its own reply.
       *)
      let no_reply =
        List.exists (function String (FileOut, _) -> true | _ -> false) args in
      if no_reply then
        pr "  /* do_%s has already sent a reply */\n" name
      else (
        match ret with
        | RErr -> pr "  reply (NULL, NULL);\n"
        | RInt n | RInt64 n | RBool n ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  ret.%s = r;\n" n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RConstString _ | RConstOptString _ ->
            failwithf "RConstString|RConstOptString cannot be used by daemon functions"
        | RString (RPlainString, n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  ret.%s = r;\n" n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RString ((RDevice|RMountable), n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  CLEANUP_FREE char *rr = reverse_device_name_translation (r);\n";
            pr "  if (rr == NULL)\n";
            pr "    /* reverse_device_name_translation has already called reply_with_error */\n";
            pr "    return;\n";
            pr "  ret.%s = rr;\n" n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RStringList (RPlainString, n)
        | RHashtable (RPlainString, RPlainString, n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n;
            pr "  ret.%s.%s_val = r;\n" n n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RStringList ((RDevice|RMountable), n)
        | RHashtable ((RDevice|RMountable), (RDevice|RMountable), n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  size_t i;\n";
            pr "  for (i = 0; r[i] != NULL; ++i) {\n";
            pr "    char *rr = reverse_device_name_translation (r[i]);\n";
            pr "    if (rr == NULL)\n";
            pr "      /* reverse_device_name_translation has already called reply_with_error */\n";
            pr "      return;\n";
            pr "    free (r[i]);\n";
            pr "    r[i] = rr;\n";
            pr "  }\n";
            pr "  ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n;
            pr "  ret.%s.%s_val = r;\n" n n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RHashtable ((RDevice|RMountable), RPlainString, n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  size_t i;\n";
            pr "  for (i = 0; r[i] != NULL; i += 2) {\n";
            pr "    char *rr = reverse_device_name_translation (r[i]);\n";
            pr "    if (rr == NULL)\n";
            pr "      /* reverse_device_name_translation has already called reply_with_error */\n";
            pr "      return;\n";
            pr "    free (r[i]);\n";
            pr "    r[i] = rr;\n";
            pr "  }\n";
            pr "  ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n;
            pr "  ret.%s.%s_val = r;\n" n n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RHashtable (RPlainString, (RDevice|RMountable), n) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  size_t i;\n";
            pr "  for (i = 0; r[i] != NULL; i += 2) {\n";
            pr "    char *rr = reverse_device_name_translation (r[i+1]);\n";
            pr "    if (rr == NULL)\n";
            pr "      /* reverse_device_name_translation has already called reply_with_error */\n";
            pr "      return;\n";
            pr "    free (r[i+1]);\n";
            pr "    r[i+1] = rr;\n";
            pr "  }\n";
            pr "  ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n;
            pr "  ret.%s.%s_val = r;\n" n n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RStruct (n, typ) ->
            (* XXX RStruct containing an FDevice field would require
             * reverse device name translation.  That is not implemented.
             * See also RStructList immediately below this.
             *)
            let cols = (Structs.lookup_struct typ).s_cols in
            assert (not (List.exists
                           (function (_, FDevice) -> true | _ -> false) cols));
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  ret.%s = *r;\n" n;
            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
              name;
            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RStructList (n, typ) ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            let cols = (Structs.lookup_struct typ).s_cols in
            List.iter (
              function
              | (fname, FDevice) ->
                pr "  for (size_t i = 0; i < r->guestfs_int_%s_list_len; ++i) {\n"
                  typ;
                pr "    char *field = r->guestfs_int_%s_list_val[i].%s;\n"
                  typ fname;
                pr "    char *rr = reverse_device_name_translation (field);\n";
                pr "    if (!rr) abort ();\n";
                pr "    free (field);\n";
                pr "    r->guestfs_int_%s_list_val[i].%s = rr;\n" typ fname;
                pr "  }\n";
              | _ -> ()
            ) cols;
            pr "  ret.%s = *r;\n" n;
            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
              name;
            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
        | RBufferOut n ->
            pr "  struct guestfs_%s_ret ret;\n" name;
            pr "  ret.%s.%s_val = r;\n" n n;
            pr "  ret.%s.%s_len = size;\n" n n;
            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
              name
      );
      pr "}\n\n";
  ) (actions |> daemon_functions |> sort)

let generate_daemon_caml_callbacks_ml () =
  generate_header OCamlStyle GPLv2plus;

  if actions |> impl_ocaml_functions <> [] then (
    pr "let init_callbacks () =\n";
    pr "  (* Initialize callbacks to OCaml code. *)\n";
    List.iter (
      fun ({ name; style = ret, args, optargs } as f) ->
        let ocaml_function =
          match f.impl with
          | OCaml f -> f
          | C -> assert false in

        pr "  Callback.register %S %s;\n" ocaml_function ocaml_function
    ) (actions |> impl_ocaml_functions |> sort)
  )
  else
    pr "let init_callbacks () = ()\n"

let rec generate_daemon_caml_interface modname () =
  generate_header OCamlStyle GPLv2plus;

  let is_ocaml_module_function = function
    | { impl = OCaml m } when String.starts_with (modname ^ ".") m -> true
    | { impl = OCaml _ } -> false
    | { impl = C } -> false
  in

  let ocaml_actions = actions |> (List.filter is_ocaml_module_function) in
  if ocaml_actions == [] then
    failwithf "no OCaml implementations for module %s" modname;

  let prefix_length = String.length modname + 1 in
  List.iter (
    fun { name; style; impl } ->
      let ocaml_function =
        match impl with
        | OCaml f ->
            String.sub f prefix_length (String.length f - prefix_length)
        | C -> assert false in

      generate_ocaml_daemon_prototype ocaml_function style
  ) ocaml_actions

and generate_ocaml_daemon_prototype name (ret, args, optargs) =
  let type_for_stringt = function
    | Mountable
    | Mountable_or_Path -> "Mountable.t"
    | PlainString
    | Device
    | Pathname
    | FileIn
    | FileOut
    | Key
    | GUID
    | Filename
    | Dev_or_Path -> "string"
  in
  let type_for_rstringt = function
    | RMountable -> "Mountable.t"
    | RPlainString
    | RDevice -> "string"
  in
  pr "val %s : " name;
  List.iter (
    function
    | OBool n -> pr "?%s:bool -> " n
    | OInt n -> pr "?%s:int -> " n
    | OInt64 n -> pr "?%s:int64 -> " n
    | OString n -> pr "?%s:string -> " n
    | OStringList n -> pr "?%s:string list -> " n
  ) optargs;
  if args <> [] then
    List.iter (
      function
      | String (typ, _) -> pr "%s -> " (type_for_stringt typ)
      | BufferIn _ -> pr "string -> "
      | OptString _ -> pr "string option -> "
      | StringList (typ, _) -> pr "%s list -> " (type_for_stringt typ)
      | Bool _ -> pr "bool -> "
      | Int _ -> pr "int -> "
      | Int64 _ | Pointer _ -> pr "int64 -> "
    ) args
  else
    pr "unit -> ";
  (match ret with
   | RErr -> pr "unit" (* all errors are turned into exceptions *)
   | RInt _ -> pr "int"
   | RInt64 _ -> pr "int64"
   | RBool _ -> pr "bool"
   | RConstString _ -> pr "string"
   | RConstOptString _ -> pr "string option"
   | RString (typ, _) -> pr "%s" (type_for_rstringt typ)
   | RBufferOut _ -> pr "string"
   | RStringList (typ, _) -> pr "%s list" (type_for_rstringt typ)
   | RStruct (_, typ) -> pr "Structs.%s" typ
   | RStructList (_, typ) -> pr "Structs.%s list" typ
   | RHashtable (typea, typeb, _) ->
       pr "(%s * %s) list" (type_for_rstringt typea) (type_for_rstringt typeb)
  );
  pr "\n"

(* Generate stubs for the functions implemented in OCaml.
 * Basically we implement the do_<name> function here, and
 * have it call out to OCaml code.
 *)
let generate_daemon_caml_stubs () =
  generate_header CStyle GPLv2plus;

  pr {|#include <config.h>

#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <string.h>
#include <inttypes.h>
#include <errno.h>
#include <assert.h>

#include <caml/alloc.h>
#include <caml/callback.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>

#include "daemon.h"
#include "actions.h"
#include "daemon-c.h"

|};

  (* Implement code for returning structs and struct lists. *)
  let emit_return_struct typ =
    let struc = Structs.lookup_struct typ in
    let uc_typ = String.uppercase_ascii typ in
    pr "/* Implement RStruct (%S, _). */\n" typ;
    pr "static guestfs_int_%s *\n" typ;
    pr "return_%s (value retv)\n" typ;
    pr "{\n";
    pr "  CLEANUP_FREE_%s guestfs_int_%s *ret = NULL;\n" uc_typ typ;
    pr "  guestfs_int_%s *real_ret;\n" typ;
    pr "  value v;\n";
    pr "\n";
    pr "  ret = calloc (1, sizeof (*ret));\n";
    pr "  if (ret == NULL) {\n";
    pr "    reply_with_perror (\"calloc\");\n";
    pr "    return NULL;\n";
    pr "  }\n";
    pr "\n";
    List.iteri (
      fun i ->
        pr "  v = Field (retv, %d);\n" i;
        function
        | n, (FString|FDevice) ->
           pr "  ret->%s = strdup (String_val (v));\n" n;
           pr "  if (ret->%s == NULL) return NULL;\n" n
        | n, FUUID ->
           pr "  assert (caml_string_length (v) == sizeof ret->%s);\n" n;
           pr "  memcpy (ret->%s, String_val (v), sizeof ret->%s);\n" n n
        | n, FBuffer ->
           pr "  ret->%s_len = caml_string_length (v);\n" n;
           pr "  ret->%s = strdup (String_val (v));\n" n;
           pr "  if (ret->%s == NULL) return NULL;\n" n
        | n, (FBytes|FInt64|FUInt64) ->
           pr "  ret->%s = Int64_val (v);\n" n
        | n, (FInt32|FUInt32) ->
           pr "  ret->%s = Int32_val (v);\n" n
        | n, FOptPercent ->
           pr "  if (v == Val_int (0)) /* None */\n";
           pr "    ret->%s = -1;\n" n;
           pr "  else {\n";
           pr "    v = Field (v, 0);\n";
           pr "    ret->%s = Double_val (v);\n" n;
           pr "  }\n"
        | n, FChar ->
           pr "  ret->%s = Int_val (v);\n" n
    ) struc.s_cols;
    pr "\n";
    pr "  real_ret = ret;\n";
    pr "  ret = NULL;\n";
    pr "  return real_ret;\n";
    pr "}\n";
    pr "\n"

  and emit_return_struct_list typ =
    let uc_typ = String.uppercase_ascii typ in
    pr "/* Implement RStructList (%S, _). */\n" typ;
    pr "static guestfs_int_%s_list *\n" typ;
    pr "return_%s_list (value retv)\n" typ;
    pr "{\n";
    pr "  CLEANUP_FREE_%s_LIST guestfs_int_%s_list *ret = NULL;\n" uc_typ typ;
    pr "  guestfs_int_%s_list *real_ret;\n" typ;
    pr "  guestfs_int_%s *r;\n" typ;
    pr "  size_t i, len;\n";
    pr "  value v, rv;\n";
    pr "\n";
    pr "  /* Count the number of elements in the list. */\n";
    pr "  rv = retv;\n";
    pr "  len = 0;\n";
    pr "  while (rv != Val_int (0)) {\n";
    pr "    len++;\n";
    pr "    rv = Field (rv, 1);\n";
    pr "  }\n";
    pr "\n";
    pr "  ret = calloc (1, sizeof *ret);\n";
    pr "  if (ret == NULL) {\n";
    pr "    reply_with_perror (\"calloc\");\n";
    pr "    return NULL;\n";
    pr "  }\n";
    pr "  if (len > 0) {\n";
    pr "    ret->guestfs_int_%s_list_val =\n" typ;
    pr "      calloc (len, sizeof (guestfs_int_%s));\n" typ;
    pr "    if (ret->guestfs_int_%s_list_val == NULL) {\n" typ;
    pr "      reply_with_perror (\"calloc\");\n";
    pr "      return NULL;\n";
    pr "    }\n";
    pr "    ret->guestfs_int_%s_list_len = len;\n" typ;
    pr "  }\n";
    pr "\n";
    pr "  rv = retv;\n";
    pr "  for (i = 0; i < len; ++i) {\n";
    pr "    v = Field (rv, 0);\n";
    pr "    r = return_%s (v);\n" typ;
    pr "    if (r == NULL)\n";
    pr "      return NULL;\n";
    pr "    memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof (*r));\n" typ;
    pr "    free (r);\n";
    pr "    rv = Field (rv, 1);\n";
    pr "  }\n";
    pr "\n";
    pr "  real_ret = ret;\n";
    pr "  ret = NULL;\n";
    pr "  return real_ret;\n";
    pr "}\n";
    pr "\n";
  in

  List.iter (
    function
    | typ, RStructOnly ->
       emit_return_struct typ
    | typ, (RStructListOnly | RStructAndList) ->
       emit_return_struct typ;
       emit_return_struct_list typ
  ) (rstructs_used_by (actions |> impl_ocaml_functions));

  (* Implement the wrapper functions. *)
  List.iter (
    fun ({ name; style = ret, args, optargs } as f) ->
      let uc_name = String.uppercase_ascii name in
      let ocaml_function =
        match f.impl with
        | OCaml f -> f
        | C -> assert false in

      pr "/* Wrapper for OCaml function ‘%s’. */\n" ocaml_function;

      let args_do_function = args @ args_of_optargs optargs in
      let args_do_function =
        List.filter (function
                     | String ((FileIn|FileOut), _) -> false | _ -> true)
                    args_do_function in
      let style = ret, args_do_function, [] in
      generate_prototype ~extern:false ~semicolon:false
                         ~single_line:false ~newline:false
                         ~in_daemon:true ~prefix:"do_"
                         name style;
      pr "\n";

      let add_unit_arg =
        let args = List.filter
                     (function
                      | String ((FileIn|FileOut), _) -> false | _ -> true)
                 args in
        args = [] in
      let nr_args = List.length args_do_function in

      pr "{\n";
      pr "  static const value *cb = NULL;\n";
      pr "  CAMLparam0 ();\n";
      pr "  CAMLlocal2 (v, retv);\n";
      pr "  CAMLlocalN (args, %d);\n"
         (nr_args + if add_unit_arg then 1 else 0);
      pr "\n";
      pr "  if (cb == NULL)\n";
      pr "    cb = caml_named_value (\"%s\");\n" ocaml_function;
      pr "\n";

      (* Construct the actual call, but note that we want to pass
       * the optional arguments first in the list.
       *)
      let i = ref 0 in
      List.iter (
        fun optarg ->
          let n = name_of_optargt optarg in
          let uc_n = String.uppercase_ascii n in

          (* optargs are all passed as [None|Some _] *)
          pr "  if ((optargs_bitmask & GUESTFS_%s_%s_BITMASK) == 0)\n"
             uc_name uc_n;
          pr "    args[%d] = Val_int (0); /* None */\n" !i;
          pr "  else {\n";
          pr "    v = ";
          (match optarg with
           | OBool _ ->
              pr "Val_bool (%s)" n;
           | OInt _ -> assert false
           | OInt64 _ -> assert false
           | OString _ ->
              pr "caml_copy_string (%s)" n
           | OStringList _ -> assert false
          );
          pr ";\n";
          pr "    args[%d] = caml_alloc (1, 0);\n" !i;
          pr "    Store_field (args[%d], 0, v);\n" !i;
          pr "  }\n";
          incr i
      ) optargs;
      List.iter (
        fun arg ->
          pr "  args[%d] = " !i;
          (match arg with
           | Bool n -> pr "Val_bool (%s)" n
           | Int n -> pr "Val_int (%s)" n
           | Int64 n -> pr "caml_copy_int64 (%s)" n
           | String ((PlainString|Device|Pathname|Dev_or_Path|Key|GUID), n) ->
              pr "caml_copy_string (%s)" n
           | String ((Mountable|Mountable_or_Path), n) ->
              pr "guestfs_int_daemon_copy_mountable (%s)" n
           | String _ -> assert false
           | OptString _ -> assert false
           | StringList ((PlainString|Filename|Pathname), n) ->
              pr "guestfs_int_daemon_copy_string_list (%s)" n
           | StringList _ -> assert false
           | BufferIn _ -> assert false
           | Pointer _ -> assert false
          );
          pr ";\n";
          incr i
      ) args;
      assert (!i = nr_args);

      (* If there are no non-optional arguments, we add a unit arg. *)
      if add_unit_arg then
        pr "  args[%d] = Val_unit;\n" !i;

      pr "  retv = caml_callbackN_exn (*cb, %d, args);\n"
         (nr_args + if add_unit_arg then 1 else 0);
      pr "\n";
      pr "  if (Is_exception_result (retv)) {\n";
      pr "    retv = Extract_exception (retv);\n";
      pr "    guestfs_int_daemon_exn_to_reply_with_error (%S, retv);\n" name;
      (match errcode_of_ret ret with
       | `CannotReturnError ->
          pr "    CAMLreturn0;\n"
       | `ErrorIsMinusOne ->
          pr "    CAMLreturnT (int, -1);\n"
       | `ErrorIsNULL ->
          pr "    CAMLreturnT (void *, NULL);\n"
      );
      pr "  }\n";
      pr "\n";

      (match ret with
       | RErr ->
          pr "  CAMLreturnT (int, 0);\n"
       | RInt _ ->
          pr "  CAMLreturnT (int, Int_val (retv));\n"
       | RInt64 _ ->
          pr "  CAMLreturnT (int64_t, Int64_val (retv));\n"
       | RBool _ ->
          pr "  CAMLreturnT (int, Bool_val (retv));\n"
       | RConstString _ -> assert false
       | RConstOptString _ -> assert false
       | RString ((RPlainString|RDevice), _) ->
          pr "  char *ret = strdup (String_val (retv));\n";
          pr "  if (ret == NULL) {\n";
          pr "    reply_with_perror (\"strdup\");\n";
          pr "    CAMLreturnT (char *, NULL);\n";
          pr "  }\n";
          pr "  CAMLreturnT (char *, ret); /* caller frees */\n"
       | RString (RMountable, _) ->
          pr "  char *ret =\n";
          pr "    guestfs_int_daemon_return_string_mountable (retv);\n";
          pr "  CAMLreturnT (char *, ret); /* caller frees */\n"
       | RStringList ((RPlainString|RDevice), _) ->
          pr "  char **ret = guestfs_int_daemon_return_string_list (retv);\n";
          pr "  CAMLreturnT (char **, ret); /* caller frees */\n"
       | RStringList (RMountable, _) ->
          pr "  char **ret =\n";
          pr "    guestfs_int_daemon_return_string_mountable_list (retv);\n";
          pr "  CAMLreturnT (char **, ret); /* caller frees */\n"
       | RStruct (_, typ) ->
          pr "  guestfs_int_%s *ret =\n" typ;
          pr "    return_%s (retv);\n" typ;
          pr "  /* caller frees */\n";
          pr "  CAMLreturnT (guestfs_int_%s *, ret);\n" typ
       | RStructList (_, typ) ->
          pr "  guestfs_int_%s_list *ret =\n" typ;
          pr "    return_%s_list (retv);\n" typ;
          pr "  /* caller frees */\n";
          pr "  CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
       | RHashtable (RPlainString, RPlainString, _)
       | RHashtable (RPlainString, RDevice, _) ->
          pr "  char **ret =\n";
          pr "    guestfs_int_daemon_return_hashtable_string_string (retv);\n";
          pr "  CAMLreturnT (char **, ret); /* caller frees */\n"
       | RHashtable (RMountable, RPlainString, _) ->
          pr "  char **ret =\n";
          pr "    guestfs_int_daemon_return_hashtable_mountable_string (retv);\n";
          pr "  CAMLreturnT (char **, ret); /* caller frees */\n"
       | RHashtable (RPlainString, RMountable, _) ->
          pr "  char **ret =\n";
          pr "    guestfs_int_daemon_return_hashtable_string_mountable (retv);\n";
          pr "  CAMLreturnT (char **, ret); /* caller frees */\n"
       | RHashtable _ -> assert false
       | RBufferOut _ -> assert false
      );
      pr "}\n";
      pr "\n"
  ) (actions |> impl_ocaml_functions |> sort)

let generate_daemon_dispatch () =
  generate_header CStyle GPLv2plus;

  pr {|#include <config.h>

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <inttypes.h>
#include <errno.h>
#include <rpc/types.h>
#include <rpc/xdr.h>

#include "daemon.h"
#include "c-ctype.h"
#include "guestfs_protocol.h"
#include "actions.h"
#include "optgroups.h"
#include "stubs.h"

|};

  (* Dispatch function. *)
  pr "void\n";
  pr "dispatch_incoming_message (XDR *xdr_in)\n";
  pr "{\n";
  pr "  switch (proc_nr) {\n";

  List.iter (
    fun { name } ->
      pr "    case GUESTFS_PROC_%s:\n" (String.uppercase_ascii name);
      pr "      %s_stub (xdr_in);\n" name;
      pr "      break;\n"
  ) (actions |> daemon_functions |> sort);

  pr "    default:\n";
  pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d, set LIBGUESTFS_PATH to point to the matching libguestfs appliance directory\", proc_nr);\n";
  pr "  }\n";
  pr "}\n";
  pr "\n"

(* Generate a list of function names, for debugging in the daemon.. *)
let generate_daemon_names () =
  generate_header CStyle GPLv2plus;

  pr "#include <config.h>\n";
  pr "\n";
  pr "#include \"daemon.h\"\n";
  pr "\n";

  pr "/* This array is indexed by proc_nr.  See guestfs_protocol.x. */\n";
  pr "const char *function_names[] = {\n";
  List.iter (
    function
    | { name; proc_nr = Some proc_nr } ->
      pr "  [%d] = \"%s\",\n" proc_nr name
    | { proc_nr = None } -> assert false
  ) (actions |> daemon_functions |> sort);
  pr "};\n"

(* Generate the optional groups for the daemon to implement
 * guestfs_available.
 *)
let generate_daemon_optgroups_c () =
  generate_header CStyle GPLv2plus;

  pr "#include <config.h>\n";
  pr "\n";
  pr "#include <caml/mlvalues.h>\n";
  pr "\n";
  pr "#include \"daemon.h\"\n";
  pr "#include \"optgroups.h\"\n";
  pr "\n";

  if optgroups_retired <> [] then (
    pr "static int\n";
    pr "dummy_available (void)\n";
    pr "{\n";
    pr "  return 1;\n";
    pr "}\n";
    pr "\n";
  );

  pr "struct optgroup optgroups[] = {\n";
  List.iter (
    fun group ->
      if List.mem group optgroups_retired then
        pr "  { \"%s\", dummy_available },\n" group
      else
        pr "  { \"%s\", optgroup_%s_available },\n" group group
  ) optgroups_names_all;
  pr "  { NULL, NULL }\n";
  pr "};\n";
  pr "\n";
  pr "/* Wrappers so these functions can be called from OCaml code. */\n";
  List.iter (
    fun group ->
      pr "extern value guestfs_int_daemon_optgroup_%s_available (value);\n"
         group;
      pr "\n";
      pr "/* NB: This is a [@@noalloc] call. */\n";
      pr "value\n";
      pr "guestfs_int_daemon_optgroup_%s_available (value unitv)\n" group;
      pr "{\n";
      pr "  return Val_bool (optgroup_%s_available ());\n" group;
      pr "}\n";
      pr "\n"
  ) optgroups_names

let generate_daemon_optgroups_h () =
  generate_header CStyle GPLv2plus;

  pr "#ifndef GUESTFSD_OPTGROUPS_H\n";
  pr "#define GUESTFSD_OPTGROUPS_H\n";
  pr "\n";

  List.iter (
    fun group ->
      pr "extern int optgroup_%s_available (void);\n" group
  ) optgroups_names;

  pr "\n";

  pr {|/* These macros can be used to disable an entire group of functions.
 * The advantage of generating this code is that it avoids an
 * undetected error when a new function in a group is added, but
 * the appropriate abort function is not added to the daemon (because
 * the developers rarely test that the daemon builds when a library
 * is not present).
 */

|};
  List.iter (
    fun (group, fns) ->
      pr "#define OPTGROUP_%s_NOT_AVAILABLE \\\n"
         (String.uppercase_ascii group);
      List.iter (
        function
        | { name; style = ret, args, optargs; impl = C } ->
          let style = ret, args @ args_of_optargs optargs, [] in
          pr "  ";
          generate_prototype
            ~prefix:"do_"
            ~attribute_noreturn:true
            ~single_line:true ~newline:false
            ~extern:false ~in_daemon:true
            ~semicolon:false
            name style;
          pr " { abort (); } \\\n"
        | { impl = OCaml _ } ->
           (* Don't need to generate anything for OCaml functions since
            * the caml-stubs do_* function will still exist.
            *)
           ()
      ) fns;
      pr "  int optgroup_%s_available (void) { return 0; }\n" group;
      pr "\n"
  ) optgroups;

  pr "#endif /* GUESTFSD_OPTGROUPS_H */\n"

(* Generate optgroup available functions in OCaml. *)
let generate_daemon_optgroups_ml () =
  generate_header OCamlStyle GPLv2plus;

  List.iter (
    fun group ->
      pr "external %s_available : unit -> bool =\n" group;
      pr "  \"guestfs_int_daemon_optgroup_%s_available\" [@@noalloc]\n" group
  ) optgroups_names

let generate_daemon_optgroups_mli () =
  generate_header OCamlStyle GPLv2plus;

  List.iter (
    fun group ->
      pr "val %s_available : unit -> bool\n" group
  ) optgroups_names

(* Generate structs-cleanups.c file. *)
let generate_daemon_structs_cleanups_c () =
  generate_header CStyle GPLv2plus;

  pr {|#include <config.h>

#include <stdio.h>
#include <stdlib.h>

#include "daemon.h"
#include "guestfs_protocol.h"

|};

  pr "/* Cleanup functions used by CLEANUP_* macros.  Do not call\n";
  pr " * these functions directly.\n";
  pr " */\n";
  pr "\n";

  List.iter (
    fun { s_name = typ; s_cols = cols } ->
      pr "void\n";
      pr "cleanup_free_int_%s (void *ptr)\n" typ;
      pr "{\n";
      pr "  struct guestfs_int_%s *x = (* (struct guestfs_int_%s **) ptr);\n" typ typ;
      pr "\n";
      pr "  if (x) {\n";
      pr "    xdr_free ((xdrproc_t) xdr_guestfs_int_%s, (char *) x);\n" typ;
      pr "    free (x);\n";
      pr "  }\n";
      pr "}\n";
      pr "\n";

      pr "void\n";
      pr "cleanup_free_int_%s_list (void *ptr)\n" typ;
      pr "{\n";
      pr "  struct guestfs_int_%s_list *x = (* (struct guestfs_int_%s_list **) ptr);\n"
        typ typ;
      pr "\n";
      pr "  if (x) {\n";
      pr "    xdr_free ((xdrproc_t) xdr_guestfs_int_%s_list, (char *) x);\n"
        typ;
      pr "    free (x);\n";
      pr "  }\n";
      pr "}\n";
      pr "\n";

  ) structs

(* Generate structs-cleanups.h file. *)
let generate_daemon_structs_cleanups_h () =
  generate_header CStyle GPLv2plus;

  pr {|/* These CLEANUP_* macros automatically free the struct or struct list
 * pointed to by the local variable at the end of the current scope.
 */

#ifndef GUESTFS_DAEMON_STRUCTS_CLEANUPS_H_
#define GUESTFS_DAEMON_STRUCTS_CLEANUPS_H_

|};

  List.iter (
    fun { s_name = name } ->
      pr "#define CLEANUP_FREE_%s \\\n" (String.uppercase_ascii name);
      pr "  __attribute__((cleanup(cleanup_free_int_%s)))\n" name;
      pr "#define CLEANUP_FREE_%s_LIST \\\n" (String.uppercase_ascii name);
      pr "  __attribute__((cleanup(cleanup_free_int_%s_list)))\n" name
  ) structs;

  pr {|
/* These functions are used internally by the CLEANUP_* macros.
 * Don't call them directly.
 */

|};

  List.iter (
    fun { s_name = name } ->
      pr "extern void cleanup_free_int_%s (void *ptr);\n"
        name;
      pr "extern void cleanup_free_int_%s_list (void *ptr);\n"
        name
  ) structs;

  pr "\n";
  pr "#endif /* GUESTFS_INTERNAL_FRONTEND_CLEANUPS_H_ */\n"