builder/app/client.ml

open Rresult.R.Infix

let connect (host, port) =
  let connect () =
    try
      let sockaddr = Unix.ADDR_INET (host, port) in
      let s = Unix.(socket PF_INET SOCK_STREAM 0) in
      Unix.(connect s sockaddr);
      Ok s
    with
    | Unix.Unix_error (err, f, _) ->
      Logs.err (fun m -> m "unix error in %s: %s" f (Unix.error_message err));
      Error (`Msg "connect failure")
  in
  connect () >>= fun s ->
  let hello = Builder.(Client_hello cmds) in
  Builder.write_cmd s hello >>= fun () ->
  Builder.read_cmd s >>= function
  | Builder.Server_hello x when x = Builder.cmds -> Ok s
  | cmd ->
    Logs.err (fun m -> m "expected Server Hello with matching version, got %a"
                 Builder.pp_cmd cmd);
    Error (`Msg "bad communication")

let observe () remote id =
  match Uuidm.of_string id with
  | None -> Error (`Msg "error parsing uuid")
  | Some uuid ->
    connect remote >>= fun s ->
    Builder.write_cmd s (Builder.Observe uuid) >>= fun () ->
    let rec read () =
      Builder.read_cmd s >>= fun cmd ->
      Logs.app (fun m -> m "%a" Builder.pp_cmd cmd);
      read ()
    in
    read ()

let info_ () remote =
  connect remote >>= fun s ->
  Builder.write_cmd s Builder.Info >>= fun () ->
  Builder.read_cmd s >>= fun cmd ->
  Logs.app (fun m -> m "%a" Builder.pp_cmd cmd);
  Ok ()

let unschedule () remote name =
  connect remote >>= fun s ->
  Builder.write_cmd s (Builder.Unschedule name)

let schedule () remote name script period dir =
  let files =
    match dir with
    | None -> []
    | Some f ->
      let dir = Fpath.v f in
      let all_files =
        let dirs = [ dir ] in
        let collect path acc = path :: acc in
        match Bos.OS.Path.fold ~elements:`Files collect [] dirs with
        | Ok files -> files
        | Error `Msg msg ->
          Logs.warn (fun m -> m "folding resulted in an error %s" msg);
          []
      in
      List.fold_left (fun acc f ->
          match Fpath.rem_prefix dir f with
          | None ->
            Logs.warn (fun m -> m "couldn't remove prefix from %a"
                          Fpath.pp f);
            acc
          | Some name ->
            match Bos.OS.File.read f with
            | Ok data -> (name, data) :: acc
            | Error `Msg e ->
              Logs.err (fun m -> m "error reading %a: %s" Fpath.pp f e);
              acc)
        [] all_files
  in
  Bos.OS.File.read (Fpath.v script) >>= fun script ->
  let job = Builder.{ name ; script ; files } in
  connect remote >>= fun s ->
  Builder.write_cmd s (Builder.Schedule (period, job))

let help () man_format cmds = function
  | None -> `Help (`Pager, None)
  | Some t when List.mem t cmds -> `Help (man_format, Some t)
  | Some x ->
    print_endline ("unknown command '" ^ x ^ "', available commands:");
    List.iter print_endline cmds;
    `Ok ()

let setup_log style_renderer level =
  Fmt_tty.setup_std_outputs ?style_renderer ();
  Logs.set_level level;
  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())

open Cmdliner

let host_port : (Unix.inet_addr * int) Arg.converter =
  let parse s =
    match String.split_on_char ':' s with
    | [ hostname ;  port ] ->
      begin try
          `Ok (Unix.inet_addr_of_string hostname, int_of_string port)
        with
          Not_found -> `Error "failed to parse IP:port"
      end
    | _ -> `Error "broken: no port specified"
  in
  parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d"
      (Unix.string_of_inet_addr h) p

let remote =
  let doc = "The remote host:port to connect to" in
  Arg.(value & opt host_port (Unix.inet_addr_loopback, 1234) &
       info [ "r" ; "remote" ] ~doc ~docv:"IP:PORT")

let nam =
  let doc = "The job name" in
  Arg.(required & pos 0 (some string) None & info [ ] ~doc ~docv:"NAME")

let id =
  let doc = "The job ID" in
  Arg.(required & pos 0 (some string) None & info [ ] ~doc ~docv:"ID")

let p : Builder.period Arg.converter =
  let parse = function
    | "hourly" -> `Ok Builder.Hourly
    | "daily" -> `Ok Builder.Daily
    | "weekly" -> `Ok Builder.Weekly
    | s -> `Error ("failed to parse period " ^ s)
  in
  parse, Builder.pp_period

let period =
  let doc = "The periodic execution interval" in
  Arg.(value & opt p Builder.Hourly & info [ "period" ] ~doc ~docv:"PERIOD")

let dir =
  let doc = "The directory with supplementary material to embed into the job" in
  Arg.(value & opt (some dir) None & info [ "dir" ] ~doc ~docv:"DIR")

let script =
  let doc = "The script to execute" in
  Arg.(required & pos 1 (some file) None & info [ ] ~doc ~docv:"FILE")

let setup_log =
  Term.(const setup_log
        $ Fmt_cli.style_renderer ()
        $ Logs_cli.level ())

let observe_cmd =
  Term.(term_result (const observe $ setup_log $ remote $ id)),
  Term.info "observe"

let info_cmd =
  Term.(term_result (const info_ $ setup_log $ remote)),
  Term.info "info"

let unschedule_cmd =
  Term.(term_result (const unschedule $ setup_log $ remote $ nam)),
  Term.info "unschedule"

let schedule_cmd =
  Term.(term_result (const schedule $ setup_log $ remote $ nam $ script $ period $ dir)),
  Term.info "schedule"

let help_cmd =
  let doc = "Builder client" in
  Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
  Term.info "builder" ~version:Builder.version ~doc

let cmds = [ help_cmd ; schedule_cmd ; unschedule_cmd ; info_cmd ; observe_cmd ]

let () = match Term.eval_choice help_cmd cmds with `Ok () -> exit 0 | _ -> exit 1