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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix channels)
#:use-module (git)
#:use-module (guix git)
#:use-module (guix git-authenticate)
#:use-module ((guix openpgp)
#:select (openpgp-public-key-fingerprint
openpgp-format-fingerprint))
#:use-module (guix base16)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix discovery)
#:use-module (guix monads)
#:use-module (guix profiles)
#:use-module (guix packages)
#:use-module (guix progress)
#:use-module (guix derivations)
#:use-module (guix combinators)
#:use-module (guix diagnostics)
#:use-module (guix sets)
#:use-module (guix store)
#:use-module (guix i18n)
#:use-module ((guix utils)
#:select (source-properties->location
&error-location
&fix-hint))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module ((ice-9 rdelim) #:select (read-string))
#:use-module ((rnrs bytevectors) #:select (bytevector=?))
#:export (channel
channel?
channel-name
channel-url
channel-branch
channel-commit
channel-introduction
channel-location
channel-introduction?
;; <channel-introduction> accessors purposefully omitted for now.
%default-channels
guix-channel?
channel-instance?
channel-instance-channel
channel-instance-commit
channel-instance-checkout
authenticate-channel
latest-channel-instances
checkout->channel-instance
latest-channel-derivation
channel-instances->manifest
%channel-profile-hooks
channel-instances->derivation
ensure-forward-channel-update
profile-channels
channel-news-entry?
channel-news-entry-commit
channel-news-entry-tag
channel-news-entry-title
channel-news-entry-body
channel-news-for-commit))
;;; Commentary:
;;;
;;; This module implements "channels." A channel is usually a source of
;;; package definitions. There's a special channel, the 'guix' channel, that
;;; provides all of Guix, including its commands and its documentation.
;;; User-defined channels are expected to typically provide a bunch of .scm
;;; files meant to be added to the '%package-search-path'.
;;;
;;; This module provides tools to fetch and update channels from a Git
;;; repository and to build them.
;;;
;;; Code:
(define-record-type* <channel> channel make-channel
channel?
(name channel-name)
(url channel-url)
(branch channel-branch (default "master"))
(commit channel-commit (default #f))
(introduction channel-introduction (default #f))
(location channel-location
(default (current-source-location)) (innate)))
;; Channel introductions. A "channel introduction" provides a commit/signer
;; pair that specifies the first commit of the authentication process as well
;; as its signer's fingerprint. The pair must be signed by the signer of that
;; commit so that only them may emit this introduction. Introductions are
;; used to bootstrap trust in a channel.
;;
;; For the 'guix' channel, the introduction can also list "prehistorical
;; authorizations": the list of fingerprints of authorized committers before
;; the '.guix-authorizations' file was introduced. Currently this feature is
;; only available for the 'guix' channel because otherwise we would need and
;; out-of-band mechanism to authenticate those prehistorical authorizations.
(define-record-type <channel-introduction>
(make-channel-introduction first-signed-commit first-commit-signer
prehistorical-authorizations signature)
channel-introduction?
(first-signed-commit channel-introduction-first-signed-commit) ;hex string
(first-commit-signer channel-introduction-first-commit-signer) ;bytevector
(prehistorical-authorizations
channel-introduction-prehistorical-authorizations) ;list of bytevectors
(signature channel-introduction-signature)) ;string
(define %guix-historical-committers
;; List of "historical" Guix committers---people once authorized committers
;; before the '.guix-authorizations' file was created.
;;
;; These are the user names found on
;; <https://savannah.gnu.org/project/memberlist.php?group=guix> along with
;; the fingerprint of the signing (sub)key.
'(("andreas"
"AD17 A21E F8AE D8F1 CC02 DBD9 F7D5 C9BF 765C 61E3")
("ajgrf"
"2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5")
("alexvong1995"
"306F CB8F 2C01 C25D 29D3 0556 61EF 502E F602 52F2")
("alezost"
"4FB9 9F49 2B12 A365 7997 E664 8246 0C08 2A0E E98F")
("ambrevar"
"50F3 3E2E 5B0C 3D90 0424 ABE8 9BDC F497 A4BB CC7F")
("apteryx"
"27D5 86A4 F890 0854 329F F09F 1260 E464 82E6 3562")
("arunisaac"
"7F73 0343 F2F0 9F3C 77BF 79D3 2E25 EE8B 6180 2BB3")
("atheia"
;; primary: "3B12 9196 AE30 0C3C 0E90 A26F A715 5567 3271 9948"
"9A2B 401E D001 0650 1584 BAAC 8BC4 F447 6E8A 8E00")
("bandali"
;; primary: "BE62 7373 8E61 6D6D 1B3A 08E8 A21A 0202 4881 6103"
"39B3 3C8D 9448 0D2D DCC2 A498 8B44 A0CD C7B9 56F2")
("bavier"
;; primary: "34FF 38BC D151 25A6 E340 A0B5 3453 2F9F AFCA 8B8E"
"A0C5 E352 2EF8 EF5C 64CD B7F0 FD73 CAC7 19D3 2566")
("beffa"
"3774 8024 880F D3FF DCA2 C9AB 5893 6E0E 2F1B 5A4C")
("benwoodcroft"
"BCF8 F737 2CED 080A 67EB 592D 2A6A D9F4 AAC2 0DF6")
("biscuolo"
"45CC 63B8 5258 C9D5 5F34 B239 D37D 0EA7 CECC 3912")
("boskovits"
"7988 3B9F 7D6A 4DBF 3719 0367 2506 A96C CF63 0B21")
("brettgilio"
"DFC0 C7F7 9EE6 0CA7 AE55 5E19 6722 43C4 A03F 0EEE")
("carl"
;; primary: "0401 7A2A 6D9A 0CCD C81D 8EC2 96AB 007F 1A7E D999"
"09CD D25B 5244 A376 78F6 EEA8 0CC5 2153 1979 91A5")
("cbaines"
"3E89 EEE7 458E 720D 9754 E0B2 5E28 A33B 0B84 F577")
("civodul"
"3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5")
("cwebber"
"510A 8628 E2A7 7678 8F8C 709C 4BC0 2592 5FF8 F4D3")
("dannym"
;; primary: "295A F991 6F46 F8A1 34B0 29DA 8086 3842 F0FE D83B"
"76CE C6B1 7274 B465 C02D B3D9 E71A 3554 2C30 BAA5")
("davexunit"
"B3C0 DB4D AD73 BA5D 285E 19AE 5143 0234 CEFD 87C3")
("davexunit (2nd)" ;FIXME: to be confirmed!
"8CCB A7F5 52B9 CBEA E1FB 2915 8328 C747 0FF1 D807")
("daviwil"
"53C4 1E6E 41AA FE55 335A CA5E 446A 2ED4 D940 BF14")
("dvc"
"6909 6DFD D702 8BED ACC5 884B C5E0 51C7 9C0B ECDB")
("dvc (old)"
"5F43 B681 0437 2F4B A898 A64B 33B9 E9FD E28D 2C23")
("efraim"
"A28B F40C 3E55 1372 662D 14F7 41AA E7DC CA3D 8351")
("efraim (old)"
"9157 41FE B22F A4E3 3B6E 8F8D F4C1 D391 7EAC EE93")
("glv"
;; primary: "2453 02B1 BAB1 F867 FDCA 96BC 8F3F 861F 82EB 7A9A"
"CBC5 9C66 EC27 B971 7940 6B3E 6BE8 208A DF21 FE3F")
("hoebjo"
"2219 43F4 9E9F 276F 9499 3382 BF28 6CB6 593E 5FFD")
("htgoebel"
"B943 509D 633E 80DD 27FC 4EED 634A 8DFF D3F6 31DF")
("ipetkov"
"7440 26BA 7CA3 C668 E940 1D53 0B43 1E98 3705 6942")
("iyzsong"
;; primary: "66A5 6D9C 9A98 BE7F 719A B401 2652 5665 AE72 7D37"
"0325 78A6 8298 94E7 2AA2 66F5 D415 BF25 3B51 5976")
;; https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00229.html
("janneke (old)"
"DB34 CB51 D25C 9408 156F CDD6 A12F 8797 8D70 1B99")
("janneke"
"1A85 8392 E331 EAFD B8C2 7FFB F3C1 A0D9 C1D6 5273")
("jlicht"
;; primary: "1BA4 08C5 8BF2 0EA7 3179 635A 865D C0A3 DED9 B5D0"
"E31D 9DDE EBA5 4A14 8A20 4550 DA45 97F9 47B4 1025")
("jmd"
"8797 A26D 0854 2EAB 0285 A290 8A67 719C 2DE8 27B3")
("kkebreau"
"83B6 703A DCCA 3B69 4BCE 2DA6 E6A5 EE3C 1946 7A0D")
("leungbk"
"45E5 75FA 53EA 8BD6 1BCE 0B4E 3ADC 75F0 13D6 78F9")
("lfam"
;; primary: "4F71 6F9A 8FA2 C80E F1B5 E1BA 5E35 F231 DE1A C5E0"
"B051 5948 F1E7 D3C1 B980 38A0 2646 FA30 BACA 7F08")
("lsl88"
"2AE3 1395 932B E642 FC0E D99C 9BED 6EDA 32E5 B0BC")
("marusich"
"CBF5 9755 CBE7 E7EF EF18 3FB1 DD40 9A15 D822 469D")
("mbakke"
"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")
("mhw"
"D919 0965 CE03 199E AF28 B3BE 7CEF 2984 7562 C516")
("mothacehe"
"4008 6A7E 0252 9B60 31FB 8607 8354 7635 3176 9CA6")
("mthl"
"F2A3 8D7E EB2B 6640 5761 070D 0ADE E100 9460 4D37")
("nckx"
;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B"
"F5DA 2032 4B87 3D0B 7A38 7672 0DB0 FF88 4F55 6D79")
("nckx (revoked; not compromised)"
;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B"
"7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C")
("niedzejkob"
"E576 BFB2 CF6E B13D F571 33B9 E315 A758 4613 1564")
("ngz"
"ED0E F1C8 E126 BA83 1B48 5FE9 DA00 B4F0 48E9 2F2D")
("pelzflorian"
"CEF4 CB91 4856 BA38 0A20 A7E2 3008 88CB 39C6 3817")
("pgarlick"
;; primary: "B68B DF22 73F9 DA0E 63C1 8A32 515B F416 9242 D600"
"C699 ED09 E51B CE89 FD1D A078 AAC7 E891 896B 568A")
("phant0mas"
"3A86 380E 58A8 B942 8D39 60E1 327C 1EF3 8DF5 4C32")
("reepca"
"74D6 A930 F44B 9B84 9EA5 5606 C166 AA49 5F7F 189C")
("rekado"
"BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAC")
("rhelling"
"0154 E1B9 1CC9 D9EF 7764 8DE7 F3A7 27DB 44FC CA36")
("roelj (old)"
"17CB 2812 EB63 3DFF 2C7F 0452 C3EC 1DCA 8430 72E1")
("roelj"
;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
"F556 FD94 FB8F 8B87 79E3 6832 CBD0 CD51 38C1 9AFC")
("roptat (old)"
"B5FA E628 5B41 3728 B2A0 FAED 4311 1F45 2008 6A0C")
("roptat"
;; From commit 2cbede5935eb6a40173bbdf30a9ad22bf7574c22 (Jan. 2020). See
;; <https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00499.html>.
"1EFB 0909 1F17 D28C CBF9 B13A 53D4 57B2 D636 EE82")
("samplet"
;; primary: "D6B0 C593 DA8C 5EDC A44C 7A58 C336 91F7 1188 B004"
"A02C 2D82 0EF4 B25B A6B5 1D90 2AC6 A5EC 1C35 7C59")
("sleep_walker"
"77DD AD2D 97F5 31BB C0F3 C7FD DFB5 EB09 AA62 5423")
("snape"
"F494 72F4 7A59 00D5 C235 F212 89F9 6D48 08F3 59C7")
("steap"
"4E26 CCE9 578E 0828 9855 BDD4 1C79 95D2 D5A3 8336")
("taylanub"
"9ADE 9ECF 2B19 C180 9C99 5CEA A1F4 CFCC 5283 6BAC")
;; https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00826.html
("thomasd"
;; primary: "1DD1 681F E285 E07F 11DC 0C59 2E15 A6BC D77D 54FD"
"3D2C DA58 819C 08C2 A649 D43D 5C3B 064C 724A 5726")
("thomasd (old)"
"A5C5 92EA 606E 7106 A6A3 BC08 98B2 1575 91E1 2B08")
("toothbrush"
"D712 1D73 A40A 7264 9E43 ED7D F284 6B1A 0D32 C442")
("vagrantc"
"6580 7361 3BFC C5C7 E2E4 5D45 DC51 8FC8 7F97 16AA")
("wigust"
;; primary: "C955 CC5D C048 7FB1 7966 40A9 199A F6A3 67E9 4ABB"
"7238 7123 8EAC EB63 4548 5857 167F 8EA5 001A FA9C")
("wingo"
"FF47 8FB2 64DE 32EC 2967 25A3 DDC0 F535 8812 F8F2")))
(define (openpgp-fingerprint->bytevector str)
(base16-string->bytevector
(string-downcase (string-filter char-set:hex-digit str))))
(define %guix-channel-introduction
;; Introduction of the official 'guix channel.
(make-channel-introduction
"6298c3ffd9654d3231a6f25390b056483e8f407c" ;v1.0.0
(openpgp-fingerprint->bytevector
"3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5") ;civodul
;; The "prehistorical authorizations" lists authorized committers between
;; v1.0.0 and the commit where '.guix-authorizations' was introduced.
(match %guix-historical-committers
(((_ fingerprints) ...)
(map openpgp-fingerprint->bytevector fingerprints)))
#f)) ;TODO: Add an intro signature so it can be exported.
(define %default-channel-url
;; URL of the default 'guix' channel.
"https://git.savannah.gnu.org/git/guix.git")
(define %default-channels
;; Default list of channels.
(list (channel
(name 'guix)
(branch "master")
(url %default-channel-url)
(introduction %guix-channel-introduction))))
(define (guix-channel? channel)
"Return true if CHANNEL is the 'guix' channel."
(eq? 'guix (channel-name channel)))
(define (ensure-default-introduction chan)
"If CHAN represents the \"official\" 'guix' channel and lacks an
introduction, add it."
(if (and (guix-channel? chan)
(not (channel-introduction chan))
(string=? (channel-url chan) %default-channel-url))
(channel (inherit chan)
(introduction %guix-channel-introduction))
chan))
(define-record-type <channel-instance>
(channel-instance channel commit checkout)
channel-instance?
(channel channel-instance-channel)
(commit channel-instance-commit)
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
(channel-metadata directory dependencies news-file keyring-reference)
channel-metadata?
(directory channel-metadata-directory) ;string with leading slash
(dependencies channel-metadata-dependencies) ;list of <channel>
(news-file channel-metadata-news-file) ;string | #f
(keyring-reference channel-metadata-keyring-reference)) ;string
(define %default-keyring-reference
;; Default value of the 'keyring-reference' field.
"keyring")
(define (channel-reference channel)
"Return the \"reference\" for CHANNEL, an sexp suitable for
'latest-repository-commit'."
(match (channel-commit channel)
(#f `(branch . ,(channel-branch channel)))
(commit `(commit . ,(channel-commit channel)))))
(define (read-channel-metadata port)
"Read from PORT channel metadata in the format expected for the
'.guix-channel' file. Return a <channel-metadata> record, or raise an error
if valid metadata could not be read from PORT."
(match (read port)
(('channel ('version 0) properties ...)
(let ((directory (and=> (assoc-ref properties 'directory) first))
(dependencies (or (assoc-ref properties 'dependencies) '()))
(news-file (and=> (assoc-ref properties 'news-file) first))
(keyring-reference
(or (and=> (assoc-ref properties 'keyring-reference) first)
%default-keyring-reference)))
(channel-metadata
(cond ((not directory) "/") ;directory
((string-prefix? "/" directory) directory)
(else (string-append "/" directory)))
(map (lambda (item) ;dependencies
(let ((get (lambda* (key #:optional default)
(or (and=> (assoc-ref item key) first) default))))
(and-let* ((name (get 'name))
(url (get 'url))
(branch (get 'branch "master")))
(channel
(name name)
(branch branch)
(url url)
(commit (get 'commit))))))
dependencies)
news-file
keyring-reference)))
((and ('channel ('version version) _ ...) sexp)
(raise (condition
(&message (message "unsupported '.guix-channel' version"))
(&error-location
(location (source-properties->location
(source-properties sexp)))))))
(sexp
(raise (condition
(&message (message "invalid '.guix-channel' file"))
(&error-location
(location (source-properties->location
(source-properties sexp)))))))))
(define (read-channel-metadata-from-source source)
"Return a channel-metadata record read from channel's SOURCE/.guix-channel
description file, or return the default channel-metadata record if that file
doesn't exist."
(catch 'system-error
(lambda ()
(call-with-input-file (string-append source "/.guix-channel")
read-channel-metadata))
(lambda args
(if (= ENOENT (system-error-errno args))
(channel-metadata "/" '() #f %default-keyring-reference)
(apply throw args)))))
(define (channel-instance-metadata instance)
"Return a channel-metadata record read from the channel INSTANCE's
description file or its default value."
(read-channel-metadata-from-source (channel-instance-checkout instance)))
(define (channel-instance-dependencies instance)
"Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
(channel-metadata-dependencies (channel-instance-metadata instance)))
(define (apply-patches checkout commit patches)
"Apply the matching PATCHES to CHECKOUT, modifying files in place. The
result is unspecified."
(let loop ((patches patches))
(match patches
(() #t)
((patch rest ...)
(when (applicable-patch? patch checkout commit)
(apply-patch patch checkout))
(loop rest)))))
(define commit-short-id
(compose (cut string-take <> 7) oid->string commit-id))
(define (verify-introductory-commit repository introduction keyring)
"Raise an exception if the first commit described in INTRODUCTION doesn't
have the expected signer."
(define commit-id
(channel-introduction-first-signed-commit introduction))
(define actual-signer
(openpgp-public-key-fingerprint
(commit-signing-key repository (string->oid commit-id)
keyring)))
(define expected-signer
(channel-introduction-first-commit-signer introduction))
(unless (bytevector=? expected-signer actual-signer)
(raise (condition
(&message
(message (format #f (G_ "initial commit ~a is signed by '~a' \
instead of '~a'")
commit-id
(openpgp-format-fingerprint actual-signer)
(openpgp-format-fingerprint expected-signer))))))))
(define* (authenticate-channel channel checkout commit
#:key (keyring-reference-prefix "origin/"))
"Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
directory containing a CHANNEL checkout. Raise an error if authentication
fails."
;; XXX: Too bad we need to re-open CHECKOUT.
(with-repository checkout repository
(define start-commit
(commit-lookup repository
(string->oid
(channel-introduction-first-signed-commit
(channel-introduction channel)))))
(define end-commit
(commit-lookup repository (string->oid commit)))
(define cache-key
(string-append "channels/" (symbol->string (channel-name channel))))
(define keyring-reference
(channel-metadata-keyring-reference
(read-channel-metadata-from-source checkout)))
(define keyring
(load-keyring-from-reference repository
(string-append keyring-reference-prefix
keyring-reference)))
(define prehistorical-authorizations
(channel-introduction-prehistorical-authorizations
(channel-introduction channel)))
(define authenticated-commits
;; Previously-authenticated commits that don't need to be checked again.
(filter-map (lambda (id)
(false-if-exception
(commit-lookup repository (string->oid id))))
(previously-authenticated-commits cache-key)))
(define commits
;; Commits to authenticate, excluding the closure of
;; AUTHENTICATED-COMMITS.
(commit-difference end-commit start-commit
authenticated-commits))
(define reporter
(progress-reporter/bar (length commits)))
;; When COMMITS is empty, it's either because AUTHENTICATED-COMMITS
;; contains END-COMMIT or because END-COMMIT is not a descendant of
;; START-COMMIT. Check that.
(if (null? commits)
(match (commit-relation start-commit end-commit)
((or 'self 'ancestor 'descendant) #t) ;nothing to do!
('unrelated
(raise
(condition
(&message
(message
(format #f (G_ "'~a' is not related to introductory \
commit of channel '~a'~%")
(oid->string (commit-id end-commit))
(channel-name channel))))))))
(begin
(format (current-error-port)
(G_ "Authenticating channel '~a', \
commits ~a to ~a (~h new commits)...~%")
(channel-name channel)
(commit-short-id start-commit)
(commit-short-id end-commit)
(length commits))
;; If it's our first time, verify CHANNEL's introductory commit.
(when (null? authenticated-commits)
(verify-introductory-commit repository
(channel-introduction channel)
keyring))
(call-with-progress-reporter reporter
(lambda (report)
(authenticate-commits repository commits
#:keyring keyring
#:default-authorizations
prehistorical-authorizations
#:report-progress report)))
(unless (null? commits)
(cache-authenticated-commit cache-key
(oid->string
(commit-id end-commit))))))))
(define* (latest-channel-instance store channel
#:key (patches %patches)
starting-commit
(authenticate? #f)
(validate-pull
ensure-forward-channel-update))
"Return the latest channel instance for CHANNEL. When STARTING-COMMIT is
true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated."
(define (dot-git? file stat)
(and (string=? (basename file) ".git")
(eq? 'directory (stat:type stat))))
(let-values (((channel)
(ensure-default-introduction channel))
((checkout commit relation)
(update-cached-checkout (channel-url channel)
#:ref (channel-reference channel)
#:starting-commit starting-commit)))
(when relation
(validate-pull channel starting-commit commit relation))
(if authenticate?
(if (channel-introduction channel)
(authenticate-channel channel checkout commit)
;; TODO: Warn for all the channels once the authentication interface
;; is public.
(when (guix-channel? channel)
(warning (G_ "the code of channel '~a' cannot be authenticated~%")
(channel-name channel))))
(warning (G_ "channel authentication disabled~%")))
(when (guix-channel? channel)
;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is
;; safe to do because 'switch-to-ref' eventually does a hard reset.
(apply-patches checkout commit patches))
(let* ((name (url+commit->name (channel-url channel) commit))
(checkout (add-to-store store name #t "sha256" checkout
#:select? (negate dot-git?))))
(channel-instance channel commit checkout))))
(define (ensure-forward-channel-update channel start commit relation)
"Raise an error if RELATION is not 'ancestor, meaning that START is not an
ancestor of COMMIT, unless CHANNEL specifies a commit.
This procedure implements a channel update policy meant to be used as a
#:validate-pull argument."
(match relation
('ancestor #t)
('self #t)
(_
(raise (make-compound-condition
(condition
(&message (message
(format #f (G_ "\
aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
(channel-name channel)
commit start))))
;; If the user asked for a specific commit, they might want
;; that to happen nevertheless, so tell them about the
;; relevant 'guix pull' option.
(if (channel-commit channel)
(condition
(&fix-hint
(hint (G_ "Use @option{--allow-downgrades} to force
this downgrade."))))
(condition
(&fix-hint
(hint (G_ "This could indicate that the channel has
been tampered with and is trying to force a roll-back, preventing you from
getting the latest updates. If you think this is not the case, explicitly
allow non-forward updates."))))))))))
(define* (latest-channel-instances store channels
#:key
(current-channels '())
(authenticate? #t)
(validate-pull
ensure-forward-channel-update))
"Return a list of channel instances corresponding to the latest checkouts of
CHANNELS and the channels on which they depend.
When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
\"channel introduction\".
CURRENT-CHANNELS is the list of currently used channels. It is compared
against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
for each channel update and can choose to emit warnings or raise an error,
depending on the policy it implements."
;; Only process channels that are unique, or that are more specific than a
;; previous channel specification.
(define (ignore? channel others)
(member channel others
(lambda (a b)
(and (eq? (channel-name a) (channel-name b))
(or (channel-commit b)
(not (or (channel-commit a)
(channel-commit b))))))))
(define (current-commit name)
;; Return the current commit for channel NAME.
(any (lambda (channel)
(and (eq? (channel-name channel) name)
(channel-commit channel)))
current-channels))
(let loop ((channels channels)
(previous-channels '()))
;; Accumulate a list of instances. A list of processed channels is also
;; accumulated to decide on duplicate channel specifications.
(define-values (resulting-channels instances)
(fold2 (lambda (channel previous-channels instances)
(if (ignore? channel previous-channels)
(values previous-channels instances)
(begin
(format (current-error-port)
(G_ "Updating channel '~a' from Git repository at '~a'...~%")
(channel-name channel)
(channel-url channel))
(let* ((current (current-commit (channel-name channel)))
(instance
(latest-channel-instance store channel
#:authenticate?
authenticate?
#:validate-pull
validate-pull
#:starting-commit
current)))
(let-values (((new-instances new-channels)
(loop (channel-instance-dependencies instance)
previous-channels)))
(values (append (cons channel new-channels)
previous-channels)
(append (cons instance new-instances)
instances)))))))
previous-channels
'() ;instances
channels))
(let ((instance-name (compose channel-name channel-instance-channel)))
;; Remove all earlier channel specifications if they are followed by a
;; more specific one.
(values (delete-duplicates instances
(lambda (a b)
(eq? (instance-name a) (instance-name b))))
resulting-channels))))
(define* (checkout->channel-instance checkout
#:key commit
(url checkout) (name 'guix))
"Return a channel instance for CHECKOUT, which is assumed to be a checkout
of COMMIT at URL. Use NAME as the channel name."
(let* ((commit (or commit (make-string 40 #\0)))
(channel (channel (name name)
(commit commit)
(url url))))
(channel-instance channel commit checkout)))
(define %self-build-file
;; The file containing code to build Guix. This serves the same purpose as
;; a makefile, and, similarly, is intended to always keep this name.
"build-aux/build-self.scm")
(define %pull-version
;; This is the version of the 'guix pull' protocol. It specifies what's
;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd
;; place a set of compiled Guile modules in ~/.config/guix/latest.
1)
(define (standard-module-derivation name source core dependencies)
"Return a derivation that builds with CORE, a Guix instance, the Scheme
modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
objects. The assumption is that SOURCE contains package modules to be added
to '%package-module-path'."
(let* ((metadata (read-channel-metadata-from-source source))
(directory (channel-metadata-directory metadata)))
(define build
;; This is code that we'll run in CORE, a Guix instance, with its own
;; modules and so on. That way, we make sure these modules are built for
;; the right Guile version, with the right dependencies, and that they get
;; to see the right (gnu packages …) modules.
(with-extensions dependencies
#~(begin
(use-modules (guix build compile)
(guix build utils)
(srfi srfi-26))
(define go
(string-append #$output "/lib/guile/" (effective-version)
"/site-ccache"))
(define scm
(string-append #$output "/share/guile/site/"
(effective-version)))
(let* ((subdir #$directory)
(source (string-append #$source subdir)))
(compile-files source go (find-files source "\\.scm$"))
(mkdir-p (dirname scm))
(symlink (string-append #$source subdir) scm))
scm)))
(gexp->derivation-in-inferior name build core)))
(define* (guile-for-source source #:optional (quirks %quirks))
"Return the Guile package to use when building SOURCE or #f if the default
'%guile-for-build' should be good enough."
(let loop ((quirks quirks))
(match quirks
(()
#f)
(((predicate . guile) rest ...)
(if (predicate source) (guile) (loop rest))))))
(define (call-with-guile guile thunk)
(lambda (store)
(values (parameterize ((%guile-for-build
(if guile
(package-derivation store guile)
(%guile-for-build))))
(run-with-store store (thunk)))
store)))
(define-syntax-rule (with-guile guile exp ...)
"Set GUILE as the '%guile-for-build' parameter for the dynamic extent of
EXP, a series of monadic expressions."
(call-with-guile guile (lambda ()
(mbegin %store-monad exp ...))))
(define (with-trivial-build-handler mvalue)
"Run MVALUE, a monadic value, with a \"trivial\" build handler installed
that unconditionally resumes the continuation."
(lambda (store)
(with-build-handler (lambda (continue . _)
(continue #t))
(values (run-with-store store mvalue)
store))))
(define* (build-from-source name source
#:key core verbose? commit
(dependencies '()))
"Return a derivation to build Guix from SOURCE, using the self-build script
contained therein; use COMMIT as the version string. When CORE is true, build
package modules under SOURCE using CORE, an instance of Guix."
;; Running the self-build script makes it easier to update the build
;; procedure: the self-build script of the Guix-to-be-installed contains the
;; right dependencies, build procedure, etc., which the Guix-in-use may not
;; be know.
(define script
(string-append source "/" %self-build-file))
(if (file-exists? script)
(let ((build (save-module-excursion
(lambda ()
;; Disable deprecation warnings; it's OK for SCRIPT to
;; use deprecated APIs and the user doesn't have to know
;; about it.
(parameterize ((guix-warning-port
(%make-void-port "w")))
(primitive-load script)))))
(guile (guile-for-source source)))
;; BUILD must be a monadic procedure of at least one argument: the
;; source tree.
;;
;; Note: BUILD can return #f if it does not support %PULL-VERSION. In
;; the future we'll fall back to a previous version of the protocol
;; when that happens.
(with-guile guile
;; BUILD is usually quite costly. Install a "trivial" build handler
;; so we don't bounce an outer build-accumulator handler that could
;; cause us to redo half of the BUILD computation several times just
;; to realize it gives the same result.
(with-trivial-build-handler
(build source #:verbose? verbose? #:version commit
#:pull-version %pull-version))))
;; Build a set of modules that extend Guix using the standard method.
(standard-module-derivation name source core dependencies)))
(define* (build-channel-instance instance
#:optional core (dependencies '()))
"Return, as a monadic value, the derivation for INSTANCE, a channel
instance. DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on."
(build-from-source (symbol->string
(channel-name (channel-instance-channel instance)))
(channel-instance-checkout instance)
#:commit (channel-instance-commit instance)
#:core core
#:dependencies dependencies))
(define (resolve-dependencies instances)
"Return a procedure that, given one of the elements of INSTANCES, returns
list of instances it depends on."
(define channel-instance-name
(compose channel-name channel-instance-channel))
(define table ;map a name to an instance
(fold (lambda (instance table)
(vhash-consq (channel-instance-name instance)
instance table))
vlist-null
instances))
(define edges
(fold (lambda (instance edges)
(fold (lambda (channel edges)
(let ((name (channel-name channel)))
(match (vhash-assq name table)
((_ . target)
(vhash-consq instance target edges)))))
edges
(channel-instance-dependencies instance)))
vlist-null
instances))
(lambda (instance)
(vhash-foldq* cons '() instance edges)))
(define (channel-instance-derivations instances)
"Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
(define core-instance
;; The 'guix' channel is treated specially: it's an implicit dependency of
;; all the other channels.
(find (lambda (instance)
(guix-channel? (channel-instance-channel instance)))
instances))
(define edges
(resolve-dependencies instances))
(define (instance->derivation instance)
(mlet %store-monad ((system (current-system)))
(mcached (if (eq? instance core-instance)
(build-channel-instance instance)
(mlet %store-monad ((core (instance->derivation core-instance))
(deps (mapm %store-monad instance->derivation
(edges instance))))
(build-channel-instance instance core deps)))
instance
system)))
(unless core-instance
(let ((loc (and=> (any (compose channel-location channel-instance-channel)
instances)
source-properties->location)))
(raise (apply make-compound-condition
(condition
(&message (message "'guix' channel is lacking")))
(condition
(&fix-hint (hint (G_ "Make sure your list of channels
contains one channel named @code{guix} providing the core of Guix."))))
(if loc
(list (condition (&error-location (location loc))))
'())))))
(mapm %store-monad instance->derivation instances))
(define (whole-package-for-legacy name modules)
"Return a full-blown Guix package for MODULES, a derivation that builds Guix
modules in the old ~/.config/guix/latest style."
(define packages
(resolve-interface '(gnu packages guile)))
(define modules+compiled
;; Since MODULES contains both .scm and .go files at its root, re-bundle
;; it so that it has share/guile/site and lib/guile, which is what
;; 'whole-package' expects.
(computed-file (derivation-name modules)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(define version
(effective-version))
(define share
(string-append #$output "/share/guile/site"))
(define lib
(string-append #$output "/lib/guile/" version))
(mkdir-p share) (mkdir-p lib)
(symlink #$modules (string-append share "/" version))
(symlink #$modules (string-append lib "/site-ccache"))))))
(letrec-syntax ((list (syntax-rules (->)
((_)
'())
((_ (module -> variable) rest ...)
(cons (module-ref (resolve-interface
'(gnu packages module))
'variable)
(list rest ...)))
((_ variable rest ...)
(cons (module-ref packages 'variable)
(list rest ...))))))
(whole-package name modules+compiled
;; In the "old style", %SELF-BUILD-FILE would simply return a
;; derivation that builds modules. We have to infer what the
;; dependencies of these modules were.
(list guile-json-3 guile-git guile-bytestructures
(ssh -> guile-ssh) (tls -> gnutls)))))
(define (old-style-guix? drv)
"Return true if DRV corresponds to a ~/.config/guix/latest style of
derivation."
;; Here we rely on a gross historical fact: that derivations produced by the
;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
;; dated May 30, 2018) did not depend on "guix-command.drv".
(not (find (lambda (input)
(string=? "guix-command"
(derivation-name
(derivation-input-derivation input))))
(derivation-inputs drv))))
(define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
(define (instance->entry instance drv)
(let ((commit (channel-instance-commit instance))
(channel (channel-instance-channel instance)))
(manifest-entry
(name (symbol->string (channel-name channel)))
(version (string-take commit 7))
(item (if (guix-channel? channel)
(if (old-style-guix? drv)
(whole-package-for-legacy (string-append name "-" version)
drv)
drv)
drv))
(properties
`((source (repository
(version 0)
(url ,(channel-url channel))
(branch ,(channel-branch channel))
(commit ,commit))))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances))
(entries -> (map instance->entry instances derivations)))
(return (manifest entries))))
(define (package-cache-file manifest)
"Build a package cache file for the instance in MANIFEST. This is meant to
be used as a profile hook."
(let ((profile (profile (content manifest) (hooks '()))))
(define build
#~(begin
(use-modules (gnu packages))
(if (defined? 'generate-package-cache)
(begin
;; Delegate package cache generation to the inferior.
(format (current-error-port)
"Generating package cache for '~a'...~%"
#$profile)
(generate-package-cache #$output))
(mkdir #$output))))
(gexp->derivation-in-inferior "guix-package-cache" build
profile
;; If the Guix in PROFILE is too old and
;; lacks 'guix repl', don't build the cache
;; instead of failing.
#:silent-failure? #t
#:properties '((type . profile-hook)
(hook . package-cache))
#:local-build? #t)))
(define %channel-profile-hooks
;; The default channel profile hooks.
(cons package-cache-file %default-profile-hooks))
(define (channel-instances->derivation instances)
"Return the derivation of the profile containing INSTANCES, a list of
channel instances."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
(profile-derivation manifest
#:hooks %channel-profile-hooks)))
(define latest-channel-instances*
(store-lift latest-channel-instances))
(define* (latest-channel-derivation #:optional (channels %default-channels)
#:key
(current-channels '())
(validate-pull
ensure-forward-channel-update))
"Return as a monadic value the derivation that builds the profile for the
latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed
to 'latest-channel-instances'."
(mlet %store-monad ((instances
(latest-channel-instances* channels
#:current-channels
current-channels
#:validate-pull
validate-pull)))
(channel-instances->derivation instances)))
(define (profile-channels profile)
"Return the list of channels corresponding to entries in PROFILE. If
PROFILE is not a profile created by 'guix pull', return the empty list."
(filter-map (lambda (entry)
(match (assq 'source (manifest-entry-properties entry))
(('source ('repository ('version 0)
('url url)
('branch branch)
('commit commit)
_ ...))
(channel (name (string->symbol
(manifest-entry-name entry)))
(url url)
(commit commit)))
;; No channel information for this manifest entry.
;; XXX: Pre-0.15.0 Guix did not provide that information,
;; but there's not much we can do in that case.
(_ #f)))
;; Show most recently installed packages last.
(reverse
(manifest-entries (profile-manifest profile)))))
\f
;;;
;;; News.
;;;
;; Channel news.
(define-record-type <channel-news>
(channel-news entries)
channel-news?
(entries channel-news-entries)) ;list of <channel-news-entry>
;; News entry, associated with a specific commit of the channel.
(define-record-type <channel-news-entry>
(channel-news-entry commit tag title body)
channel-news-entry?
(commit channel-news-entry-commit) ;hex string | #f
(tag channel-news-entry-tag) ;#f | string
(title channel-news-entry-title) ;list of language tag/string pairs
(body channel-news-entry-body)) ;list of language tag/string pairs
(define (sexp->channel-news-entry entry)
"Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
(define (pair language message)
(cons (symbol->string language) message))
(match entry
(('entry ((and (or 'commit 'tag) type) commit-or-tag)
('title ((? symbol? title-tags) (? string? titles)) ...)
('body ((? symbol? body-tags) (? string? bodies)) ...)
_ ...)
(channel-news-entry (and (eq? type 'commit) commit-or-tag)
(and (eq? type 'tag) commit-or-tag)
(map pair title-tags titles)
(map pair body-tags bodies)))
(_
(raise (condition
(&message (message "invalid channel news entry"))
(&error-location
(location (source-properties->location
(source-properties entry)))))))))
(define (read-channel-news port)
"Read a channel news feed from PORT and return it as a <channel-news>
record."
(match (false-if-exception (read port))
(('channel-news ('version 0) entries ...)
(channel-news (map sexp->channel-news-entry entries)))
(('channel-news ('version version) _ ...)
;; This is an unsupported version from the future. There's nothing wrong
;; with that (the user may simply need to upgrade the 'guix' channel to
;; be able to read it), so silently ignore it.
(channel-news '()))
(#f
(raise (condition
(&message (message "syntactically invalid channel news file")))))
(sexp
(raise (condition
(&message (message "invalid channel news file"))
(&error-location
(location (source-properties->location
(source-properties sexp)))))))))
(define (resolve-channel-news-entry-tag repository entry)
"If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup
ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
the field its 'tag' refers to. A 'git-error' exception is raised if the tag
cannot be found."
(if (channel-news-entry-commit entry)
entry
(let* ((tag (channel-news-entry-tag entry))
(reference (string-append "refs/tags/" tag))
(oid (reference-name->oid repository reference)))
(channel-news-entry (oid->string oid) tag
(channel-news-entry-title entry)
(channel-news-entry-body entry)))))
(define* (channel-news-for-commit channel new #:optional old)
"Return a list of <channel-news-entry> for CHANNEL between commits OLD and
NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL."
(catch 'git-error
(lambda ()
(let* ((checkout (update-cached-checkout (channel-url channel)
#:ref `(commit . ,new)))
(metadata (read-channel-metadata-from-source checkout))
(news-file (channel-metadata-news-file metadata))
(news-file (and news-file
(string-append checkout "/" news-file))))
(if (and news-file (file-exists? news-file))
(with-repository checkout repository
(let* ((news (call-with-input-file news-file
read-channel-news))
(entries (map (lambda (entry)
(resolve-channel-news-entry-tag repository
entry))
(channel-news-entries news))))
(if old
(let* ((new (commit-lookup repository (string->oid new)))
(old (commit-lookup repository (string->oid old)))
(commits (list->set
(map (compose oid->string commit-id)
(commit-difference new old)))))
(filter (lambda (entry)
(set-contains? commits
(channel-news-entry-commit entry)))
entries))
entries)))
'())))
(lambda (key error . rest)
;; If commit NEW or commit OLD cannot be found, then something must be
;; wrong (for example, the history of CHANNEL was rewritten and these
;; commits no longer exist upstream), so quietly return the empty list.
(if (= GIT_ENOTFOUND (git-error-code error))
'()
(apply throw key error rest)))))
;;; Local Variables:
;;; eval: (put 'with-guile 'scheme-indent-function 1)
;;; End:
|