type hooks = {
  dir : Check.place;
  own : Fpath.t;
  existing : string option;
  calls_mq : bool;
}

type past = Never | Ran of Commit.t option

(* A landing into the rules branch reads the rules it moved the branch to:
   its notes name the rules it replaced, which a repair was judged under. *)
let last_rules ~rules_branch events =
  let newest best ((at, _) as read) =
    match best with
    | Some (b, _) when Ptime.compare b at >= 0 -> best
    | _ -> Some read
  in
  List.fold_left
    (fun best (e : Event.t) ->
      match e.kind with
      | Landed (_, l) when Branch.equal l.target rules_branch ->
          newest best (e.time, l.landed)
      | Landed (_, l) ->
          List.fold_left
            (fun best (n : Note.t) -> newest best (n.at, n.rules))
            best l.checks
      | _ -> best)
    None events
  |> Option.map snd

let gone ?branch ~rules_branch = function
  | Some c ->
      Outcome.v ?branch
        ~next:(Fmt.str "git branch %a %a" Branch.pp rules_branch Commit.pp c)
        Outcome.Refused
        (Fmt.str "%a is gone; the rules last read here were at %a" Branch.pp
           rules_branch Commit.pp c)
  | None ->
      Outcome.v ?branch ~next:"mq init" Outcome.Refused
        (Fmt.str
           "%a is gone, though mq has run here, and no note names the rules \
            last read here"
           Branch.pp rules_branch)

type facts = {
  head : Branch.t option;
  born : bool;
  head_remote : string option;
  rules_branch : Branch.t;
  local : (Commit.t * string) option;
  remotes : (string * (Commit.t * string) option) list;
  hook : bool;
  files : string list;
  makefile_check : bool;
  root : Fpath.t;
  hooks : hooks;
  mq : Fpath.t;
  past : past option;
}

(* Dune's root rule: a dune-workspace, then a dune-project, marks a project's
   root. *)
let dune_roots = [ "dune-workspace"; "dune-project" ]

let detect f =
  let has n = List.mem n f.files in
  let command c = Some (Check.v (Check.name "build") (Check.Command c)) in
  if f.hook then
    Some (Check.v (Check.name "pre-commit") (Check.Hook Check.Commit))
  else if List.exists has dune_roots then command "dune build @check"
  else if has "Cargo.toml" then command "cargo check"
  else if has "go.mod" then command "go vet ./..."
  else if has "Makefile" && f.makefile_check then command "make check"
  else None

let pull_remote f =
  match f.head_remote with
  | Some "." -> None
  | Some r -> Some r
  | None -> Some "origin"

let hook_line ~mq =
  let mq = Shell.word (Fpath.to_string mq) in
  Fmt.str
    "test -x %s && %s hook reference-transaction \"$@\" >/dev/null 2>&1 || :" mq
    mq

let marker = "# mq init wrote this hook."

(* Git runs the hook at every phase of every transaction. mq hook acts on a
   probe of mq init or mq doctor, in any phase, and on a branch a committed
   transaction moved (Registration.woken), so the script reads Git's lines
   ("<old> SP <new> SP <ref>", githooks(5)) with the shell's own read, starts
   no process for any other transaction, and hands mq the lines it read. *)
let hook_filter =
  {|input=
act=
while read -r old new ref || [ -n "$old" ]; do
  input="$input$old $new $ref
"
  case "$1:$ref" in
  *:refs/mq/probe/*) act=1 ;;
  committed:refs/heads/*) [ "$old" = "$new" ] || act=1 ;;
  esac
done
[ -n "$act" ] || exit 0
exec <<EOF
$input
EOF
|}

let hook_script ~mq =
  Fmt.str
    "#!/bin/sh\n\
     %s It tells mq that a ref moved, and never refuses the update.\n\
     %s%s\n"
    marker hook_filter (hook_line ~mq)

let ours contents = String.starts_with ~prefix:("#!/bin/sh\n" ^ marker) contents
let only_line = "# mq: this hook only tells mq that a ref moved."

(* A line of the hook that holds the declaration and nothing more but blanks:
   a hook saved with CRLF ends of line still carries it. *)
let only_mq contents =
  ours contents
  || List.exists
       (fun l -> String.equal (String.trim l) only_line)
       (String.split_on_char '\n' contents)

let clone_directory url =
  let strip_suffix suffix s =
    if String.ends_with ~suffix s then
      String.sub s 0 (String.length s - String.length suffix)
    else s
  in
  let rec strip_slashes s =
    if String.ends_with ~suffix:"/" s then
      strip_slashes (String.sub s 0 (String.length s - 1))
    else s
  in
  let s = strip_slashes (String.trim url) in
  let s = strip_slashes (strip_suffix "/.git" s) in
  let s = strip_suffix ".git" s in
  let after c s =
    match String.rindex_opt s c with
    | Some i -> String.sub s (i + 1) (String.length s - i - 1)
    | None -> s
  in
  let base = after ':' (after '/' s) in
  match Fpath.of_string base with
  | Ok d when Fpath.is_seg base && (not (Fpath.is_rel_seg base)) && base <> ""
    ->
      Ok d
  | _ -> Fmt.error_msg "%S names no directory to clone into" url

(* {1 The machine} *)

type event =
  | Read of facts
  | Answered of (string * (Commit.t * string) option) list
  | Unreachable of { remote : string; why : string }
  | Unsupported of { remote : string; why : string }
  | Untrusted of { remote : string; why : string }
  | Created of Commit.t
  | Create_raced
  | Adopted
  | Tracked of Branch.t option
  | Hook_installed
  | Hook_raced
  | Signalled of Signal.t
  | Unanswered of action * Machine.unanswered

and action =
  | Read_facts
  | Ask of { remotes : string list; branch : Branch.t }
  | Create_rules of {
      branch : Branch.t;
      content : string;
      message : string;
      reflog : string;
    }
  | Adopt of { branch : Branch.t; remote : string; commit : Commit.t }
  | Track of { branch : Branch.t; remote : string }
  | Install_hook of {
      path : Fpath.t;
      content : string;
      replacing : string option;
    }

type hook_plan =
  | Install of { path : Fpath.t; content : string; replacing : string option }
  | Installed
  | Calls_mq of Fpath.t
  | Not_ours of { why : string; path : Fpath.t }

let hook_name = "reference-transaction"

let hook_plan (hooks : hooks) ~mq =
  let content = hook_script ~mq in
  let theirs why path =
    if hooks.calls_mq then Calls_mq path else Not_ours { why; path }
  in
  match hooks.dir with
  | Check.On_machine d when Fpath.equal d hooks.own -> (
      let path = Fpath.(d / hook_name) in
      match hooks.existing with
      | None -> Install { path; content; replacing = None }
      | Some s when String.equal s content -> Installed
      | Some s when ours s -> Install { path; content; replacing = Some s }
      | Some _ -> theirs "the repository has one of its own" path)
  | Check.In_tree d ->
      theirs
        (Fmt.str "core.hooksPath names %a, in the work tree" Fpath.pp d)
        Fpath.(d / hook_name)
  | Check.On_machine d ->
      theirs
        (Fmt.str "core.hooksPath names %a" Fpath.pp d)
        Fpath.(d / hook_name)

let pp_hook ~mq ppf = function
  | Calls_mq path ->
      Fmt.pf ppf "the reference-transaction hook is installed: %a calls mq"
        Fpath.pp path
  | Not_ours { why; path } ->
      Fmt.pf ppf
        "the reference-transaction hook is not installed: %s; add this line to \
         %a: %s"
        why Fpath.pp path (hook_line ~mq)
  | Installed -> Fmt.string ppf "the reference-transaction hook is installed"
  | Install _ ->
      Fmt.string ppf "the reference-transaction hook is not installed"

(* Where the rules in force come from. A remote's copy is adopted whether
   its rules load or not, the reason they do not in [Error]. *)
type source =
  | Unchanged of Rules.t
  | Create of Rules.t
  | Adopt_from of {
      remote : string;
      commit : Commit.t;
      rules : (Rules.t, string) result;
    }

type plan = {
  facts : facts;
  source : source;
  hook : hook_plan;
  tracked : Branch.t list;  (** The branches created, tracking the remote's. *)
}

type phase =
  | Reading
  | Asking of facts
  | Writing of { plan : plan; pending : action list }
  | Done of (Report.t, Outcome.t) result

type ending = (Report.t, Outcome.t) result
type t = { phase : phase; fetch : bool }

let machine = "init"
let v ?(fetch = true) () = ({ phase = Reading; fetch }, [ Read_facts ])

let pp ppf t =
  Fmt.pf ppf "init: %s"
    (match t.phase with
    | Reading -> "reading"
    | Asking _ -> "asking the remotes"
    | Writing _ -> "writing"
    | Done _ -> "done")

let pp_event ppf = function
  | Read _ -> Fmt.string ppf "facts read"
  | Answered _ -> Fmt.string ppf "the remotes answered"
  | Unreachable { remote; _ } -> Fmt.pf ppf "%s did not answer" remote
  | Unsupported { remote; _ } -> Fmt.pf ppf "%s is not reachable by mq" remote
  | Untrusted { remote; _ } ->
      Fmt.pf ppf "the SSH session to %s was refused" remote
  | Created h -> Fmt.pf ppf "rules created at %s" (Commit.to_hex h)
  | Create_raced -> Fmt.string ppf "rules created by another hand"
  | Adopted -> Fmt.string ppf "rules adopted"
  | Tracked (Some b) -> Fmt.pf ppf "%a created" Branch.pp b
  | Tracked None -> Fmt.string ppf "nothing to create"
  | Hook_installed -> Fmt.string ppf "hook installed"
  | Hook_raced -> Fmt.string ppf "a hook appeared meanwhile"
  | Signalled sg -> Fmt.pf ppf "signalled %a" Signal.pp sg
  | Unanswered (_, why) -> Fmt.pf ppf "unanswered: %a" Machine.pp_unanswered why

let pp_action ppf = function
  | Read_facts -> Fmt.string ppf "read the facts"
  | Ask { remotes; branch } ->
      Fmt.pf ppf "ask %a for %a"
        Fmt.(list ~sep:(any ", ") string)
        remotes Branch.pp branch
  | Create_rules { branch; _ } -> Fmt.pf ppf "create %a" Branch.pp branch
  | Adopt { branch; remote; _ } ->
      Fmt.pf ppf "adopt %s/%a" remote Branch.pp branch
  | Track { branch; remote } ->
      Fmt.pf ppf "set %a up from %s/%a" Branch.pp branch remote Branch.pp branch
  | Install_hook { path; _ } -> Fmt.pf ppf "install %a" Fpath.pp path

let unexpected t e =
  Machine.unexpected machine ~state:(Fmt.str "%a" pp t)
    ~event:(Fmt.str "%a" pp_event e)

let finish o = Ok (Done o, [])

(* The ending of a cause mq doctor reports with its remedy. *)
let err_diagnosed fmt = Fmt.kstr (fun d -> Error (Outcome.diagnosed d)) fmt
let unavailable detail = finish (Error (Outcome.v Outcome.Unavailable detail))

let refused ?next detail =
  finish (Error (Outcome.v ?next Outcome.Refused detail))

let report plan rules =
  let hook =
    match plan.hook with
    | (Calls_mq _ | Not_ours _) as h ->
        Fmt.str "; %a" (pp_hook ~mq:plan.facts.mq) h
    | Install _ | Installed -> ""
  in
  let branch = plan.facts.rules_branch in
  match plan.source with
  | Unchanged _ ->
      Report.v
        ~detail:("already set up, " ^ Rules.summary rules ^ hook)
        Report.Unchanged (Branch.to_string branch)
  | Create _ ->
      Report.v
        ~detail:(Rules.summary rules ^ hook)
        Report.Created (Branch.to_string branch)
  | Adopt_from { remote; _ } ->
      let tracked =
        Report.tracking ~remote (List.map Branch.to_string plan.tracked)
        |> Option.fold ~none:"" ~some:(fun c -> "; " ^ c)
      in
      Report.v
        ~detail:(Rules.summary rules ^ tracked ^ hook)
        Report.Adopted
        (Fmt.str "%s/%a" remote Branch.pp branch)

(* The writes of a plan, in order: the rules, with each branch of the DAG an
   adopted remote holds set up from it, then the hook. *)
let writes plan =
  let f = plan.facts in
  let rules =
    match plan.source with
    | Unchanged _ -> []
    | Create rules ->
        let head = Option.value f.head ~default:f.rules_branch in
        [
          Create_rules
            {
              branch = f.rules_branch;
              content = Rules.to_string rules;
              message =
                Fmt.str "mq init: the rules, with the DAG %a" Branch.pp head;
              reflog = "mq init: created";
            };
        ]
    | Adopt_from { remote; commit; rules } ->
        (* Rules that do not load name no branch to set up. *)
        let named =
          match rules with Ok r -> Rules.literals r | Error _ -> []
        in
        Adopt { branch = f.rules_branch; remote; commit }
        :: List.filter_map
             (fun branch ->
               if Branch.equal branch f.rules_branch then None
               else Some (Track { branch; remote }))
             named
  in
  let hook =
    match plan.hook with
    | Install { path; content; replacing } ->
        [ Install_hook { path; content; replacing } ]
    | Installed | Calls_mq _ | Not_ours _ -> []
  in
  rules @ hook

(* Rules adopted that do not load end the call with the doctor's next, which
   names the land into the rules branch that fixes them. *)
let ending plan =
  match plan.source with
  | Unchanged rules | Create rules | Adopt_from { rules = Ok rules; _ } ->
      Ok (report plan rules)
  | Adopt_from { remote; rules = Error why; _ } ->
      err_diagnosed "adopted %s/%a, whose rules do not load: %s" remote
        Branch.pp plan.facts.rules_branch why

let next plan pending =
  match pending with
  | [] -> finish (ending plan)
  | a :: rest -> Ok (Writing { plan; pending = rest }, [ a ])

let planned f source =
  let plan =
    { facts = f; source; hook = hook_plan f.hooks ~mq:f.mq; tracked = [] }
  in
  next plan (writes plan)

let decide f =
  let load (commit, content) =
    let file = Fmt.str "mq.toml at %a" Commit.pp commit in
    Result.map_error (fun (`Msg m) -> m) (Rules.of_string ~file content)
  in
  let remote =
    Option.bind (pull_remote f) (fun r ->
        Option.map (fun c -> (r, c)) (Option.join (List.assoc_opt r f.remotes)))
  in
  match (f.local, remote) with
  | Some local, _ -> (
      match load local with
      | Ok rules -> planned f (Unchanged rules)
      | Error why ->
          finish
            (err_diagnosed "%a holds rules that do not load: %s" Branch.pp
               f.rules_branch why))
  | None, Some (r, ((commit, _) as copy)) ->
      planned f (Adopt_from { remote = r; commit; rules = load copy })
  | None, None -> (
      match (f.past, f.head) with
      | Some (Ran (Some _ as last)), _ ->
          finish (Error (gone ~rules_branch:f.rules_branch last))
      | _, None ->
          refused "HEAD names no branch, so the rules have no branch to name"
      | _, Some head when not f.born ->
          Fmt.kstr
            (refused ~next:"git commit")
            "%a has no commit yet" Branch.pp head
      | _, Some head -> planned f (Create (Rules.initial head (detect f))))

(* With no rules here, every remote is asked for its copy before any is
   created: a clone of one branch has no remote-tracking copy to read.
   Without fetching, the remote-tracking copies Git already holds decide. *)
let ask ~fetch f =
  match (fetch, f.local, f.remotes) with
  | true, None, (_ :: _ as remotes) ->
      Ok
        ( Asking f,
          [ Ask { remotes = List.map fst remotes; branch = f.rules_branch } ] )
  | _ -> decide f

let step t e =
  match (t.phase, e) with
  | Reading, Read f -> ask ~fetch:t.fetch f
  | Asking f, Answered copies -> decide { f with remotes = copies }
  | Asking f, Unreachable { remote; why } ->
      Fmt.kstr unavailable
        "%s did not answer for %a, so no rules are created beside its own: %s; \
         mq init --no-fetch decides on the copies Git holds here"
        remote Branch.pp f.rules_branch why
  | Asking f, (Unsupported { remote; why } | Untrusted { remote; why }) ->
      Fmt.kstr refused "%s: %s, so no rules are created beside its own %a"
        remote why Branch.pp f.rules_branch
  | Writing { plan; pending }, (Created _ | Adopted | Hook_installed) ->
      next plan pending
  | Writing { plan; pending }, Tracked b ->
      next { plan with tracked = plan.tracked @ Option.to_list b } pending
  | Writing _, Create_raced -> Ok (Reading, [ Read_facts ])
  | Writing { plan; pending }, Hook_raced ->
      let path =
        match plan.hook with
        | Install { path; _ } -> path
        | Installed | Calls_mq _ | Not_ours _ ->
            Fpath.(plan.facts.hooks.own / hook_name)
      in
      next
        {
          plan with
          hook = Not_ours { why = "the repository has one of its own"; path };
        }
        pending
  | Done _, _ -> Ok (t.phase, [])
  | _, Signalled _ ->
      finish (Error (Outcome.v Outcome.Interrupted "interrupted"))
  | _, Unanswered (_, why) ->
      Fmt.kstr unavailable "%a" Machine.pp_unanswered why
  | ( (Reading | Asking _ | Writing _),
      ( Read _ | Answered _ | Unreachable _ | Unsupported _ | Untrusted _
      | Created _ | Create_raced | Adopted | Tracked _ | Hook_installed
      | Hook_raced ) ) ->
      unexpected t e

let incoming t ~now:_ e =
  Result.map (fun (phase, actions) -> ({ t with phase }, actions)) (step t e)

let ending t = match t.phase with Done r -> Some r | _ -> None
let timer t ~now:_ = Ok (t, [])
let next_timeout (_ : t) = None
let task (_ : action) = Machine.Task.Now
let unanswered a why = Unanswered (a, why)
let signal s = Signalled s