type mode = Self | Scheduled

type t = {
  result : Check.result;
  check : Check.name;
  tree : Tree.t;
  attempt : int;
  config : Build_config.t;
  rules : Commit.t;
  machine : Host.t;
  platform : Platform_name.t;
  mode : mode;
  confined : Confinement.mechanism option;
  seconds : Duration.t;
  at : Ptime.t;
  log : string option;
}

let schema = "mq2"
let earlier = [ "mq1" ]
let err fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt

let hex64 s =
  String.length s = 64
  && String.for_all
       (fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f'))
       s

let v ~result ~check ~tree ~attempt ~config ~rules ~machine ~platform ~mode
    ~confined ~seconds ~at ?log () =
  if attempt < 1 then err "attempt %d is not a run's" attempt
  else
    match log with
    | Some l when not (hex64 l) -> err "log digest %S is not a SHA-256" l
    | _ ->
        Ok
          {
            result;
            check;
            tree;
            attempt;
            config;
            rules;
            machine;
            platform;
            mode;
            confined;
            seconds;
            at;
            log;
          }

let string_of_mode = function Self -> "self" | Scheduled -> "scheduled"

let to_line r =
  let log = match r.log with None -> "" | Some l -> " log=" ^ l in
  Fmt.str
    "%s %s %s tree=%s attempt=%d config=%s rules=%s machine=%s platform=%s \
     mode=%s confined=%s seconds=%d at=%s%s"
    schema
    (Check.string_of_result r.result)
    (Check.string_of_name r.check)
    (Tree.to_hex r.tree) r.attempt
    (Build_config.to_string r.config)
    (Commit.to_hex r.rules) (Host.to_string r.machine)
    (Platform_name.to_field r.platform)
    (string_of_mode r.mode)
    (match r.confined with
    | Some m -> Confinement.string_of_mechanism m
    | None -> "no")
    (Duration.seconds r.seconds)
    (Timestamp.Rfc3339.format r.at)
    log

let ( let* ) = Result.bind

let keys =
  [
    "tree";
    "attempt";
    "config";
    "rules";
    "machine";
    "platform";
    "mode";
    "confined";
    "seconds";
    "at";
  ]

(* The [key=value] fields of a line, in the order [keys] then [log]. *)
let pairs line fields =
  let pair s =
    match String.index_opt s '=' with
    | Some i ->
        Ok (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1))
    | None -> err "field %S of %S is not key=value" s line
  in
  let* pairs =
    List.fold_right
      (fun f acc ->
        Result.bind acc (fun acc -> Result.map (fun p -> p :: acc) (pair f)))
      fields (Ok [])
  in
  let names = List.map fst pairs in
  if names = keys || names = keys @ [ "log" ] then Ok pairs
  else err "the fields of %S are not %s [log]" line (String.concat " " keys)

let tree_of s =
  match Tree.of_hex s with Some t -> Ok t | None -> err "not a tree id: %S" s

let hash_of s =
  match Commit.of_hex s with
  | Some c -> Ok c
  | None -> err "not a commit id: %S" s

let mode_of = function
  | "self" -> Ok Self
  | "scheduled" -> Ok Scheduled
  | m -> err "not a mode: %S" m

let seconds_of s =
  match int_of_string_opt s with
  | Some n when n >= 0 && string_of_int n = s -> Ok (Duration.of_seconds n)
  | _ -> err "not a count of seconds: %S" s

let time_of s =
  match Timestamp.Rfc3339.parse s with
  | Some t -> Ok t
  | None -> err "not an RFC 3339 time: %S" s

let attempt_of s =
  match int_of_string_opt s with
  | Some n -> Ok n
  | None -> err "not an attempt: %S" s

let result_of s =
  match Check.result_of_string s with
  | Some r -> Ok r
  | None -> err "not a result: %S" s

(* The machine and the platform a result ran on. *)
let where_ran get =
  let* machine = Host.of_string (get "machine") in
  let* platform = Platform_name.of_field (get "platform") in
  Ok (machine, platform)

(* [pairs] has checked that every key read here is present. *)
let of_pairs ~result ~check pairs =
  let get k = List.assoc k pairs in
  let* tree = tree_of (get "tree") in
  let* attempt = attempt_of (get "attempt") in
  let* config = Build_config.of_string (get "config") in
  let* rules = hash_of (get "rules") in
  let* mode = mode_of (get "mode") in
  let* confined = Confinement.of_field (get "confined") in
  let* seconds = seconds_of (get "seconds") in
  let* at = time_of (get "at") in
  let* machine, platform = where_ran get in
  v ~result ~check ~tree ~attempt ~config ~rules ~machine ~platform ~mode
    ~confined ~seconds ~at
    ?log:(List.assoc_opt "log" pairs)
    ()

let of_fields line =
  match String.split_on_char ' ' line with
  | _ :: result :: check :: fields ->
      let* result = result_of result in
      let* check = Check.name_of_string check in
      let* pairs = pairs line fields in
      of_pairs ~result ~check pairs
  | _ -> err "a %s line has too few fields: %S" schema line

let of_line line =
  match String.split_on_char ' ' line with
  | w :: _ when w <> schema -> Error (`Schema w)
  | _ -> (of_fields line :> (t, [ `Msg of string | `Schema of string ]) result)

type forgotten = {
  forgot : Check.name option;
  forgot_tree : Tree.t;
  forgot_by : Host.t;
  forgot_at : Ptime.t;
  set_aside : string list;
  reason : string option;
}

let digest r = Cas.Hash.to_hex (Cas.Hash.sha256 (to_line r))

let forgotten ?check ?reason ~tree ~machine ~at rs =
  let reason =
    match Option.map Outcome.line reason with
    | Some "" | None -> None
    | Some r -> Some r
  in
  let named (r : t) =
    Tree.equal r.tree tree
    && match check with None -> true | Some c -> Check.equal_name c r.check
  in
  {
    forgot = check;
    forgot_tree = tree;
    forgot_by = machine;
    forgot_at = at;
    set_aside =
      List.sort_uniq String.compare (List.map digest (List.filter named rs));
    reason;
  }

let forgot_word = "forgot"
let every_check = "*"

let forgotten_line f =
  Fmt.str "%s %s %s tree=%s machine=%s at=%s results=%s%s" schema forgot_word
    (match f.forgot with
    | Some c -> Check.string_of_name c
    | None -> every_check)
    (Tree.to_hex f.forgot_tree)
    (Host.to_string f.forgot_by)
    (Timestamp.Rfc3339.format f.forgot_at)
    (String.concat "," f.set_aside)
    (match f.reason with None -> "" | Some r -> " reason=" ^ r)

(* The reason is the rest of the line, spaces included. *)
let split_reason line =
  let tag = " reason=" in
  let n = String.length line and k = String.length tag in
  let rec find i =
    if i + k > n then (line, None)
    else if String.sub line i k = tag then
      (String.sub line 0 i, Some (String.sub line (i + k) (n - i - k)))
    else find (i + 1)
  in
  find 0

let forgotten_of_line line =
  let fields, reason = split_reason line in
  match String.split_on_char ' ' fields with
  | [ w; word; check; tree; machine; at; results ]
    when String.equal w schema && String.equal word forgot_word ->
      let value k f =
        match String.index_opt f '=' with
        | Some i when String.sub f 0 i = k ->
            Ok (String.sub f (i + 1) (String.length f - i - 1))
        | _ -> err "field %S of %S is not %s=" f line k
      in
      let* check =
        if String.equal check every_check then Ok None
        else Result.map Option.some (Check.name_of_string check)
      in
      let* tree = Result.bind (value "tree" tree) tree_of in
      let* machine = Result.bind (value "machine" machine) Host.of_string in
      let* at = Result.bind (value "at" at) time_of in
      let* results = value "results" results in
      let set_aside =
        List.filter (fun d -> d <> "") (String.split_on_char ',' results)
      in
      if List.for_all hex64 set_aside then
        Ok
          {
            forgot = check;
            forgot_tree = tree;
            forgot_by = machine;
            forgot_at = at;
            set_aside;
            reason;
          }
      else err "the results of %S are not SHA-256 digests" line
  | _ -> err "not a %s line: %S" forgot_word line

let forgotten_check f = f.forgot
let forgotten_tree f = f.forgot_tree
let forgotten_reason f = f.reason
let forgotten_count f = List.length f.set_aside

(* A result's line names its tree, so its digest does too. *)
let sets_aside f r = List.mem (digest r) f.set_aside

(* A line of a schema this mq replaced is no result and no line it cannot
   read: it is the record it was, read no further. *)
let of_earlier l =
  match String.index_opt l ' ' with
  | Some i -> List.mem (String.sub l 0 i) earlier
  | None -> false

(* An mq1 line is an mq2 line without the platform, which follows the
   machine. *)
let upgrade ~machine ~platform line =
  match String.split_on_char ' ' line with
  | "mq1" :: result :: check :: fields -> (
      let ran = "machine=" ^ Host.to_string machine in
      match List.find_opt (String.starts_with ~prefix:"machine=") fields with
      | None -> err "the %s line %S names no machine" "mq1" line
      | Some m when not (String.equal m ran) ->
          err "the %s line %S ran on %s, not on %a" "mq1" line
            (String.sub m 8 (String.length m - 8))
            Host.pp machine
      | Some _ ->
          let fields =
            List.concat_map
              (fun f ->
                if String.equal f ran then
                  [ f; "platform=" ^ Platform_name.to_field platform ]
                else [ f ])
              fields
          in
          let line = String.concat " " (schema :: result :: check :: fields) in
          let* r = of_fields line in
          Ok (Some (to_line r)))
  | _ -> Ok None

let of_note text =
  String.split_on_char '\n' text
  |> List.filter (fun l -> String.trim l <> "" && not (of_earlier l))
  |> List.fold_left
       (fun (ok, forgot, bad) l ->
         match of_line l with
         | Ok r -> (r :: ok, forgot, bad)
         | Error _ -> (
             match forgotten_of_line l with
             | Ok f -> (ok, f :: forgot, bad)
             | Error _ -> (ok, forgot, l :: bad)))
       ([], [], [])
  |> fun (ok, forgot, bad) ->
  ( List.filter
      (fun r -> not (List.exists (fun f -> sets_aside f r) forgot))
      (List.rev ok),
    List.rev bad )

let only_about tree text =
  String.split_on_char '\n' text
  |> List.filter (fun l -> String.trim l <> "")
  |> List.mapi (fun i l -> (i + 1, l))
  |> List.filter (fun (_, l) -> not (of_earlier l))
  |> List.fold_left
       (fun acc (n, l) ->
         let* () = acc in
         let about t =
           if Tree.equal t tree then Ok ()
           else
             err "line %d of the note of %a names another tree" n Tree.pp tree
         in
         match of_line l with
         | Ok r -> about r.tree
         | Error _ -> (
             match forgotten_of_line l with
             | Ok f -> about f.forgot_tree
             | Error _ ->
                 err "line %d of the note of %a is an unreadable %s line" n
                   Tree.pp tree schema))
       (Ok ())

let union rs =
  List.map to_line rs
  |> List.sort_uniq String.compare
  |> List.map (fun l -> l ^ "\n")
  |> String.concat ""

let commit_title = "mq: a check result"
let commit_message r = Fmt.str "%s\n\n%s\n" commit_title (to_line r)

let is_commit_message m =
  match String.index_opt m '\n' with
  | Some i -> String.equal (String.sub m 0 i) commit_title
  | None -> String.equal m commit_title

let forgotten_title = "mq: check results forgotten"

let forgotten_message f =
  Fmt.str "%s\n\n%s\n" forgotten_title (forgotten_line f)

let equal a b =
  Check.equal_result a.result b.result
  && Check.equal_name a.check b.check
  && Tree.equal a.tree b.tree && a.attempt = b.attempt
  && Build_config.equal a.config b.config
  && Commit.equal a.rules b.rules
  && Host.equal a.machine b.machine
  && Platform_name.equal a.platform b.platform
  && a.mode = b.mode && a.confined = b.confined
  && Duration.equal a.seconds b.seconds
  && Ptime.equal (Ptime.truncate ~frac_s:0 a.at) (Ptime.truncate ~frac_s:0 b.at)
  && Option.equal String.equal a.log b.log

let pp ppf r = Fmt.string ppf (to_line r)