File: ben_tracker.ml

package info (click to toggle)
ben 0.7.4
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 520 kB
  • sloc: ml: 3,364; makefile: 88; ansic: 39
file content (583 lines) | stat: -rw-r--r-- 17,893 bytes parent folder | download
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
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
(**************************************************************************)
(*  Copyright © 2011 Mehdi Dogguy <mehdi@dogguy.org>                      *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

open Html5.M
open Printf
open Benl_core
open Benl_clflags
open Benl_utils
open Benl_error

let ($) f x = f x

let base = ref "."
let config_dir = ref "config"
let global_config = ref (FilePath.concat !config_dir "global.conf")
let lock = ref "ben.lock"
let clean = ref true
let tconfig = ref None

open Benl_types
open Benl_frontend

let eval x =
  Query.eval
    `source
    (Package.of_assoc `source Benl_core.StringMap.empty)
    (Query.of_expr x)

let read_global_config () =
  if Sys.file_exists !global_config then begin
    let config = Benl_utils.parse_config_file !global_config in
    StringMap.iter (fun key value -> match (key, value) with
        | "architectures", archs ->
          Benl_base.debian_architectures := to_string_l "architectures" archs;
          Benl_clflags.architectures := to_string_l "architectures" archs
        | "ignored", archs ->
          Benl_base.ignored_architectures := to_string_l "ignored" archs
        | "suite", (EString suite) ->
          Benl_clflags.suite := suite
        | "areas", areas ->
          Benl_clflags.areas := to_string_l "areas" areas
        | "base", (EString path) ->
          base := path
        | "config-dir", (EString path) ->
          config_dir := path
        | "cache-dir", (EString dir) ->
          Benl_clflags.cache_dir := dir
        | "mirror-binaries", (EString mirror) ->
          Benl_clflags.mirror_binaries := mirror
        | "mirror-sources", (EString mirror) ->
          Benl_clflags.mirror_sources := mirror
        | "mirror", (EString mirror) ->
          Benl_clflags.mirror_sources := mirror;
          Benl_clflags.mirror_binaries := mirror
        | "use-cache", expr ->
          Benl_clflags.use_cache := eval expr
        | "run-debcheck", expr ->
          Benl_data.run_debcheck := eval expr
        | "use-projectb", expr ->
          Benl_data.use_projectb := eval expr
        | "base-url", (EString url) ->
          Ben_monitor.baseurl := url
        | "template", (EString template) ->
          Benl_templates.load_template template;
        | item, _ ->
            warn (Unknown_configuration_item item)
    )
    config
  end

let lockf () =
  FilePath.concat !cache_dir !lock

let spec = Arg.align [
  "--config-dir" , Arg.Set_string config_dir, " Specify tracker's global configuration directory";
  "-cd"          , Arg.Set_string config_dir, " ";
  "--global-conf", Arg.Set_string global_config, " Specify tracker's global configuration file";
  "-g"           , Arg.Set_string global_config, " ";
  "--transition" , Arg.String (fun t -> tconfig := Some t), " Specify selected transition";
  "-t"           , Arg.String (fun t -> tconfig := Some t), " ";
  "--update"     , Arg.Set Benl_clflags.update, " Do update the cache file";
  "-u"           , Arg.Set Benl_clflags.update, " ";
  "--base"       , Arg.Set_string base, " Specify tracker's base directory";
  "-b"           , Arg.Set_string base, " ";
  "--use-projectb", Arg.Set Benl_data.use_projectb, " Use Projectb to fetch information about distributions";
  "--template"   , Arg.String (fun t -> Benl_templates.load_template t), " Specify template to use";
  "--no-clean"   , Arg.Clear clean, " Do not clean HTML directory before exiting";
]

exception Unknown_profile of string

type profile = Planned | Ongoing | Permanent | Finished | Old | Unknown

let string_of_profile = function
  | Planned -> "planned"
  | Ongoing -> "ongoing"
  | Permanent -> "permanent"
  | Finished -> "finished"
  | Old -> "old"
  | Unknown -> "unknown"

let profile_of_string = function
  | "planned" -> Planned
  | "ongoing" -> Ongoing
  | "permanent" -> Permanent
  | "finished" -> Finished
  | "old" -> Old
  | _ -> Unknown

let profiles_desc = [
  Planned   , ( "Some planned transitions"     , false );
  Ongoing   , ( "Ongoing transitions"          , true  );
  Permanent , ( "Permanent trackers"           , false );
  Finished  , ( "(almost) Finished transitions", true  );
  Old       , ( "Old trackers"                 , false );
  Unknown   , ( "Miscellaneous transitions"    , false );
]

open FileUtil

let p = Benl_clflags.progress

let is_packages_file name =
  try
    let name = String.sub (Filename.basename name) 0 9 in
    name = "Packages_"
  with _ -> false

let clear_cache () =
  let cached = !cache_dir in
  let cachef = !cache_file in
  let test_cond = Or (Basename_is cachef, Custom is_packages_file) in
  let pkgs = find test_cond cached (fun x y -> y ::x) [] in
  rm ~force:Force pkgs

let update_test () =
  let cachef = Benl_clflags.get_cache_file () in
     !Benl_clflags.update
  || (!Benl_clflags.use_cache && test (Not Exists) cachef)

let read_cache architectures =
  if update_test () then begin
    if not !Benl_data.use_projectb then begin
      clear_cache ();
      Ben_download.download_all architectures;
    end;
    Benl_data.generate_cache
      (Benl_clflags.get_cache_file ())
      architectures
  end
  else
    Benl_data.load_cache architectures

let profile_of_file file =
  try
    profile_of_string $ Filename.basename (Filename.dirname file)
  with _ -> Unknown

let read_transition_config file =
  let (!!) = Filename.basename in
  let transition = FilePath.chop_extension !!file in
  (* Read a .ben file *)
  transition, (Benl_frontend.read_ben_file file)

let get_transition_data data name config =
  try
    let transition_data = Ben_monitor.compute_transition_data data config in
    let monitor_data, sources, binaries, dep_graph, all, bad, packages =
      transition_data in
    let has_testing_data = Ben_monitor.has_testing_data monitor_data in
    let export =
      try
        Benl_clflags.get_config config "export" = Benl_types.Etrue
      with _ -> true in
    Some (export, transition_data, has_testing_data)
  with e ->
    Benl_error.warn_exn ("Failed to process transition " ^ name) e;
    None

module SMap = Map.Make(String)

let sadd mp p t =
  let ts =
    try SMap.find p mp
    with _ -> [] in
  SMap.add p (t::ts) mp

let smerge _ v1 v2 = match v1, v2 with
  | Some v1, Some v2 -> Some (v1 @ v2)
  | Some v1, None    -> Some v1
  | None   , Some v2 -> Some v2
  | _                -> None

let html_path_t name =
  Filename.concat "html" (Printf.sprintf "%s.html" name)

let print_html_collisions (hits : (SMap.key * SMap.key list) list) =
  let hits = List.fold_left
    (fun map (pkg, transitions) ->
      List.fold_left
        (fun map t -> sadd map t pkg)
        map
        transitions
    )
    SMap.empty
    hits
  in
  div ~a:[ a_id "collisions" ] [
    b [ pcdata "Collisions:" ];
    let hits =
      SMap.fold
        (fun transition packages list ->
          let elt =
            li [ Ben_monitor.a_link
                   (transition ^ ".html")
                   transition;
                 pcdata " through ";
                 pcdata (String.concat ", " packages)
               ]
          in
          elt :: list
        )
        hits
        []
    in
    match List.rev hits with
    | [] -> pcdata "(none)"
    | h::l -> ul (h::l)
  ]

let print_html_monitor config template file transition_data has_testing_data collisions =
  let monitor_data, sources, binaries, dep_graph, _, _, packages =
    transition_data
  in
  let ($) = Filename.concat in
  let (!!) = Filename.basename in
  let collisions_div =
    try
      let hits = SMap.find !!file collisions in
      Some (print_html_collisions hits)
    with Not_found ->
      None
  in
  let output =
    Ben_monitor.print_html_monitor
      config
      template
      monitor_data
      sources
      binaries
      dep_graph
      packages
      has_testing_data
      collisions_div
  in
  let htmlp = html_path_t !!file in
  let html = !base $ htmlp in
  p "Generating %s\n" htmlp;
  try
    Benl_utils.dump_xhtml_to_file html output
  with e ->
    Benl_error.warn_exn ("Failed to generate" ^ html) e

let compute_collisions results =
  let data_map = List.fold_left
    (fun
      data_map
      (_, transition, _, (_, transition_data, has_testing_data)) ->
        let  _, _, _, _, _, _, pkgs = transition_data in
        let new_data = Benl_data.S.fold
          (fun package data ->
            SMap.add (Package.Name.to_string package) [transition] data
          )
          pkgs
          SMap.empty
        in
        SMap.merge smerge data_map new_data
    )
    SMap.empty
    results
  in
  let collision_map = SMap.fold
    (fun pkg transitions map ->
      List.fold_left
        (fun map t ->
          let ts_left = List.filter (fun r -> t <> r) transitions in
          sadd map t (pkg,ts_left)
        )
        map
        transitions
    )
    data_map
    SMap.empty
  in
  collision_map

let generate_stats results =
  List.fold_left
    (fun (packages, profiles)
      (p, t, export, transition_data, _) ->
        let _, _, _, _, all, bad, pkgs = transition_data in
        let htmlp = html_path_t t in
        let profiles = sadd
          profiles
          (string_of_profile p)
          (htmlp, t, all, bad)
        in
        let packages = Benl_data.S.fold
          (fun package packages ->
            if export then
              sadd
                packages
                (Package.Name.to_string package)
                (t, p, export)
            else
              packages
          )
          pkgs
          packages
        in
        packages, profiles
    )
    (SMap.empty, SMap.empty)
    results

let dump_yaml smap file =
  let transition (name, profile, _) =
    sprintf "[ '%s' , '%s' ]"
      name
      (string_of_profile profile)
  in
  let file = Filename.concat !base (Filename.concat "export" file) in
  p "Generating %s\n" file;
  let string = SMap.fold
    (fun key list string ->
      let list = List.filter (fun (_,_,export) -> export) list in
      sprintf "%s- {'name': '%s',\n   'list': [%s]\n  }\n"
        string
        key
        (String.concat ", " (List.map transition list))
    )
    smap
    ""
  in
  try
    mkdir ~parent:true (Filename.dirname file);
    let newfile = FilePath.add_extension file "new" in
    dump_to_file newfile string;
    mv newfile file
  with exn ->
    Benl_error.error_exn ("Failed to generate " ^ file) exn

let clean_up smap =
  if !clean then begin
    p "Cleaning up...\n";
    let ($) = Filename.concat in
    let html_dir = !base $ "html" in
    let known_transitions =
      SMap.fold
        (fun _ tlist accu ->
          let tlist = List.map
            (fun (name, _, _, _) -> Filename.basename name)
            tlist
          in
          let tset = StringSet.from_list tlist in
          StringSet.union tset accu
        )
        smap
        StringSet.empty
    in
    try
      let dir_content = Sys.readdir html_dir in
      Array.iter
        (fun file ->
          if Filename.check_suffix file ".html" &&
            not (StringSet.mem file known_transitions)
          then begin
            let file = html_dir $ file in
            p "Removing %s\n" file;
            Sys.remove file
          end
        )
        dir_content
    with _ -> ()
  end

let tracker template profiles =
  let page_title = "Transition tracker" in
  let footer = [ small (Ben_monitor.generated_on_text ()) ] in
  let tget show_score (path, name, all, bad) =
    li (
      (Ben_monitor.a_link path name)::
      if show_score then
        let score =
          if all = 0
          then 0
          else 100*(all-bad)/all in
        [ pcdata (sprintf " (%d%%)" score) ]
      else []
    )
  in
  let contents = SMap.fold
    (fun profile tlist acc ->
      let title, show_score =
        try
          let profile = profile_of_string profile in
          List.assoc profile profiles_desc
        with _ ->
          List.assoc Unknown profiles_desc
      in
      let tlist = List.sort Pervasives.compare tlist in
      let tlist = List.map (tget show_score) tlist in
      match tlist with
        | [] -> acc
        | _::_ ->
          let tdiv = div ~a:[ a_class [ "transitions" ] ]
            [ b [ pcdata title ];
              ul tlist
            ] in
          tdiv::acc
    )
    profiles
    []
  in
  let contents = template.Template.intro @ contents in
  let index = Filename.concat !base "index.html" in
  let subtitle = [ pcdata "Transition tracker" ] in
  let output = template.Template.page page_title subtitle [] contents footer in
  try
    p "Generating index...\n";
    dump_xhtml_to_file index output
  with exn ->
    Benl_error.error_exn "Failed to generate index.html" exn

let () = at_exit (fun () ->
  try
    rm [lockf ()]
  with _ -> ()
)

let main args =
  let () = read_global_config () in
  let lockf = lockf () in
  if test Exists lockf then
    eprintf "Please wait until %s is removed!\n" lockf
  else
    try
      let lockf_b = Filename.dirname lockf in
      let () = if test Exists lockf_b then
          touch lockf
        else
          eprintf "%s doesn't exist. Skipping creation of lock file.\n" lockf_b
      in
      let htmld = Filename.concat !base "html" in
      if test (Not Exists) htmld then
        mkdir ~parent:true htmld;
      Ben_monitor.check_media_dir !base;
      let confd = !config_dir in
      let test_cond = And (Size_not_null,
                      And (Has_extension "ben",
                      And (Is_file, Is_readable))) in
      let template = Benl_templates.get_registered_template () in
      (* Computing list of transitions *)
      let transition_files =
        match !tconfig with
        | Some transition -> [transition, profile_of_file transition]
        | None ->
          find test_cond confd
            (fun results transition ->
              match profile_of_file transition with
              | Old -> results
              | profile -> (transition, profile) :: results
            )
            []
      in
      (* Read found .ben files *)
      let transitions =
        Benl_parallel.map
          (fun (transition, profile) ->
            try
              let name, config = read_transition_config transition in
              Some (name, (config, transition, profile))
            with
            | Benl_error.Error e -> (* Ben file has errors *)
              warn e;
              None
            | e ->
              Benl_error.warn_exn ("Failed to read " ^ transition) e;
              None

          )
          transition_files
      in
      let transitions =
        List.fold_left
          (fun transitions -> function
          | Some t -> t :: transitions
          | None -> transitions
          )
          []
          transitions
      in
      (* Read ben.cache *)
      let cache = read_cache (Benl_base.archs_list ()) in
      (* Compute data for each transition *)
      let results =
        Benl_parallel.map
          (fun (name, (config, file, profile)) ->
            let () =
              p "Computing data for (%s) %s\n"
                (string_of_profile profile)
                name
            in
            config, name, profile, (get_transition_data cache name config)
          )
          transitions
      in
      let results =
        List.fold_left
          (fun results -> function
          | (c, n, p, Some d) -> (c, n, p, d) :: results
          | _ -> results
          )
          []
          results
      in
      (* Compute collisions *)
      let collisions = compute_collisions results in
      (* Generate an HTML page for each transition *)
      let () = Benl_parallel.iter
        (fun (config, transition, _, (_, transition_data, has_testing_data)) ->
          print_html_monitor
            config
            template
            transition
            transition_data
            has_testing_data
            collisions
        )
        results
      in
      (* Generate the packages.yaml file *)
      let results =
        Benl_parallel.map
          (fun (config, t, p, (export, transition_data, has_testing_data)) ->
            p, t, export, transition_data, has_testing_data
          )
          results
      in
      let packages, profiles = generate_stats results in
      let () = dump_yaml packages "packages.yaml" in
      (* Clean up the HTML directory from old files *)
      let () = clean_up profiles in
      (* Generate the index page *)
      (match !tconfig with
        | None -> tracker template profiles
        | Some _ -> ())
    with exn ->
      Benl_error.error_exn "General error" exn;
      exit(42)

let frontend = {
  Benl_frontend.name = "tracker";
  Benl_frontend.main = main;
  Benl_frontend.anon_fun = (fun _ -> ());
  Benl_frontend.help = spec;
}