package conex

  1. Overview
  2. Docs

Source file conex_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
open Conex_utils
open Conex_resource
open Conex_opam_encoding

type t = {
  basedir : string ;
  description : string ;
  file_type : path -> (file_type, string) result ;
  read : path -> (string, string) result ;
  write : path -> string -> (unit, string) result ;
  read_dir : path -> (item list, string) result ;
  exists : path -> bool ;
}

(*BISECT-IGNORE-BEGIN*)
let pp ppf t =
  Format.fprintf ppf "repository %s: %s" t.basedir t.description
(*BISECT-IGNORE-END*)

type r_err = [
  | `NotFound of typ * name
  | `ParseError of typ * name * string
  | `NameMismatch of typ * name * name
  | `InvalidPath of identifier * path
]

(*BISECT-IGNORE-BEGIN*)
let pp_r_err ppf = function
  | `NotFound (res, nam) -> Format.fprintf ppf "%a (type %a) was not found in repository" pp_name nam pp_typ res
  | `ParseError (res, n, e) -> Format.fprintf ppf "parse error while parsing %a (type %a): %s" pp_name n pp_typ res e
  | `NameMismatch (res, should, is) -> Format.fprintf ppf "%a (type %a) is named %a" pp_name should pp_typ res pp_name is
  | `InvalidPath (nam, path) -> Format.fprintf ppf "%a contains an invalid path %a" pp_id nam pp_path path
(*BISECT-IGNORE-END*)

let read_root t root_file =
  match t.read [ root_file ] with
  | Error _ -> Error (`NotFound (`Root, root_file))
  | Ok data ->
    match decode data >>= Root.of_wire with
    | Error p -> Error (`ParseError (`Root, root_file, p))
    | Ok (root, warn) ->
      guard (id_equal root.Root.name root_file)
        (`NameMismatch (`Root, root_file, root.Root.name)) >>= fun () ->
      Ok (root, warn)

let write_root t root =
  let id = root.Root.name in
  t.write [ id ] (encode (Root.wire root))

let targets t root =
  match t.read_dir root.Root.keydir with
  | Error e ->
    Printf.printf "failed while listing keys with %s\n" e ;
    []
  | Ok datas ->
    List.fold_left (fun acc -> function
        | File, name -> name :: acc
        | Directory, name ->
          Printf.printf "unexpected directory %s in keydir!" name ;
          acc)
      [] datas

let read_targets t root opam id =
  let path = root.Root.keydir @ [ id ] in
  match t.read path with
  | Error _ -> Error (`NotFound (`Targets, id))
  | Ok data ->
    match decode data >>= Targets.of_wire with
    | Error p -> Error (`ParseError (`Targets, id, p))
    | Ok (targets, warn) ->
      guard (id_equal targets.Targets.name id)
        (`NameMismatch (`Targets, id, targets.Targets.name)) >>= fun () ->
      let check_path t =
        if opam then
          guard (Target.valid_opam_path t) (`InvalidPath (id, t.Target.filename))
        else
          Ok ()
      in
      iterM check_path targets.Targets.targets >>= fun () ->
      Ok (targets, warn)

let write_targets t root targets =
  let path = root.Root.keydir @ [ targets.Targets.name ] in
  Printf.printf "writing %s\n" (path_to_string path) ;
  t.write path (encode (Targets.wire targets))

let digest_len f data =
  let digest = f data
  and size = Uint.of_int_exn (String.length data)
  in
  (digest, size)

let target f filename data =
  let digest, size = digest_len f data in
  { Target.digest = [ digest ] ; size ; filename }

let compute_checksum ?(prefix = [ "packages" ]) t opam f path =
  let rec compute_item prefix otherp acc = function
    | Directory, name ->
      let path = prefix @ [ name ] in
      t.read_dir path >>= fun items ->
      foldM (compute_item path (otherp @ [ name ])) acc items
    | File, name ->
      let filename = prefix @ [ name ] in
      t.read filename >>= fun data ->
      let target = target f (otherp @ [ name ]) data in
      if not opam || opam && Target.valid_opam_path target then
        Ok (target :: acc)
      else
        Error ("invalid path " ^ path_to_string filename)
  in
  let go pre name = compute_item (prefix @ pre) pre [] (Directory, name) in
  match List.rev path with
    | [] ->
      t.read_dir prefix >>= fun items ->
      foldM (fun acc e -> match e with
          | Directory, _ -> compute_item prefix [ ] acc e
          | File, _ -> Ok acc)
        [] items
    | [ name ] -> go [] name
    | name::rest -> go (List.rev rest) name


let compute_checksum_tree ?(prefix = [ "packages" ]) t f =
  let rec compute_item prefix otherp acc = function
    | Directory, name ->
      let path = prefix @ [ name ] in
      t.read_dir path >>= fun items ->
      foldM (compute_item path (otherp @ [ name ])) acc items
    | File, name ->
      let filename = prefix @ [ name ] in
      t.read filename >>= fun data ->
      let path = otherp @ [name] in
      let digestlen = digest_len f data in
      Ok (Tree.insert path digestlen acc)
  in
  t.read_dir prefix >>= fun items ->
  foldM (compute_item prefix []) Tree.empty items
OCaml

Innovation. Community. Security.