Source file cstruct_append.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
(* XXX(dinosaure): this implementation is specialised to be used by
   [Git.Mem] and [Smart_git]. So we can rely on one assumption, we will
   create only 2 "objects"/"files":
   - a temporary object
   - the destination object

   In this context, [t] can stores only 2 objects. We should extend the
   implementation to be more general but the trade-off is bad. *)

let src = Logs.Src.create "git-cstruct-append"

module Log = (val Logs.src_log src : Logs.LOG)

type 'a rd = < rd : unit ; .. > as 'a
type 'a wr = < wr : unit ; .. > as 'a

type 'a mode =
  | Rd : < rd : unit > mode
  | Wr : < wr : unit > mode
  | RdWr : < rd : unit ; wr : unit > mode

type uid = < >

module Ephemeron = Ephemeron.K1.Make (struct
  type t = uid

  let equal = ( = )
  let hash = Hashtbl.hash
end)

type t = { storage : (bool * Cstruct.t ref) Ephemeron.t; mutable which : bool }
type +'a fiber = 'a Lwt.t
type error = |

let pp_error : error Fmt.t = fun _ppf -> function _ -> .
let device () = { storage = Ephemeron.create 2; which = true }
let empty = Cstruct.create 0

let key device =
  let file = object end in
  Ephemeron.add device.storage file (device.which, ref empty);
  device.which <- not device.which;
  file

type 'a fd = {
  mutable buffer : Cstruct.t;
  mutable capacity : int;
  mutable length : int;
  uid : Ephemeron.key;
}

let enlarge fd more =
  Log.debug (fun m ->
      m "Start to enlarge the given buffer (+ %d byte(s))." more);
  let _old_length = fd.length in
  let old_capacity = fd.capacity in
  let new_capacity = ref old_capacity in
  Log.debug (fun m ->
      m "Current capacity of the given buffer: %d byte(s)." old_capacity);
  while old_capacity + more > !new_capacity do
    new_capacity := 2 * !new_capacity
  done;
  Log.debug (fun m ->
      m "old capacity: %d, new capacity: %d." old_capacity !new_capacity);
  if !new_capacity > Sys.max_string_length then
    if old_capacity + more <= Sys.max_string_length then
      new_capacity := Sys.max_string_length
    else failwith "Too big buffer";
  let new_buffer = Cstruct.create !new_capacity in
  Cstruct.blit fd.buffer 0 new_buffer 0 fd.length;
  fd.buffer <- new_buffer;
  fd.capacity <- !new_capacity;
  (* XXX(dinosaure): these asserts wants to rely on some assumptions
     even if we use [enlarge] into a preemptive thread as [Stdlib.Buffer].
     However, with [lwt], it should be fine to use it and avoid these
     assertions. *)
  (* assert (fd.position + more <= fd.capacity) ; *)
  (* assert (old_length + more <= fd.capacity) ; *)
  ()

(* XXX(dinosaure): use [Cstruct_cap]? I think we must prove capabilities
 * with [Refl]. *)
let create ?(trunc = true) ~mode:_ { storage; _ } uid =
  let which, value = Ephemeron.find storage uid in

  let value =
    if Cstruct.length !value < 1 then (
      let v = Cstruct.create 1 in
      value := v;
      v)
    else !value
  in

  Log.debug (fun m ->
      m "Make a new file-descriptor (%b) (%d byte(s))." which
        (Cstruct.length value));
  let fd =
    {
      buffer = value;
      capacity = Cstruct.length value;
      length = (if trunc then 0 else Cstruct.length value);
      uid;
    }
  in
  Lwt.return_ok fd

let append _ fd str =
  let len = String.length str in
  let new_length = fd.length + len in
  if new_length > fd.capacity then enlarge fd len;
  Cstruct.blit_from_string str 0 fd.buffer fd.length len;
  fd.length <- new_length;
  Log.debug (fun m -> m "Append + %d byte(s)." fd.length);
  Lwt.return ()

let map _ fd ~pos len =
  Log.debug (fun m -> m "map on fd(length:%d) ~pos:%Ld %d." fd.length pos len);
  let pos = Int64.to_int pos in
  if pos > Cstruct.length fd.buffer then Bigstringaf.empty
  else
    let len = min len (Cstruct.length fd.buffer - pos) in
    let { Cstruct.buffer; off; _ } = fd.buffer in
    let res = Bigstringaf.sub ~off:(off + pos) ~len buffer in
    res

let close device fd =
  let result = Cstruct.sub fd.buffer 0 fd.length in
  Log.debug (fun m ->
      m "Close the object into the cstruct-append heap (save %d bytes)"
        fd.length);
  let _, cell = Ephemeron.find device.storage fd.uid in
  cell := result;
  Lwt.return_ok ()

let move device ~src ~dst =
  Log.debug (fun m -> m "Start to move a key to another.");
  if src == dst then Lwt.return_ok ()
  else
    let a, srcv = Ephemeron.find device.storage src in
    let b, dstv = Ephemeron.find device.storage dst in
    assert (a <> b);
    let tmpv = !srcv in
    srcv := !dstv;
    dstv := tmpv;
    Lwt.return_ok ()

let project device uid =
  let _, cell = Ephemeron.find device.storage uid in
  !cell