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 ;
}
let pp ppf t =
Format.fprintf ppf "repository %s: %s" t.basedir t.description
type r_err = [
| `NotFound of typ * name
| `ParseError of typ * name * string
| `NameMismatch of typ * name * name
| `InvalidPath of identifier * path
]
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
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