package irmin-pack

  1. Overview
  2. Docs
package irmin-pack
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file io.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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
(*
 * Copyright (c) 2022-2023 Tarides <contact@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open! Import
open Io_intf
module Syscalls = Index_unix.Syscalls

(* File utils, taken from index.unix package.

   These functions need to read from a loop because the underlying
   implementation will not read/write more than a constant called
   [UNIX_BUFFER_SIZE]. *)
module Util = struct
  let really_write fd fd_offset buffer buffer_offset length =
    let rec aux fd_offset buffer_offset length =
      let w = Syscalls.pwrite ~fd ~fd_offset ~buffer ~buffer_offset ~length in
      if w = 0 || w = length then ()
      else
        (aux [@tailcall])
          Int63.Syntax.(fd_offset + Int63.of_int w)
          (buffer_offset + w) (length - w)
    in
    aux fd_offset buffer_offset length

  let really_read fd fd_offset length buffer =
    let rec aux fd_offset buffer_offset length =
      let r = Syscalls.pread ~fd ~fd_offset ~buffer ~buffer_offset ~length in
      if r = 0 then buffer_offset (* end of file *)
      else if r = length then buffer_offset + r
      else
        (aux [@tailcall])
          Int63.Syntax.(fd_offset + Int63.of_int r)
          (buffer_offset + r) (length - r)
    in
    aux fd_offset 0 length
end

module type S = S

module Unix = struct
  type misc_error = Unix.error * string * string

  let unix_error_t =
    Irmin.Type.(map string (fun _str -> assert false) Unix.error_message)

  let misc_error_t = Irmin.Type.(triple unix_error_t string string)

  type create_error = [ `Io_misc of misc_error | `File_exists of string ]

  type open_error =
    [ `Io_misc of misc_error
    | `No_such_file_or_directory of string
    | `Not_a_file ]

  type read_error =
    [ `Io_misc of misc_error
    | `Read_out_of_bounds
    | `Closed
    | `Invalid_argument ]

  type write_error = [ `Io_misc of misc_error | `Ro_not_allowed | `Closed ]
  type close_error = [ `Io_misc of misc_error | `Double_close ]

  type mkdir_error =
    [ `Io_misc of misc_error
    | `File_exists of string
    | `No_such_file_or_directory of string
    | `Invalid_parent_directory ]

  let raise_misc_error (x, y, z) = raise (Unix.Unix_error (x, y, z))

  let catch_misc_error f =
    try Ok (f ())
    with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))

  type t = {
    fd : Unix.file_descr;
    mutable closed : bool;
    readonly : bool;
    path : string;
  }

  let classify_path p =
    Unix.(
      try
        match (stat p).st_kind with
        | S_REG -> `File
        | S_DIR -> `Directory
        | _ -> `Other
      with _ -> `No_such_file_or_directory)

  let default_create_perm = 0o644
  let default_open_perm = 0o644
  let default_mkdir_perm = 0o755

  let create ~path ~overwrite =
    try
      match Sys.file_exists path with
      | false ->
          let fd =
            Unix.(
              openfile path
                [ O_CREAT; O_RDWR; O_EXCL; O_CLOEXEC ]
                default_create_perm)
          in
          Ok { fd; closed = false; readonly = false; path }
      | true -> (
          match overwrite with
          | true ->
              (* The file exists, truncate it and use it. An exception will be
                 triggered if we don't have the permissions *)
              let fd =
                Unix.(
                  openfile path
                    [ O_RDWR; O_CLOEXEC; O_TRUNC ]
                    default_create_perm)
              in
              Ok { fd; closed = false; readonly = false; path }
          | false -> Error (`File_exists path))
    with
    | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))
    | Sys_error _ -> assert false

  let open_ ~path ~readonly =
    match classify_path path with
    | `Directory | `Other -> Error `Not_a_file
    | `No_such_file_or_directory -> Error (`No_such_file_or_directory path)
    | `File -> (
        let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in
        try
          let fd = Unix.(openfile path [ mode; O_CLOEXEC ] default_open_perm) in
          Ok { fd; closed = false; readonly; path }
        with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))

  let close t =
    match t.closed with
    | true -> Error `Double_close
    | false -> (
        t.closed <- true;
        (* mark [t] as closed, even if [Unix.close] fails, since it is recommended
           to not retry after an error. see: https://man7.org/linux/man-pages/man2/close.2.html *)
        try
          Unix.close t.fd;
          Ok ()
        with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))

  let write_exn t ~off ~len s =
    if String.length s < len then raise (Errors.Pack_error `Invalid_argument);
    match (t.closed, t.readonly) with
    | true, _ -> raise Errors.Closed
    | _, true -> raise Errors.RO_not_allowed
    | _ ->
        (* Bytes.unsafe_of_string usage: s has shared ownership; we assume that
           Util.really_write does not mutate buf (i.e., only needs shared ownership). This
           usage is safe. *)
        let buf = Bytes.unsafe_of_string s in
        let () = Util.really_write t.fd off buf 0 len in
        Index.Stats.add_write len;
        ()

  let write_string t ~off s =
    let len = String.length s in
    try Ok (write_exn t ~off ~len s) with
    | Errors.Closed -> Error `Closed
    | Errors.RO_not_allowed -> Error `Ro_not_allowed
    | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))

  let fsync t =
    match (t.closed, t.readonly) with
    | true, _ -> Error `Closed
    | _, true -> Error `Ro_not_allowed
    | _ -> (
        try
          Unix.fsync t.fd;
          Ok ()
        with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))

  let read_exn t ~off ~len buf =
    if len > Bytes.length buf then raise (Errors.Pack_error `Invalid_argument);
    match t.closed with
    | true -> raise Errors.Closed
    | false ->
        let nread = Util.really_read t.fd off len buf in
        Index.Stats.add_read nread;
        if nread <> len then
          (* didn't manage to read the desired amount; in this case the interface seems to
             require we return `Read_out_of_bounds FIXME check this, because it is unusual
             - the normal API allows return of a short string *)
          raise (Errors.Pack_error `Read_out_of_bounds)

  let read_to_string t ~off ~len =
    let buf = Bytes.create len in
    try
      read_exn t ~off ~len buf;
      (* Bytes.unsafe_to_string usage: buf is local to this function, so uniquely
         owned. We assume read_exn returns unique ownership of buf to this function. Then
         at the call to Bytes.unsafe_to_string we give up unique ownership of buf for
         ownership of the string. This is safe. *)
      Ok (Bytes.unsafe_to_string buf)
    with
    | Errors.Pack_error ((`Invalid_argument | `Read_out_of_bounds) as e) ->
        Error e
    | Errors.Closed -> Error `Closed
    | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))

  let page_size = 4096

  let read_all_to_string t =
    let open Result_syntax in
    let* () = if t.closed then Error `Closed else Ok () in
    let buf = Buffer.create 0 in
    let len = page_size in
    let bytes = Bytes.create len in
    let rec aux ~off =
      let nread =
        Syscalls.pread ~fd:t.fd ~fd_offset:off ~buffer:bytes ~buffer_offset:0
          ~length:len
      in
      if nread > 0 then (
        Index.Stats.add_read nread;
        Buffer.add_subbytes buf bytes 0 nread;
        if nread = len then aux ~off:Int63.(add off (of_int nread)))
    in
    try
      aux ~off:Int63.zero;
      Ok (Buffer.contents buf)
    with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))

  let read_size t =
    match t.closed with
    | true -> Error `Closed
    | false -> (
        try Ok Unix.LargeFile.((fstat t.fd).st_size |> Int63.of_int64)
        with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))

  let size_of_path s =
    let open Result_syntax in
    let* io = open_ ~path:s ~readonly:true in
    let res =
      match read_size io with
      | Error `Closed -> assert false
      | Error (`Io_misc _) as x -> x
      | Ok _ as x -> x
    in
    match close io with
    | Error `Double_close -> assert false
    | Error (`Io_misc _) as x -> x
    | Ok () -> res

  let readonly t = t.readonly
  let path t = t.path

  let move_file ~src ~dst =
    try
      Sys.rename src dst;
      Ok ()
    with Sys_error msg -> Error (`Sys_error msg)

  let copy_file ~src ~dst =
    let cmd = Filename.quote_command "cp" [ "-p"; src; dst ] in
    match Sys.command cmd with
    | 0 -> Ok ()
    | n -> Error (`Sys_error (Int.to_string n))

  let mkdir path =
    match (classify_path (Filename.dirname path), classify_path path) with
    | `Directory, `No_such_file_or_directory -> (
        try
          Unix.mkdir path default_mkdir_perm;
          Ok ()
        with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)))
    | `Directory, (`File | `Directory | `Other) -> Error (`File_exists path)
    | `No_such_file_or_directory, `No_such_file_or_directory ->
        Error (`No_such_file_or_directory path)
    | _ -> Error `Invalid_parent_directory

  let unlink path =
    try
      Sys.remove path;
      Ok ()
    with Sys_error msg -> Error (`Sys_error msg)

  let unlink_dont_wait ~on_exn path =
    Lwt.dont_wait (fun () -> Lwt_unix.unlink path) on_exn
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct