<commit_before>open Stdune
open Utils

type memory = {root: Path.t; log: Log.t}

type key = Digest.t

type metadata = Sexp.t

type promotion =
  | Already_promoted of Path.t * Path.t
  | Promoted of Path.t * Path.t
  | Hash_mismatch of Path.t * Digest.t * Digest.t

let compare a b : ordering =
  let a = Path.to_string a and b = Path.to_string b in
  let lena = String.length a and lenb = String.length b in
  let len = min lena lenb in
  let rec loop i =
    if i = len then Int.compare lena lenb
    else
      match Char.compare a.[i] b.[i] with
      | 0 ->
          loop (i + 1)
      | x when x < 0 ->
          Ordering.Lt
      | _ ->
          Ordering.Gt
  in
  loop 0

let key consumed metadata produced =
  let consumed =
    List.sort ~compare:(fun (p1, _) (p2, _) -> compare p1 p2) consumed
  and produced = List.sort ~compare produced in
  let key =
    Sexp.List
      [ Sexp.List
          (List.map
             ~f:(fun (p, h) ->
               Sexp.List
                 [Sexp.Atom (Path.to_string p); Sexp.Atom (Digest.to_string h)]
               )
             consumed)
      ; metadata
      ; Sexp.List
          (List.map ~f:(fun p -> Sexp.Atom (Path.to_string p)) produced) ]
  in
  Digest.string (Csexp.to_string_canonical key)

let key_to_string = Digest.to_string

let key_of_string = Digest.from_hex

let promotion_to_string = function
  | Already_promoted (original, promoted) ->
      Printf.sprintf "%s already promoted as %s" (Path.to_string original)
        (Path.to_string promoted)
  | Promoted (original, promoted) ->
      Printf.sprintf "%s promoted as %s" (Path.to_string original)
        (Path.to_string promoted)
  | Hash_mismatch (original, expected, effective) ->
      Printf.sprintf "hash for %s mismatch: expected %s got %s"
        (Path.to_string original)
        (Digest.to_string expected)
        (Digest.to_string effective)

exception Failed = Utils.Failed

let concat p f = Path.of_string (Filename.concat (Path.to_string p) f)

let path_files memory = concat memory.root "files"

let path_meta memory = concat memory.root "meta"

let path_tmp memory = concat memory.root "temp"

let make ?log
    ?(root =
      Path.append (Path.of_string Xdg.cache_dir) (Path.of_string "dune/db")) ()
    =
  let root = concat root "v2" in
  {root; log= (match log with Some log -> log | None -> Log.no_log)}

(* How to handle collisions. E.g. another version could assume collisions are not possible *)
module Collision = struct
  type res = Found of Path.t | Not_found of Path.t

  (* We need to ensure we do not create holes in the suffix numbering for this to work *)
  let search path file =
    let rec loop n =
      let path = Path.extend_basename path ~suffix:("." ^ string_of_int n) in
      if Sys.file_exists (Path.to_string path) then
        if Io.compare_files path file == Ordering.Eq then Found path
        else loop (n + 1)
      else Not_found path
    in
    loop 1
end

(* Where to store file with a given hash. In this case ab/abcdef. *)
module FSScheme = struct
  let path root hash =
    let hash = Digest.to_string hash in
    let short_hash = String.sub hash ~pos:0 ~len:2 in
    List.fold_left ~f:concat ~init:root [short_hash; hash]
end

let search memory hash file =
  Collision.search (FSScheme.path (path_files memory) hash) file

let promote memory paths key metadata _ =
  let promote (path, expected_hash) =
    Log.infof memory.log "promote %s" (Path.to_string path) ;
    let hardlink path =
      let tmp = path_tmp memory in
      (* dune-memory uses a single writer model, the promoted file name can be constant *)
      let dest = concat tmp "promoting" in
      (let dest = Path.to_string dest in
       if Sys.file_exists dest then Unix.unlink dest else mkpath tmp ;
       Unix.link (Path.to_string path) dest) ;
      dest
    in
    let tmp = hardlink path in
    let effective_hash = Digest.file tmp in
    if Digest.compare effective_hash expected_hash != Ordering.Eq then (
      Log.infof memory.log "hash mismatch: %s != %s"
        (Digest.to_string effective_hash)
        (Digest.to_string expected_hash) ;
      Hash_mismatch (path, expected_hash, effective_hash) )
    else
      match search memory effective_hash tmp with
      | Collision.Found p -><commit_msg>Dune_memory: Fix `Path` usage.<commit_after>open Stdune
open Utils

type memory = {root: Path.t; log: Log.t}

type key = Digest.t

type metadata = Sexp.t

type promotion =
  | Already_promoted of Path.t * Path.t
  | Promoted of Path.t * Path.t
  | Hash_mismatch of Path.t * Digest.t * Digest.t

let compare a b : ordering =
  let a = Path.to_string a and b = Path.to_string b in
  let lena = String.length a and lenb = String.length b in
  let len = min lena lenb in
  let rec loop i =
    if i = len then Int.compare lena lenb
    else
      match Char.compare a.[i] b.[i] with
      | 0 ->
          loop (i + 1)
      | x when x < 0 ->
          Ordering.Lt
      | _ ->
          Ordering.Gt
  in
  loop 0

let key consumed metadata produced =
  let consumed =
    List.sort ~compare:(fun (p1, _) (p2, _) -> compare p1 p2) consumed
  and produced = List.sort ~compare produced in
  let key =
    Sexp.List
      [ Sexp.List
          (List.map
             ~f:(fun (p, h) ->
               Sexp.List
                 [Sexp.Atom (Path.to_string p); Sexp.Atom (Digest.to_string h)]
               )
             consumed)
      ; metadata
      ; Sexp.List
          (List.map ~f:(fun p -> Sexp.Atom (Path.to_string p)) produced) ]
  in
  Digest.string (Csexp.to_string_canonical key)

let key_to_string = Digest.to_string

let key_of_string = Digest.from_hex

let promotion_to_string = function
  | Already_promoted (original, promoted) ->
      Printf.sprintf "%s already promoted as %s" (Path.to_string original)
        (Path.to_string promoted)
  | Promoted (original, promoted) ->
      Printf.sprintf "%s promoted as %s" (Path.to_string original)
        (Path.to_string promoted)
  | Hash_mismatch (original, expected, effective) ->
      Printf.sprintf "hash for %s mismatch: expected %s got %s"
        (Path.to_string original)
        (Digest.to_string expected)
        (Digest.to_string effective)

exception Failed = Utils.Failed

let path_files memory = Path.L.relative memory.root ["files"]

let path_meta memory = Path.L.relative memory.root ["meta"]

let path_tmp memory = Path.L.relative memory.root ["temp"]

let make ?log
    ?(root = Path.L.relative (Path.of_string Xdg.cache_dir) ["dune"; "db"]) ()
    =
  let root = Path.L.relative root ["v2"] in
  {root; log= (match log with Some log -> log | None -> Log.no_log)}

(* How to handle collisions. E.g. another version could assume collisions are not possible *)
module Collision = struct
  type res = Found of Path.t | Not_found of Path.t

  (* We need to ensure we do not create holes in the suffix numbering for this to work *)
  let search path file =
    let rec loop n =
      let path = Path.extend_basename path ~suffix:("." ^ string_of_int n) in
      if Sys.file_exists (Path.to_string path) then
        if Io.compare_files path file == Ordering.Eq then Found path
        else loop (n + 1)
      else Not_found path
    in
    loop 1
end

(* Where to store file with a given hash. In this case ab/abcdef. *)
module FSScheme = struct
  let path root hash =
    let hash = Digest.to_string hash in
    let short_hash = String.sub hash ~pos:0 ~len:2 in
    Path.L.relative root [short_hash; hash]
end

let search memory hash file =
  Collision.search (FSScheme.path (path_files memory) hash) file

let promote memory paths key metadata _ =
  let promote (path, expected_hash) =
    Log.infof memory.log "promote %s" (Path.to_string path) ;
    let hardlink path =
      let tmp = path_tmp memory in
      (* dune-memory uses a single writer model, the promoted file name can be constant *)
      let dest = Path.L.relative tmp ["promoting"] in
      (let dest = Path.to_string dest in
       if Sys.file_exists dest then Unix.unlink dest else mkpath tmp ;
       Unix.link (Path.to_string path) dest) ;
      dest
    in
    let tmp = hardlink path in
    let effective_hash = Digest.file tmp in
    if Digest.compare effective_hash expected_hash != Ordering.Eq then (
      Log.infof memory.log "hash mismatch: %s != %s"
        (Digest.to_string effective_hash)
        (Digest.to_string expected_hash) ;
      Hash_mismatch (path, expected_hash, effective_hash) )
    else
      match search memory effective_hash tmp with
      | Collision.Found p ->
{'fraction_non_alphanumeric': 0.09392265193370165, 'fraction_numerical': 0.003056306571059128, 'mean_word_length': 2.595942519019442, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 27, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4306991', 'n_tokens_mistral': 2794, 'n_tokens_neox': 2755, 'n_words': 951}