package dose3

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file stdLoaders.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
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
(**************************************************************************)
(*  This file is part of a library developed with the support of the      *)
(*  Mancoosi Project. http://www.mancoosi.org                             *)
(*                                                                        *)
(*  Main author(s):  Pietro Abate                                         *)
(*                                                                        *)
(*  This library is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version.  A special linking    *)
(*  exception to the GNU Lesser General Public License applies to this    *)
(*  library, see the COPYING file for more information.                   *)
(**************************************************************************)

open ExtLib
open Dose_common

include Util.Logging (struct
  let label = "doseparse.stdLoaders"
end)

let load_list_timer = Util.Timer.create "Load"

let deb_load_list_timer = Util.Timer.create "Load.Debian"

let deb_load_source_timer = Util.Timer.create "Load.DebianSource"

(* a list of the raw package types for all input except Cudf itself *)
(* currently, only Deb and DebSrc are used *)
type rawpackage =
  | Deb of Dose_debian.Packages.package
  | DebSrc of Dose_debian.Sources.source
  | Pef of Dose_pef.Packages.package
  | Opam of Dose_opam2.Packages.package
  | Npm of Dose_npm.Packages.package
  | Edsp of Dose_debian.Packages.package
  | Csw of Dose_opencsw.Packages.package

(** read a debian Packages file - compressed or not *)
let read_deb ?filter ?(extras = []) fname =
  Dose_debian.Packages.input_raw ?filter ~extras [fname]

(* fll = file list list
 * dll = deb packages list list
 * cll = cudf package list list
 *)
let deb_load_list options ?(status = []) ?(raw = false) dll =
  Util.Timer.start deb_load_list_timer ;
  let noindep = options.Dose_debian.Debcudf.drop_bd_indep in
  let noarch = options.Dose_debian.Debcudf.drop_bd_arch in
  let profiles = options.Dose_debian.Debcudf.profiles in
  let pkgll =
    List.map
      (List.map (function
          | Deb p -> p
          | DebSrc p ->
              if Option.is_none options.Dose_debian.Debcudf.native then
                fatal
                  "--deb-native-arch was not specified while treating Debian \
                   Sources File" ;
              let buildarch = Option.get options.Dose_debian.Debcudf.native in
              let hostarch = Option.get options.Dose_debian.Debcudf.host in
              Dose_debian.Sources.src2pkg
                ~noindep
                ~noarch
                ~profiles
                buildarch
                hostarch
                p
          | _ -> fatal "cannot handle input"))
      dll
  in
  let pkgl = List.flatten pkgll in
  let pkgl =
    if status = [] then pkgl else Dose_debian.Packages.merge status pkgl
  in
  let tables = Dose_debian.Debcudf.init_tables ~options pkgl in
  let from_cudf (p, i) = Dose_debian.Debcudf.get_real_version tables (p, i) in
  let to_cudf (p, v) =
    (p, Dose_debian.Debcudf.get_cudf_version tables (p, v))
  in
  let cll =
    List.map
      (fun l ->
        List.map
          (Dose_debian.Debcudf.tocudf tables ~options)
          (Dose_debian.Packages.merge status l))
      pkgll
  in
  (* if requested, connect all cudf packages representing binary packages to
   * the cudf packages representing the source package they each build from,
   * respectively *)
  let cll =
    if options.Dose_debian.Debcudf.builds_from then
      let univ =
        Cudf.load_universe
          (CudfAdd.Cudf_set.elements
             (List.fold_right
                (List.fold_right CudfAdd.Cudf_set.add)
                cll
                CudfAdd.Cudf_set.empty))
      in
      List.map2
        (List.map2 (fun cudfpkg debpkg ->
             match debpkg with
             | Deb _ ->
                 let srcpkg =
                   try Dose_debian.Sources.get_src_package univ cudfpkg
                   with Dose_debian.Sources.NotfoundSrc ->
                     failwith
                       (Printf.sprintf
                          "cannot find source for binary package %s"
                          (CudfAdd.string_of_package cudfpkg))
                 in
                 (* connect to source package as "builds-from" *)
                 let srcdep =
                   (srcpkg.Cudf.package, Some (`Eq, srcpkg.Cudf.version))
                 in
                 { cudfpkg with
                   Cudf.depends = [srcdep] :: cudfpkg.Cudf.depends
                 }
             | DebSrc _ -> cudfpkg
             | _ -> failwith "impossible"))
        cll
        dll
    else cll
  in
  let preamble = Dose_debian.Debcudf.preamble in
  let request = Cudf.default_request in
  let rawll = if raw && status = [] then Some dll else None in
  let global_constraints = Dose_debian.Debcudf.get_essential ~options tables in
  let l =
    (preamble, cll, request, from_cudf, to_cudf, rawll, global_constraints)
  in
  Util.Timer.stop deb_load_list_timer l

let npm_load_list file =
  let (_request, pkglist) = Dose_npm.Packages.input_raw file in
  let tables =
    Dose_pef.Pefcudf.init_tables Dose_versioning.SemverNode.compare pkglist
  in
  let from_cudf (p, i) = Dose_pef.Pefcudf.get_real_version tables (p, i) in
  let to_cudf (p, v) = (p, Dose_pef.Pefcudf.get_cudf_version tables (p, v)) in
  let cl = List.map (Dose_pef.Pefcudf.tocudf tables) pkglist in
  let preamble = Dose_npm.Npmcudf.preamble in
  let request = Cudf.default_request in
  (*
  let request = Dose_npm.Npmcudf.requesttocudf tables (Cudf.load_universe cl) request in
  *)
  (preamble, [cl; []], request, from_cudf, to_cudf, None, [])

let opam_load_list ?options file =
  let (request, pkglist) = Dose_opam2.Packages.input_raw file in
  let tables =
    Dose_pef.Pefcudf.init_tables Dose_versioning.Debian.compare pkglist
  in
  let from_cudf (p, i) = Dose_pef.Pefcudf.get_real_version tables (p, i) in
  let to_cudf (p, v) = (p, Dose_pef.Pefcudf.get_cudf_version tables (p, v)) in
  let options =
    match options with
    | None ->
        { Dose_opam2.Opamcudf.default_options with
          Dose_opam2.Opamcudf.switch = request.Dose_opam2.Packages.switch;
          switches = request.Dose_opam2.Packages.switches;
          profiles = request.Dose_opam2.Packages.profiles
        }
    | Some opt -> opt
  in
  let cl =
    List.flatten (List.map (Dose_opam2.Opamcudf.tocudf ~options tables) pkglist)
  in
  let preamble = Dose_opam2.Opamcudf.preamble in
  let request =
    Dose_opam2.Opamcudf.requesttocudf tables (Cudf.load_universe cl) request
  in
  (preamble, [cl; []], request, from_cudf, to_cudf, None, [])

let pef_load_list ?compare dll =
  let compare =
    match compare with Some c -> c | None -> Dose_versioning.Debian.compare
  in
  let extras = [("maintainer", ("maintainer", `String None))] in
  let pkglist = List.flatten dll in
  let tables = Dose_pef.Pefcudf.init_tables compare pkglist in
  let from_cudf (p, i) = Dose_pef.Pefcudf.get_real_version tables (p, i) in
  let to_cudf (p, v) = (p, Dose_pef.Pefcudf.get_cudf_version tables (p, v)) in
  let cll =
    List.map (fun l -> List.map (Dose_pef.Pefcudf.tocudf ~extras tables) l) dll
  in
  let preamble = Dose_pef.Pefcudf.preamble in
  let request = Cudf.default_request in
  (preamble, cll, request, from_cudf, to_cudf, None, [])

let csw_load_list dll =
  let pkglist = List.flatten dll in
  let tables = Dose_opencsw.Cswcudf.init_tables pkglist in
  let from_cudf (p, i) =
    (p, None, Dose_opencsw.Cswcudf.get_real_version tables (p, i))
  in
  let to_cudf (p, v) =
    (p, Dose_opencsw.Cswcudf.get_cudf_version tables (p, v))
  in
  let cll =
    List.map (fun l -> List.map (Dose_opencsw.Cswcudf.tocudf tables) l) dll
  in
  let preamble = Dose_opencsw.Cswcudf.preamble in
  let request = Cudf.default_request in
  (preamble, cll, request, from_cudf, to_cudf, None, [])

let edsp_load_list options file =
  let (request, pkglist) = Dose_debian.Edsp.input_raw file in
  let (native_arch, foreign_archs) =
    StdUtils.get_architectures
      request.Dose_debian.Edsp.architecture
      request.Dose_debian.Edsp.architectures
      options.Dose_debian.Debcudf.native
      (match options.Dose_debian.Debcudf.foreign with
      | [] -> None
      | l -> Some l)
  in
  let options =
    { options with
      Dose_debian.Debcudf.native = native_arch;
      Dose_debian.Debcudf.foreign = foreign_archs
    }
  in
  let tables = Dose_debian.Debcudf.init_tables ~options pkglist in
  let preamble =
    let l = List.map snd Dose_debian.Edsp.extras_tocudf in
    Dose_common.CudfAdd.add_properties Dose_debian.Debcudf.preamble l
  in
  let univ = Hashtbl.create ((2 * List.length pkglist) - 1) in
  let cudfpkglist =
    List.filter_map
      (fun pkg ->
        let p = Dose_debian.Edsp.tocudf tables ~options pkg in
        if not (Hashtbl.mem univ (p.Cudf.package, p.Cudf.version)) then (
          Hashtbl.add univ (p.Cudf.package, p.Cudf.version) pkg ;
          Some p)
        else (
          warning
            "Duplicated package (same version, name and architecture) : \
             (%s,%s,%s)"
            pkg#name
            pkg#version
            pkg#architecture ;
          None))
      pkglist
  in
  let request =
    Dose_debian.Edsp.requesttocudf
      tables
      (Cudf.load_universe cudfpkglist)
      request
  in
  let to_cudf (p, v) =
    (p, Dose_debian.Debcudf.get_cudf_version tables (p, v))
  in
  let from_cudf (p, i) = Dose_debian.Debcudf.get_real_version tables (p, i) in
  let global_constraints = Dose_debian.Debcudf.get_essential ~options tables in
  ( preamble,
    [cudfpkglist; []],
    request,
    from_cudf,
    to_cudf,
    None,
    global_constraints )

let edsp_load_universe options file =
  let (pr, l, r, f, t, w, e) = edsp_load_list options file in
  (pr, Cudf.load_universe (List.hd l), r, f, t, w, e)

(** transform a list of debian control stanza into a cudf universe *)
let deb_load_universe options ?(raw = false) l =
  let (pr, cll, r, f, t, w, e) = deb_load_list options ~raw l in
  (pr, Cudf.load_universe (List.flatten cll), r, f, t, w, e)

(** parse a cudf file and return a triple (preamble,package list,request
    option). If the package is not valid returns an empty list of packages *)
let parse_cudf doc =
  try
    let p = Cudf_parser.from_IO_in_channel (Input.open_file doc) in
    Cudf_parser.parse p
  with
  | Input.File_empty -> (None, [], None)
  | Cudf_parser.Parse_error (msg, loc) ->
      fatal
        "Error while parsing CUDF from %s (%s): %s"
        doc
        (Format822.string_of_loc loc)
        msg
  | Cudf.Constraint_violation _ as exn ->
      fatal "Error while loading CUDF from %s: %s" doc (Printexc.to_string exn)

(** parse a cudf file and return a triple (preamble,universe,request option).
    If the package is not valid return an empty list of packages *)
let load_cudf doc =
  let ch = Input.open_file doc in
  let l =
    try
      let p = Cudf_parser.from_IO_in_channel ch in
      Cudf_parser.load p
    with
    | Input.File_empty -> (None, Cudf.load_universe [], None)
    | Cudf_parser.Parse_error (msg, loc) ->
        fatal
          "Error while parsing CUDF from %s (%s): %s"
          doc
          (Format822.string_of_loc loc)
          msg
    | Cudf.Constraint_violation _ as exn ->
        fatal
          "Error while loading CUDF file %s:\n%s"
          doc
          (Printexc.to_string exn)
  in
  Input.close_ch ch ;
  l

let cudf_load_list file =
  let (preamble, pkglist, request) =
    match parse_cudf file with
    | (None, pkglist, None) ->
        (Cudf.default_preamble, pkglist, Cudf.default_request)
    | (None, pkglist, Some req) -> (Cudf.default_preamble, pkglist, req)
    | (Some p, pkglist, None) -> (p, pkglist, Cudf.default_request)
    | (Some p, pkglist, Some req) -> (p, pkglist, req)
  in
  let from_cudf (p, i) = (p, None, string_of_int i) in
  let to_cudf (p, v) = (p, int_of_string v) in
  (preamble, [pkglist; []], request, from_cudf, to_cudf, None, [])

let cudf_load_universe file =
  let (pr, l, r, f, t, w, _) = cudf_load_list file in
  (pr, Cudf.load_universe (List.hd l), r, f, t, w, [])

let unpack_l expected l =
  List.fold_left
    (fun acc (t, (_, _, _, _, f), _) ->
      if t = expected then f :: acc
      else fatal "cannot handle input %s" (Url.scheme_to_string t))
    []
    l

let unpack expected = function
  | (t, (_, _, _, _, f), _) when t = expected -> f
  | _ -> "cannot handle input"

let deb_parse_input options ?(status = []) ?(raw = false) urilist =
  let archs =
    if not (Option.is_none options.Dose_debian.Debcudf.native) then
      Option.get options.Dose_debian.Debcudf.native
      :: options.Dose_debian.Debcudf.foreign
    else []
  in
  let dll =
    List.map
      (fun l ->
        List.fold_left
          (fun acc (t, (_, _, _, _, f), _) ->
            match t with
            | `Deb ->
                List.fold_left
                  (fun acc p -> Deb p :: acc)
                  acc
                  (Dose_debian.Packages.input_raw ~archs [f])
            | `DebSrc ->
                List.fold_left
                  (fun acc p -> DebSrc p :: acc)
                  acc
                  (Dose_debian.Sources.input_raw ~archs [f])
            | _ -> fatal "cannot handle input")
          []
          l)
      urilist
  in
  deb_load_list options ~status ~raw dll

let pef_parse_input ?compare urilist =
  let extras = [("maintainer", None)] in
  let dll =
    List.map
      (fun l ->
        let filelist = unpack_l `Pef l in
        Dose_pef.Packages.input_raw ~extras filelist)
      urilist
  in
  pef_load_list ?compare dll

let npm_parse_input urilist =
  match urilist with
  | [[p]] when unpack `Npm p = "-" -> fatal "no stdin for npm yet"
  | [[p]] -> npm_load_list (unpack `Npm p)
  | l ->
      if List.length (List.flatten l) > 1 then
        warning "more than one npm request file specified on the command line" ;
      let p = List.hd (List.flatten l) in
      npm_load_list (unpack `Npm p)

let opam_parse_input ?options urilist =
  match urilist with
  | [[p]] when unpack `Opam p = "-" -> fatal "no stdin for opam yet"
  | [[p]] -> opam_load_list ?options (unpack `Opam p)
  | l ->
      if List.length (List.flatten l) > 1 then
        warning "more than one opam request file specified on the command line" ;
      let p = List.hd (List.flatten l) in
      opam_load_list ?options (unpack `Opam p)

let csw_parse_input urilist =
  let dll =
    List.map
      (fun l ->
        let filelist = unpack_l `Csw l in
        Dose_opencsw.Packages.input_raw filelist)
      urilist
  in
  csw_load_list dll

let cudf_parse_input urilist =
  match urilist with
  | [[p]] when unpack `Cudf p = "-" -> fatal "no stdin for cudf yet"
  | [[p]] -> cudf_load_list (unpack `Cudf p)
  | l ->
      if List.length (List.flatten l) > 1 then
        warning "more than one cudf specified on the command line" ;
      let p = List.hd (List.flatten l) in
      cudf_load_list (unpack `Cudf p)

let edsp_parse_input options urilist =
  match urilist with
  | [[p]] when unpack `Edsp p = "-" -> fatal "no stdin for edsp yet"
  | [[p]] -> edsp_load_list options (unpack `Edsp p)
  | l ->
      if List.length (List.flatten l) > 1 then
        warning "more than one cudf specified on the command line" ;
      let p = List.hd (List.flatten l) in
      edsp_load_list options (unpack `Edsp p)

(* Check that all uris are of type that is an instance of scheme *)
(* If yes return that instance of scheme, and the list of paths  *)
(* in uris.                                                      *)

(** parse a list of uris of the same type and return a cudf packages list *)
let parse_input ?(options = None) ?(raw = false) ?compare urilist =
  let filelist = List.map (List.map Input.parse_uri) urilist in
  match (Input.guess_format urilist, options) with
  | (`Cudf, None) -> cudf_parse_input filelist
  | (`Deb, None) | (`DebSrc, None) ->
      deb_parse_input Dose_debian.Debcudf.default_options ~raw filelist
  | (`Pef, None) -> pef_parse_input ?compare filelist
  | (`Deb, Some (StdOptions.Deb opt)) | (`DebSrc, Some (StdOptions.Deb opt)) ->
      deb_parse_input opt ~raw filelist
  (*  |`Edsp, Some (StdOptions.Edsp opt) -> edsp_parse_input opt filelist *)
  | (`Edsp, _) -> edsp_parse_input Dose_debian.Debcudf.default_options filelist
  | (`Opam, _) -> opam_parse_input filelist
  | (`Npm, _) -> npm_parse_input filelist
  (* |`Opam, Some (StdOptions.Opam options) -> opam_parse_input ~options filelist *)
  | (`Pef, Some (StdOptions.Pef _)) -> pef_parse_input ?compare filelist
  | (`Csw, None) -> csw_parse_input filelist
  | (`Hdlist, None) -> fatal "hdlist Not supported."
  | (`Synthesis, None) -> fatal "synthesis input format not supported."
  | (s, _) -> fatal "%s Not supported" (Url.scheme_to_string s)

let supported_formats () =
  ["cudf://"; "deb://"; "deb://-"; "eclipse://"; "pef://"]

(** return a list of Debian packages from a debian source file *)
let deb_load_source ?filter ?(dropalternatives = false) ?(profiles = [])
    ?(noindep = false) ?(noarch = false) buildarch hostarch sourcefile =
  Util.Timer.start deb_load_source_timer ;
  let l =
    Dose_debian.Sources.input_raw ?filter ~archs:[hostarch] [sourcefile]
  in
  let r =
    Dose_debian.Sources.sources2packages
      ~dropalternatives
      ~noindep
      ~noarch
      ~profiles
      buildarch
      hostarch
      l
  in
  Util.Timer.stop deb_load_source_timer r

(** parse and merge a list of files into a cudf package list *)
let load_list ?(options = None) ?(raw = false) ?compare urilist =
  info "Parsing and normalizing..." ;
  Util.Timer.start load_list_timer ;
  let u = parse_input ~options ~raw ?compare urilist in
  Util.Timer.stop load_list_timer u

(** parse and merge a list of files into a cudf universe *)
let load_universe ?(options = None) ?(raw = false) ?compare uris =
  info "Parsing and normalizing..." ;
  Util.Timer.start load_list_timer ;
  let (pr, cll, r, f, t, w, e) = parse_input ~options ~raw ?compare [uris] in
  let u = (pr, Cudf.load_universe (List.flatten cll), r, f, t, w, e) in
  Util.Timer.stop load_list_timer u
OCaml

Innovation. Community. Security.