This repository has been archived by the owner on Aug 5, 2024. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 9
/
Copy pathcamelus_lib.ml
1405 lines (1307 loc) · 48.5 KB
/
camelus_lib.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
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
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(****************************************************************************)
(* *)
(* Copyright (c) 2015 OCamlPro *)
(* *)
(* 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 Lwt.Infix
let log fmt = OpamConsole.msg (fmt ^^ "\n%!")
let verbose =
try Sys.getenv "CAMELUS_VERBOSE" <> ""
with Not_found -> false
type repo = {
user: string;
name: string;
auth: (string * string) option; (* user, token *)
}
type full_ref = {
repo: repo;
ref: string;
sha: string;
}
type pull_request = {
number: int;
base: full_ref;
head: full_ref;
pr_user: string;
message: string * string;
}
type push_event = {
push_repo: repo;
push_head: string;
push_ancestor: string;
}
module FdPool = struct
let max_count = 50
let curr_count = ref 0
let c : unit Lwt_condition.t = Lwt_condition.create ()
let fd_use () =
if !curr_count < max_count
then ( incr curr_count; Lwt.return_unit )
else ( Lwt_condition.wait c >>= fun () -> incr curr_count; Lwt.return_unit )
let fd_free () =
decr curr_count; Lwt_condition.signal c ()
let with_fd (f : unit -> 'a Lwt.t) : 'a Lwt.t =
begin fd_use () >>= f end
[%lwt.finally fd_free (); Lwt.return_unit]
end
module RepoGit = struct
module M = OpamStd.String.Map
type t = repo
let github_repo_string repo =
Printf.sprintf "https://%sgithub.com/%s/%s.git"
(match repo.auth with
| None -> ""
| Some (user, token) -> Printf.sprintf "%s:%s@" user token)
repo.user repo.name
let github_repo repo =
Uri.of_string @@ github_repo_string repo
let local_mirror repo =
Fpath.v (Fmt.strf "./%s%%%s.git" repo.user repo.name)
let write_lock = Lwt_mutex.create ()
let git
?(can_fail=false) ?(silent_fail=false) ?(verbose=verbose) ?(writing=false)
repo ?env ?input args =
let cmd = Array.of_list ("git" :: "-C" :: (Fpath.to_string (local_mirror repo)) :: args) in
let str_cmd =
OpamStd.List.concat_map " "
(fun s -> if String.contains s ' ' then Printf.sprintf "%S" s else s)
(Array.to_list cmd) in
if verbose then log "+ %s" str_cmd;
let env =
match env with
| None -> None
| Some e -> Some (Array.append (Unix.environment ()) e)
in
let git_call () =
let p = Lwt_process.open_process ("git", cmd) ?env in
let ic = p#stdout in
let oc = p#stdin in
let%lwt r = (
let%lwt () = (match input with
| None -> Lwt.return_unit
| Some s -> Lwt_io.write oc s
) [%lwt.finally Lwt_io.close oc]
in
Lwt_io.read ic
) [%lwt.finally Lwt_io.close ic ]
in
if verbose then
List.iter (fun s -> print_string "- "; print_endline s)
(OpamStd.String.split r '\n');
match%lwt p#close with
| Unix.WEXITED 0 -> Lwt.return r
| Unix.WEXITED i ->
if not silent_fail then log "ERROR: command %s returned %d" str_cmd i;
if can_fail then Lwt.return r else Lwt.fail (Failure str_cmd)
| Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
log "ERROR: command %s interrupted" str_cmd;
Lwt.fail (Failure str_cmd)
in
FdPool.with_fd @@ if writing then (fun () -> Lwt_mutex.with_lock write_lock git_call) else git_call
let get repo =
OpamSystem.mkdir (Fpath.to_string (local_mirror repo));
let%lwt _ = git ~writing:true repo ["init"] in
let%lwt _ = git ~writing:true repo ["config"; "receive.denyCurrentBranch"; "ignore"] in
Lwt.return (Ok repo)
let get_file t sha path =
try%lwt
git t ~verbose:false ~silent_fail:true ["show"; sha ^":"^ path]
>|= OpamStd.Option.some
with Failure _ -> Lwt.return None
let get_file_exn t sha path =
match%lwt get_file t sha path with
| Some f -> Lwt.return f
| None ->
log "GET_FILE %s: not found" path;
Lwt.fail Not_found
let get_blob t sha =
try%lwt
git t ~verbose:false ~silent_fail:false ["cat-file"; "blob"; sha]
>|= OpamStd.Option.some
with Failure _ -> Lwt.return_none
let get_blob_exn t sha =
match%lwt get_blob t sha with
| Some f -> Lwt.return f
| None -> log "GET_BLOB %s: not found" sha; Lwt.fail Not_found
let branch_reference name = "refs/heads/" ^ name
let pr_branch pr = "pr/" ^ (string_of_int pr.number)
let get_branch t branch =
git t ["rev-parse"; branch_reference branch]
>|= String.trim
let set_branch t name commit_hash =
git t ["branch"; "-f"; branch_reference name; commit_hash]
>|= ignore
let fetch t ?(manual_branches=[]) ?(branches=[]) repo =
let remote b = "refs/remotes/" ^ repo.user ^ "/" ^ b in
let b =
manual_branches @
List.map (fun b -> "+" ^ branch_reference b ^ ":" ^ remote b) branches
in
let%lwt _ = git ~writing:true t ("fetch" :: Uri.to_string (github_repo repo) :: b) in
Lwt_list.map_s (fun b ->
log "fetched %s" b;
git t ["rev-parse"; remote b] >|= String.trim)
branches
let fetch_pr pull_request t =
let%lwt _ =
fetch t ~branches:[pull_request.base.ref] pull_request.base.repo
in
log "fetched upstream";
let%lwt _head_fetch =
let prn = string_of_int pull_request.number in
fetch t ~manual_branches:[ "+pull/" ^ prn ^"/head:pr/" ^ prn ] pull_request.base.repo
in
log "fetched user pr";
Lwt.return_unit
let push ?(force=false) t branch repo =
git t ["push"; Uri.to_string (github_repo repo);
(if force then "+" else "") ^
branch_reference branch ^":"^ branch]
>|= ignore
let common_ancestor pull_request t =
git t ["merge-base"; pull_request.base.sha; pull_request.head.sha ]
>|= String.trim
let changed_files base head t =
git t ["diff-tree"; "-r"; "--name-only"; "--diff-filter=ACMRD"; base; head]
>>= fun s ->
let paths = OpamStd.String.split s '\n' in
Lwt_list.map_s (fun p -> get_file t head p >|= fun c -> p, c) paths
let opam_hash_and_file_re =
Re.(compile @@ seq [
bos;
repn digit 6 (Some 6);
str " blob ";
group @@ repn xdigit 40 (Some 40);
char '\t';
group @@
seq
[
str "packages/";
rep1 @@ diff any (char '/');
opt @@ seq [char '/'; rep1 @@ diff any (char '/')];
str "/opam";
];
eos;
])
let opam_files t sha =
git t ["ls-tree"; "-r"; sha; "packages/"]
>|= (fun s -> OpamStd.String.split s '\n')
>>= Lwt_list.filter_map_p (fun s ->
match Re.exec_opt opam_hash_and_file_re s with
| None -> Lwt.return_none
| Some g ->
let hash = Re.Group.get g 1 and f = Re.Group.get g 2 in
let filename = OpamFile.make (OpamFilename.of_string f) in
try%lwt
let%lwt opam = get_blob_exn t hash in
Lwt.return_some (OpamFile.OPAM.read_from_string ~filename opam)
with _ -> Lwt_io.printlf "failed on %s" f >>= fun () -> Lwt.return_none)
(* returns a list (rel_filename * contents) *)
let extra_files t sha package =
let ( / ) a b = a ^ "/" ^ b in
let dir =
"packages" /
OpamPackage.name_to_string package /
OpamPackage.to_string package /
"files" / ""
in
git t ["ls-tree"; "-r"; "--name-only"; sha; dir]
>|= (fun s -> OpamStd.String.split s '\n')
>|= List.sort compare
>|= List.rev
>>= Lwt_list.map_s (fun f ->
let%lwt contents = get_file_exn t sha f in
Lwt.return (OpamStd.String.remove_prefix ~prefix:dir f, contents))
end
module Git = struct
module User = struct
type user = {
name: string;
email: string;
date: int64 * unit option;
}
end
end
module FormatUpgrade = struct
let git_identity () = {
Git.User.
name = "Camelus";
email = "[email protected]";
date = Int64.of_float (Unix.time ()), None;
}
let get_updated_opam commit gitstore nv =
let opam_dir =
Printf.sprintf "packages/%s/%s/"
(OpamPackage.name_to_string nv)
(OpamPackage.to_string nv)
in
let opam_file = opam_dir^"opam" in
let%lwt opam_str = RepoGit.get_file_exn gitstore commit opam_file in
let%lwt url_str = RepoGit.get_file gitstore commit (opam_dir^"url") in
let%lwt descr_str = RepoGit.get_file gitstore commit (opam_dir^"descr") in
let opam =
OpamFile.OPAM.read_from_string
~filename:(OpamFile.make (OpamFilename.of_string opam_file))
opam_str
in
let opam = match descr_str with
| None -> opam
| Some d ->
OpamFile.OPAM.with_descr (OpamFile.Descr.read_from_string d) opam
in
let opam = match url_str with
| None -> opam
| Some u ->
OpamFile.OPAM.with_url (OpamFile.URL.read_from_string u) opam
in
let opam = OpamFormatUpgrade.opam_file ~quiet:true opam in
let%lwt extra_files =
RepoGit.extra_files gitstore commit nv >>=
Lwt_list.map_s (fun (f, contents) ->
Lwt.return
(OpamFilename.Base.of_string f,
OpamHash.compute_from_string contents))
in
let opam = OpamFile.OPAM.with_extra_files extra_files opam in
let opam_str =
OpamFile.OPAM.to_string_with_preserved_format
~format_from_string:opam_str
(OpamFile.make (OpamFilename.of_string opam_file))
opam
in
Lwt.return opam_str
module CompilerConversion = struct
(* Taken from OpamAdminRepoUpgrade ; should be generalised and called *)
open OpamStd.Option.Op
open OpamProcess.Job.Op
let cache_file : string list list OpamFile.t =
OpamFile.make @@
OpamFilename.of_string "~/.cache/opam-compilers-to-packages/url-hashes"
let get_url_md5, save_cache =
let url_md5 = Hashtbl.create 187 in
let () =
OpamFile.Lines.read_opt cache_file +! [] |> List.iter @@ function
| [url; md5] ->
Hashtbl.add url_md5 (OpamUrl.of_string url) (OpamHash.of_string md5)
| _ -> failwith "Bad cache, run 'opam admin upgrade --clear-cache'"
in
(fun url ->
try Done (Some (Hashtbl.find url_md5 url))
with Not_found ->
OpamFilename.with_tmp_dir_job @@ fun dir ->
OpamProcess.Job.ignore_errors ~default:None
(fun () ->
OpamDownload.download ~overwrite:false url dir @@| fun f ->
let hash = OpamHash.compute (OpamFilename.to_string f) in
Hashtbl.add url_md5 url hash;
Some hash)),
(fun () ->
Hashtbl.fold
(fun url hash l -> [OpamUrl.to_string url; OpamHash.to_string hash]::l)
url_md5 [] |>
OpamFile.Lines.write cache_file)
let opam_of_comp comp_name comp descr =
let nv =
match OpamStd.String.cut_at comp_name '+' with
| None ->
OpamPackage.create (OpamPackage.Name.of_string "ocaml-base-compiler")
(OpamPackage.Version.of_string comp_name)
| Some (version,variant) ->
OpamPackage.create (OpamPackage.Name.of_string "ocaml-variants")
(OpamPackage.Version.of_string (version^"+"^variant))
in
let opam =
OpamFormatUpgrade.comp_file ~package:nv ?descr comp |>
OpamFile.OPAM.with_conflict_class
[OpamPackage.Name.of_string "ocaml-core-compiler"]
in
let opam =
match OpamFile.OPAM.url opam with
| Some urlf when OpamFile.URL.checksum urlf = [] ->
(match OpamProcess.Job.run (get_url_md5 (OpamFile.URL.url urlf)) with
| None ->
Printf.ksprintf failwith "Could not get the archive of %s."
(OpamPackage.to_string nv)
| Some hash ->
OpamFile.OPAM.with_url (OpamFile.URL.with_checksum [hash] urlf)
opam)
| _ -> opam
in
let patches = OpamFile.Comp.patches comp in
if patches <> [] then
log "Fetching patches of %s to check their hashes...\n"
(OpamPackage.to_string nv);
let extra_sources =
(* Download them just to get their MD5 *)
OpamParallel.map
~jobs:3
~command:(fun url ->
get_url_md5 url @@| function
| Some md5 -> url, md5
| None ->
Printf.ksprintf failwith
"Could not get patch file for %s from %s, skipping"
(OpamPackage.to_string nv) (OpamUrl.to_string url))
(OpamFile.Comp.patches comp)
in
OpamFile.OPAM.with_extra_sources
(List.map (fun (url, hash) ->
OpamFilename.Base.of_string (OpamUrl.basename url),
OpamFile.URL.create ~checksum:[hash] url)
extra_sources)
opam
end
let get_compiler_opam commit gitstore comp_name =
let bname =
Printf.sprintf "compilers/%s/%s/%s"
(match OpamStd.String.cut_at comp_name '+'
with Some (v,_) -> v | None -> comp_name)
comp_name comp_name
in
let filename = bname^".comp" in
let%lwt comp_str = RepoGit.get_file_exn gitstore commit filename in
let%lwt descr_str = RepoGit.get_file gitstore commit (bname^".descr") in
let comp =
OpamFile.Comp.read_from_string
~filename:(OpamFile.make (OpamFilename.of_string filename))
comp_str
in
let descr =
OpamStd.Option.map OpamFile.Descr.read_from_string descr_str
in
let opam =
CompilerConversion.opam_of_comp comp_name comp descr
in
let opam_str =
OpamFile.OPAM.write_to_string
(opam
|> OpamFile.OPAM.with_name_opt None
|> OpamFile.OPAM.with_version_opt None)
^"\n"
in
Lwt.return (OpamFile.OPAM.package opam, opam_str)
let pkg_of_comp c =
let ocaml_official_pkgname = OpamPackage.Name.of_string "ocaml-base-compiler" in
let ocaml_variants_pkgname = OpamPackage.Name.of_string "ocaml-variants" in
match OpamStd.String.cut_at c '+' with
| None ->
OpamPackage.create ocaml_official_pkgname
(OpamPackage.Version.of_string c)
| Some (version,variant) ->
OpamPackage.create ocaml_variants_pkgname
(OpamPackage.Version.of_string (version^"+"^variant))
let get_updated_subtree commit gitstore changed_files =
let compilers, packages, files, removed =
List.fold_left (fun (compilers, packages, files, removed) (f, contents) ->
try Scanf.sscanf f "compilers/%_s@/%s@/"
(fun s ->
if contents = None then
compilers, packages, files,
OpamPackage.Set.add (pkg_of_comp s) removed
else
OpamStd.String.Set.add s compilers,
packages, files, removed)
with Scanf.Scan_failure _ -> try
Scanf.sscanf f "packages/%_s@/%s@/%s@/"
(fun s -> function
| "opam" when contents = None ->
compilers, packages, files,
OpamPackage.Set.add (OpamPackage.of_string s) removed
| "opam" | "url" | "descr" ->
compilers,
OpamPackage.Set.add (OpamPackage.of_string s) packages,
files, removed
| "files" ->
compilers, packages,
OpamStd.String.Map.add f contents files,
removed
| _ -> compilers, packages, files, removed)
with Scanf.Scan_failure _ -> compilers, packages, files, removed)
(OpamStd.String.Set.empty,
OpamPackage.Set.empty,
OpamStd.String.Map.empty,
OpamPackage.Set.empty)
changed_files
in
let%lwt compiler_packages =
Lwt_list.fold_left_s (fun acc comp_name ->
let%lwt nv, opam = get_compiler_opam commit gitstore comp_name in
Lwt.return (OpamPackage.Map.add nv opam acc))
OpamPackage.Map.empty
(OpamStd.String.Set.elements compilers)
in
let%lwt upgraded_packages =
Lwt_list.fold_left_s (fun acc nv ->
try%lwt
let%lwt opam = get_updated_opam commit gitstore nv in
Lwt.return (OpamPackage.Map.add nv opam acc)
with Not_found -> Lwt.return acc)
compiler_packages
(OpamPackage.Set.elements packages)
in
let pkg_filename nv =
Printf.sprintf "packages/%s/%s/opam"
(OpamPackage.name_to_string nv)
(OpamPackage.to_string nv)
in
Lwt.return @@
(OpamPackage.keys upgraded_packages,
removed,
OpamPackage.Map.fold (fun nv opam ->
OpamStd.String.Map.add (pkg_filename nv) (Some opam))
upgraded_packages @@
OpamPackage.Set.fold (fun nv ->
OpamStd.String.Map.add (pkg_filename nv) None)
removed @@
files)
(*
let rec add_file_to_tree gitstore tree path contents =
let add_to_tree entry t =
let name = entry.S.Value.Tree.name in
S.Value.Tree.of_list
(entry ::
List.filter (fun e -> e.S.Value.Tree.name <> name)
(S.Value.Tree.to_list t))
in
match path with
| [] -> Lwt.fail (Failure "Empty path")
| [file] ->
(match%lwt
S.write gitstore
(S.Value.blob (S.Value.Blob.of_string contents))
with
| Ok (hash, i) ->
let entry = { S.Value.Tree.perm = `Normal; name = file; node = hash } in
Lwt.return (add_to_tree entry tree)
| Error s -> Lwt.fail (Failure "Could not write new blob to git"))
| dir::path ->
let subtree =
try
Some (List.find
(fun e ->
e.S.Value.Tree.name = dir && e.S.Value.Tree.perm = `Dir)
(S.Value.Tree.to_list tree)).S.Value.Tree.node
with Not_found -> None
in
let%lwt subtree =
match subtree with
| Some h -> RepoGit.get_tree gitstore h
| None -> Lwt.return (S.Value.Tree.of_list [])
in
let%lwt subtree = add_file_to_tree gitstore subtree path contents in
match%lwt S.write gitstore (S.Value.tree subtree) with
| Ok (hash, _) ->
let entry = { S.Value.Tree.perm = `Dir; name = dir; node = hash } in
Lwt.return (add_to_tree entry tree)
| Error e -> Lwt.fail (Failure "Could not write new subtree")
let get ~err x =
match%lwt x with
| Error e -> Lwt.fail (Failure (Fmt.strf "%a" err e))
| Ok (x, _) -> Lwt.return x
*)
let gen_upgrade_commit
~merge changed_files head onto gitstore author message =
let%lwt packages, removed_packages, replace_files =
get_updated_subtree head gitstore changed_files
in
if OpamPackage.Set.(is_empty packages && is_empty removed_packages) &&
OpamStd.String.Map.is_empty replace_files
then Lwt.return None
else
let%lwt _ =
RepoGit.git gitstore
["reset"; "-q"; "--mixed"; if merge then onto else head]
in
let%lwt () =
Lwt_list.iter_s (fun (path, contents) ->
match contents with
| Some contents ->
let%lwt hash =
RepoGit.git gitstore ["hash-object"; "-w"; "--stdin"] ~input:contents
>|= String.trim
in
let%lwt _ =
RepoGit.git gitstore
["update-index"; "--ignore-missing"; "--add";
"--cacheinfo"; "100644,"^hash^","^path]
in
Lwt.return_unit
| None ->
let%lwt _ =
RepoGit.git gitstore
["update-index"; "--ignore-missing"; "--remove"; "--"; path]
in
Lwt.return_unit)
(OpamStd.String.Map.bindings replace_files)
in
let%lwt tree = RepoGit.git gitstore ["write-tree"] >|= String.trim in
let committer = git_identity () in
let env = [|
"GIT_AUTHOR_NAME="^ author.Git.User.name;
"GIT_AUTHOR_EMAIL="^ author.Git.User.email;
"GIT_COMMITTER_NAME="^ committer.Git.User.name;
"GIT_COMMITTER_EMAIL="^ committer.Git.User.email;
|] in
let message =
message (OpamPackage.Set.elements
(OpamPackage.Set.union packages removed_packages))
in
RepoGit.git gitstore ~env
("commit-tree" ::
"-m" :: message ::
(if merge then ["-p"; onto] else []) @
[ "-p"; head;
tree ])
>|= String.trim
>|= fun hash -> Some (hash, message)
(** We have conflicts if [onto] was changed in the meantime, i.e. the rewrite
of [ancestor] doesn't match what we have at the current [onto]. This is
the case where we don't want to force an overwrite *)
let check_for_conflicts changed_files ancestor onto gitstore =
let%lwt changed_files_on_ancestor =
Lwt_list.map_s (fun (f, _) ->
RepoGit.get_file gitstore ancestor f >|= fun c -> f, c)
changed_files
in
let%lwt _packages, _removed, rewritten_ancestor_tree =
get_updated_subtree ancestor gitstore
changed_files_on_ancestor
in
let rec changed = function
| (path, contents) :: r ->
let%lwt c = RepoGit.get_file gitstore onto path in
if c <> contents then
(log "Conflict on %s:\n<<<<<<\n%s======\n%s>>>>>>" path
(OpamStd.Option.to_string (fun s -> s) contents)
(OpamStd.Option.to_string (fun s -> s) c);
changed r >>= fun acc -> Lwt.return (path::acc))
else
changed r
| [] -> Lwt.return []
in
changed (OpamStd.String.Map.bindings rewritten_ancestor_tree)
let run base_branch onto_branch ancestor head_hash gitstore repo =
log "Format upgrade: %s to %s" base_branch onto_branch;
let%lwt _head_hash, onto_hash =
match%lwt
RepoGit.fetch
~branches:[base_branch; onto_branch]
gitstore repo
with
| [head_hash; onto_hash] -> Lwt.return (head_hash, onto_hash)
| _ -> Lwt.fail (Failure "Branch fetch failed")
in
(* assert (head = head_hash); *)
(* let%lwt remote_onto =
* try Lwt.return (List.assoc (RepoGit.branch_reference onto_branch) refs)
* with Not_found -> Lwt.fail (Failure ("Branch "^onto_branch^" not found"))
* in *)
(* let%lwt remote_onto =
* RepoGit.get_branch gitstore ("origin/"^onto_branch)
* in *)
log "Fetched new commits: head %s onto %s" head_hash onto_hash;
(* let%lwt _ =
* RepoGit.set_branch gitstore onto_branch remote_onto
* in
* log "Updated branch"; *)
try%lwt
(* let%lwt onto_head = RepoGit.get_commit gitstore onto_hash in
* let%lwt head_commit = RepoGit.get_commit gitstore head_hash in *)
let author = git_identity () in
log "Rewriting commit %s (and possible parents)" (*" by %s"*)
head_hash (* (S.Value.Commit.author head_commit).Git.User.name *);
let%lwt changed_files =
RepoGit.changed_files ancestor head_hash gitstore
in
let%lwt conflicts =
check_for_conflicts changed_files ancestor onto_hash gitstore
in
let rec firstn n = if n <= 0 then fun _ -> ["..."] else function
| x::r -> x::firstn (n-1) r
| [] -> []
in
let message packages =
if conflicts <> [] then
Printf.sprintf
"Partial format upgrade (%s)\n\n\
Update done by Camelus based on opam-lib %s\n\
This might overwrite changes done on the current %s branch, so it \
was not automatically merged. Conflicting files:\n%s"
(String.concat ", "
(firstn 5 (List.map OpamPackage.to_string packages)))
OpamVersion.(to_string (full ()))
onto_branch
(OpamStd.Format.itemize (fun s -> s) conflicts)
else
Printf.sprintf
"Format upgrade merge (%s)\n\n\
Merge done by Camelus based on opam-lib %s"
(OpamStd.List.concat_map ", " OpamPackage.to_string packages)
OpamVersion.(to_string (full ()))
in
match%lwt
gen_upgrade_commit ~merge:true
changed_files head_hash onto_hash gitstore author message
with
| None ->
log "No changes needed to %s branch" onto_branch;
Lwt.return None
| Some (commit_hash, msg) ->
let dest_branch =
if conflicts <> [] then "camelus-"^(String.sub head_hash 0 8)
else onto_branch
in
let%lwt _ = RepoGit.set_branch gitstore dest_branch commit_hash in
log "Pushing new commit %s onto %s (there are %sconflicts)"
((* S.Hash.to_hex *)commit_hash) dest_branch
(if conflicts <> [] then "" else "no ");
let%lwt () =
RepoGit.push ~force:(conflicts<>[]) gitstore dest_branch repo
in
log "Upgrade done";
Lwt.return (if conflicts <> [] then Some (dest_branch, msg) else None)
with e ->
log "Upgrade and push to branch %s failed: %s\n%s" onto_branch
(Printexc.to_string e)
(Printexc.get_backtrace ());
Lwt.return None
end
module PrChecks = struct
let pkg_to_string p = Printf.sprintf "`%s`" (OpamPackage.to_string p)
let max_items_in_post = 50
let changed_opam_files ancestor head gitstore =
let%lwt files = RepoGit.changed_files ancestor head gitstore in
Lwt.return @@
let opamfiles, others = List.partition (fun (s,c) ->
match c with
| Some c when
OpamStd.String.starts_with ~prefix:"packages/" s &&
OpamStd.String.ends_with ~suffix:"/opam" s
-> true
| _ -> false)
files
in
List.map (function (s, Some c) -> (OpamFilename.of_string s, c) | (_,None) -> assert false) opamfiles,
List.map fst others
let lint head gitstore opam_files =
let%lwt lint =
Lwt_list.map_s (fun (file,contents) ->
let nv =
match OpamPackage.of_filename file with
| Some nv -> nv
| None -> OpamPackage.of_string "invalid-package-name.v"
in
let%lwt check_extra_files =
RepoGit.extra_files gitstore head nv >>=
Lwt_list.map_s (fun (f, contents) ->
Lwt.return
(OpamFilename.Base.of_string f,
fun h ->
OpamHash.compute_from_string ~kind:(OpamHash.kind h)
contents
= h))
in
let r, opamopt =
OpamFileTools.lint_string ~check_extra_files
(OpamFile.make file)
contents
in
Lwt.return (file, r, opamopt))
opam_files
in
let unwanted_warns = [] in
let lint =
List.map (fun (f,r,o) ->
f, List.filter (fun (n,_,_) -> not (List.mem n unwanted_warns)) r, o)
lint
in
let passed, failed =
List.partition (function _, [], Some _ -> true | _ -> false) lint
in
let errors, warnings =
List.partition (fun (_, we, _) ->
List.exists (function _, `Error, _ -> true | _ -> false) we)
failed
in
let title =
if errors <> [] then
"##### :cloud_with_lightning: opam-lint errors"
else if warnings <> [] then
"##### :sun_behind_small_cloud: opam-lint warnings"
else if passed <> [] then
"##### :sunny: All lint checks passed"
else
"##### :sunny: No new or changed opam files"
in
let title =
Printf.sprintf "%s <small>%s</small>\n\n" title head
in
let pkgname (f,_,_) =
OpamStd.Option.Op.(
(OpamPackage.of_filename f >>| pkg_to_string)
+! OpamFilename.to_string f)
in
let pass =
OpamStd.List.concat_map ", "
~nil:""
~left:"* These packages passed lint tests: "
~right:"\n"
pkgname passed
in
let warns =
if List.length warnings + List.length errors > max_items_in_post then
OpamStd.List.concat_map
~left:"* **Packages with warnings**: " ~right:"\n" ", "
pkgname warnings
else
OpamStd.List.concat_map "\n\n"
(fun ((_, warns, _) as fe) ->
Printf.sprintf "* **%s** has some warnings:\n\n%s\n"
(pkgname fe)
(OpamStd.Format.itemize ~bullet:" * "
(fun (num,_,msg) ->
Printf.sprintf "**warning %d**: %s" num msg)
warns))
warnings
in
let errs =
if List.length errors > max_items_in_post then
OpamStd.List.concat_map
~left:"* **Packages with errors**: " ~right:"\n" ", "
pkgname errors
else
OpamStd.List.concat_map "\n\n"
(fun ((_, we, _) as fe) ->
Printf.sprintf "* **%s** has errors:\n\n%s\n"
(pkgname fe)
(OpamStd.Format.itemize ~bullet:" * "
(fun (num,kind,msg) ->
let kind = match kind with
| `Warning -> "warning"
| `Error -> "error"
in
Printf.sprintf "**%s %d:** %s" kind num msg)
we))
errors
in
let status =
if errors <> [] then `Errors (List.map pkgname errors)
else if warnings <> [] then `Warnings (List.map pkgname warnings)
else `Passed
in
Lwt.return
(status, String.concat "" [title; errs; warns; pass])
let get_universe gitstore sha ~name =
let%lwt opams = RepoGit.opam_files gitstore sha in
log "opam files at %s %s: %d" name sha (List.length opams);
let open OpamTypes in
let m =
List.fold_left (fun m o ->
let nv =
OpamPackage.create
(OpamFile.OPAM.name o) (OpamFile.OPAM.version o)
in
OpamPackage.Map.add nv o m)
OpamPackage.Map.empty opams
in
let all_packages =
OpamPackage.Set.of_list (OpamPackage.Map.keys m)
in
let env_global v =
match OpamVariable.Full.scope v,
OpamVariable.(to_string (Full.variable v))
with
| OpamVariable.Full.Global, "opam-version" ->
Some (S OpamVersion.(to_string current))
| OpamVariable.Full.Global, "with-test" -> Some (B false)
| OpamVariable.Full.Global, "with-doc" -> Some (B false)
| OpamVariable.Full.Global, "dev" -> Some (B false)
| _ -> None
in
let env nv v =
match OpamVariable.Full.scope v,
OpamVariable.(to_string (Full.variable v))
with
| (OpamVariable.Full.Global | OpamVariable.Full.Self), "name" ->
Some (S (OpamPackage.Name.to_string nv.name))
| (OpamVariable.Full.Global | OpamVariable.Full.Self), "version" ->
Some (S (OpamPackage.Version.to_string nv.version))
| _ -> env_global v
in
Lwt.return {
u_packages = all_packages;
u_action = Query;
u_installed = OpamPackage.Set.empty;
u_available =
OpamPackage.Map.filter (fun _ opam ->
OpamFilter.eval_to_bool ~default:true env_global
(OpamFile.OPAM.available opam))
m
|> OpamPackage.keys;
u_depends =
OpamPackage.Map.mapi
(fun nv o ->
OpamFile.OPAM.depends o |>
OpamFilter.partial_filter_formula (env nv))
m;
u_depopts =
OpamPackage.Map.mapi
(fun nv o ->
OpamFile.OPAM.depopts o |>
OpamFilter.partial_filter_formula (env nv))
m;
u_conflicts =
OpamPackage.Map.mapi
(fun nv o ->
OpamFile.OPAM.conflicts o |>
OpamFilter.filter_formula ~default:false (env nv))
m;
u_installed_roots = OpamPackage.Set.empty;
u_pinned = OpamPackage.Set.empty;
u_base = OpamPackage.Set.empty;
u_attrs = [];
u_reinstall = OpamPackage.Set.empty;
}
let reverse_dependencies universe packages =
OpamPackage.Set.union packages @@
OpamPackage.Set.of_list @@
OpamSolver.reverse_dependencies
~depopts:false ~build:true ~post:true ~installed:false ~unavailable:true
universe packages
let installable universe packages ~name =
let packages =
OpamPackage.Set.inter packages universe.OpamTypes.u_packages
in
log "At %s: among %d packages..." name (OpamPackage.Set.cardinal packages);
let%lwt installable =
Lwt_preemptive.detach (OpamSolver.installable_subset universe) packages
in
log "... %d are installable"
(OpamPackage.Set.cardinal installable);
Lwt.return (packages, installable)
let installability_check ancestor head gitstore packages =
let open OpamPackage.Set.Op in
let%lwt univ_before = get_universe gitstore ancestor ~name:"ANCESTOR" in
let%lwt univ_after = get_universe gitstore head ~name:"HEAD" in
let consider_packages =
reverse_dependencies univ_before packages ++
reverse_dependencies univ_after packages
in
log "Considering %d related packages"
(OpamPackage.Set.cardinal consider_packages);
let%lwt packages_before, installable_before =
installable univ_before consider_packages ~name:"ANCESTOR"
in
let%lwt packages_after, installable_after =
installable univ_after consider_packages ~name:"HEAD"
in
let fresh = packages_after -- packages_before in
let broken_before = packages_before -- installable_before in
let broken_after = packages_after -- installable_after in
let breaks = broken_after -- broken_before in
let repairs = broken_before -- broken_after in
let no_breaks = OpamPackage.Set.is_empty breaks in
let title =
Printf.sprintf "\n\n##### :%s: Installability check (%+d)\n\n"
(if no_breaks then "sunny" else "sun_behind_small_cloud")
(OpamPackage.Set.cardinal installable_after -
OpamPackage.Set.cardinal installable_before)
in
let msg (s,set) =
if OpamPackage.Set.is_empty set then None else
Some (Printf.sprintf "%s (%d): %s" s
(OpamPackage.Set.cardinal set)
(OpamStd.List.concat_map " " pkg_to_string
(OpamPackage.Set.elements set)))
in
let status =
if no_breaks then `Passed else
`Errors (List.map pkg_to_string
(OpamPackage.Set.elements breaks))