aboutsummaryrefslogtreecommitdiff
path: root/gnu/system.scm
blob: aede35775ef42d8b3470fa3625b270d217172171 (plain)
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
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <jannek@gnu.org>
;;; Copyright © 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; 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 (gnu system)
  #:use-module (guix inferior)
  #:use-module (guix store)
  #:use-module (guix memoization)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix deprecation)
  #:use-module (guix derivations)
  #:use-module (guix profiles)
  #:use-module ((guix utils) #:select (substitute-keyword-arguments))
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (guix ui)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages firmware)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages guile-xyz)
  #:use-module (gnu packages hurd)
  #:use-module (gnu packages less)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages man)
  #:use-module (gnu packages nvi)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages pciutils)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages text-editors)
  #:use-module (gnu packages wget)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services base)
  #:use-module (gnu bootloader)
  #:use-module (gnu system shadow)
  #:use-module (gnu system nss)
  #:use-module (gnu system locale)
  #:use-module (gnu system pam)
  #:use-module (gnu system linux-initrd)
  #:use-module (gnu system setuid)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-71)
  #:use-module (rnrs bytevectors)
  #:export (operating-system
            operating-system?
            this-operating-system

            operating-system-bootloader
            operating-system-services
            operating-system-essential-services
            operating-system-default-essential-services
            operating-system-user-services
            operating-system-packages
            operating-system-host-name
            operating-system-hosts-file ;deprecated
            operating-system-hurd
            operating-system-kernel
            operating-system-kernel-file
            operating-system-kernel-arguments
            operating-system-label
            operating-system-default-label
            operating-system-initrd-modules
            operating-system-initrd
            operating-system-users
            operating-system-groups
            operating-system-issue
            operating-system-timezone
            operating-system-locale
            operating-system-locale-definitions
            operating-system-locale-libcs
            operating-system-mapped-devices
            operating-system-file-systems
            operating-system-store-file-system
            operating-system-user-mapped-devices
            operating-system-boot-mapped-devices
            operating-system-bootloader-crypto-devices
            operating-system-activation-script
            operating-system-user-accounts
            operating-system-shepherd-service-names
            operating-system-user-kernel-arguments
            operating-system-firmware
            operating-system-keyboard-layout
            operating-system-name-service-switch
            operating-system-pam-services
            operating-system-setuid-programs
            operating-system-skeletons
            operating-system-sudoers-file
            operating-system-swap-devices
            operating-system-kernel-loadable-modules
            operating-system-location

            operating-system-derivation
            operating-system-profile
            operating-system-bootcfg
            operating-system-etc-directory
            operating-system-locale-directory
            operating-system-boot-script
            operating-system-uuid

            system-linux-image-file-name
            operating-system-with-gc-roots
            operating-system-with-provenance

            hurd-default-essential-services

            boot-parameters
            boot-parameters?
            boot-parameters-label
            boot-parameters-root-device
            boot-parameters-bootloader-name
            boot-parameters-bootloader-menu-entries
            boot-parameters-store-crypto-devices
            boot-parameters-store-device
            boot-parameters-store-directory-prefix
            boot-parameters-store-mount-point
            boot-parameters-locale
            boot-parameters-kernel
            boot-parameters-kernel-arguments
            boot-parameters-initrd
            boot-parameters-multiboot-modules
            boot-parameters-version
            %boot-parameters-version
            read-boot-parameters
            read-boot-parameters-file
            boot-parameters->menu-entry

            local-host-aliases                    ;deprecated
            %root-account
            %setuid-programs
            %sudoers-specification
            %base-packages
            %base-packages-artwork
            %base-packages-interactive
            %base-packages-linux
            %base-packages-networking
            %base-packages-disk-utilities
            %base-packages-utils
            %base-firmware
            %default-kernel-arguments))

;;; Commentary:
;;;
;;; This module supports whole-system configuration.
;;;
;;; Code:

(define* (bootable-kernel-arguments system root-device version)
  "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE.
VERSION is the target version of the boot-parameters record."
  ;; If the version is newer than 0, we use the new style initrd parameter
  ;; names, otherwise we use the legacy ones.  This is to maintain backward
  ;; compatibility when producing bootloader configurations for older
  ;; generations.
  (define version>0? (> version 0))
  (let ((root (file-system-device->string root-device
                                          #:uuid-type 'dce)))
    (append
     (if (string=? root "none")
         '() ;  Ignore the case where the root is "none" (typically tmpfs).
         ;; Note: Always use the DCE format because that's what
         ;; (gnu build linux-boot) expects for the 'root'
         ;; kernel command-line option.
         (list (string-append (if version>0? "root=" "--root=") root)))
     (list #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system)
           #~(string-append (if #$version>0? "gnu.load=" "--load=")
                            #$system "/boot")))))

;; System-wide configuration.

(define-with-syntax-properties (warn-hosts-file-field-deprecation
                                (value properties))
  (when value
    (warning (source-properties->location properties)
             (G_ "the 'hosts-file' field is deprecated, please use \
'hosts-service-type' instead~%")))
  value)

;; TODO: Add per-field docstrings/stexi.
(define-record-type* <operating-system> operating-system
  make-operating-system
  operating-system?
  this-operating-system

  (kernel operating-system-kernel                 ; package
          (default linux-libre))
  (kernel-loadable-modules operating-system-kernel-loadable-modules
                    (default '()))                ; list of packages
  (kernel-arguments operating-system-user-kernel-arguments
                    (default %default-kernel-arguments)) ; list of gexps/strings
  (hurd operating-system-hurd
        (default #f))                             ; package
  (bootloader operating-system-bootloader)        ; <bootloader-configuration>
  (label operating-system-label                   ; string
         (thunked)
         (default (operating-system-default-label this-operating-system)))

  (keyboard-layout operating-system-keyboard-layout ;#f | <keyboard-layout>
                   (default #f))
  (initrd operating-system-initrd                 ; (list fs) -> file-like
          (default base-initrd))
  (initrd-modules operating-system-initrd-modules ; list of strings
                  (thunked)                       ; it's system-dependent
                  (default %base-initrd-modules))

  (firmware operating-system-firmware             ; list of packages
            (default %base-firmware))

  (host-name operating-system-host-name)          ; string
  (hosts-file %operating-system-hosts-file         ; deprecated
              (default #f)
              (sanitize warn-hosts-file-field-deprecation))

  (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
                  (default '()))
  (file-systems operating-system-file-systems)    ; list of fs
  (swap-devices operating-system-swap-devices     ; list of string | <swap-space>
                (default '())
                (delayed)
                (sanitize warn-swap-devices-change))

  (users operating-system-users                   ; list of user accounts
         (default %base-user-accounts))
  (groups operating-system-groups                 ; list of user groups
          (default %base-groups))

  (skeletons operating-system-skeletons           ; list of name/file-like value
             (default (default-skeletons)))
  (issue operating-system-issue                   ; string
         (default %default-issue))

  (packages operating-system-packages             ; list of (PACKAGE OUTPUT...)
            (default %base-packages))             ; or just PACKAGE

  (timezone operating-system-timezone
            (default "Etc/UTC"))                  ; string
  (locale   operating-system-locale               ; string
            (default "en_US.utf8"))
  (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
                      (default %default-locale-definitions))
  (locale-libcs operating-system-locale-libcs     ; list of <packages>
                (default %default-locale-libcs))
  (name-service-switch operating-system-name-service-switch ; <name-service-switch>
                       (default %default-nss))

  (essential-services operating-system-essential-services ; list of services
                      (thunked)
                      (default (operating-system-default-essential-services
                                this-operating-system)))
  (services operating-system-user-services        ; list of services
            (thunked)                     ;allow for system-dependent services
            (default %base-services))

  (pam-services operating-system-pam-services     ; list of PAM services
                (default (base-pam-services)))
  (setuid-programs operating-system-setuid-programs
                   (default %setuid-programs)     ; list of <setuid-program>
                   (sanitize ensure-setuid-program-list))

  (sudoers-file operating-system-sudoers-file     ; file-like
                (default %sudoers-specification))

  (location operating-system-location             ; <location>
            (default (and=> (current-source-location)
                            source-properties->location))
            (innate)))

(define-deprecated (operating-system-hosts-file os)
  hosts-service-type
  (%operating-system-hosts-file os))

(define* (operating-system-kernel-arguments
          os root-device #:key (version %boot-parameters-version))
  "Return all the kernel arguments, including the ones not specified directly
by the user.  VERSION should match that of the target <boot-parameters> record
object that will contain the kernel parameters."
  (append (bootable-kernel-arguments os root-device version)
          (operating-system-user-kernel-arguments os)))


;;;
;;; Boot parameters
;;;

;;; Version 1 was introduced early 2022 to mark the departure from long option
;;; names such as '--load' to the more conventional initrd option names like
;;; 'gnu.load'.
;;;
;;; When bumping the boot-parameters version, increment it by one (1).
(define %boot-parameters-version 1)

(define-record-type* <boot-parameters>
  boot-parameters make-boot-parameters boot-parameters?
  (label            boot-parameters-label)
  ;; Because we will use the 'store-device' to create the GRUB search command,
  ;; the 'store-device' has slightly different semantics than 'root-device'.
  ;; The 'store-device' can be a file system uuid, a file system label, or #f,
  ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would
  ;; not understand that.  The 'root-device', on the other hand, corresponds
  ;; exactly to the device field of the <file-system> object representing the
  ;; OS's root file system, so it might be a device file name like
  ;; "/dev/sda3".  The 'store-directory-prefix' field contains #f or the store
  ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would
  ;; contain "/storefs" if the store is located in that subvolume of a btrfs
  ;; partition.
  (root-device      boot-parameters-root-device)
  (bootloader-name  boot-parameters-bootloader-name)
  (bootloader-menu-entries                        ;list of <menu-entry>
   boot-parameters-bootloader-menu-entries)
  (store-device     boot-parameters-store-device)
  (store-mount-point boot-parameters-store-mount-point)
  (store-directory-prefix boot-parameters-store-directory-prefix)
  (store-crypto-devices boot-parameters-store-crypto-devices
                        (default '()))
  (locale           boot-parameters-locale)
  (kernel           boot-parameters-kernel)
  (kernel-arguments boot-parameters-kernel-arguments)
  (initrd           boot-parameters-initrd)
  (multiboot-modules boot-parameters-multiboot-modules)
  (version          boot-parameters-version  ;positive integer
                    (default %boot-parameters-version)))

(define (ensure-not-/dev device)
  "If DEVICE starts with a slash, return #f.  This is meant to filter out
Linux device names such as /dev/sda, and to preserve GRUB device names and
file system labels."
  (if (and (string? device) (string-prefix? "/" device))
      #f
      device))

(define (read-boot-parameters port)
  "Read boot parameters from PORT and return the corresponding
<boot-parameters> object.  Raise an error if the format is unrecognized."
  (define device-sexp->device
    (match-lambda
      (('uuid (? symbol? type) (? bytevector? bv))
       (bytevector->uuid bv type))
      (('file-system-label (? string? label))
       (file-system-label label))
      ((? bytevector? bv)                         ;old format
       (bytevector->uuid bv 'dce))
      ((? string? device)
       (if (string-contains device ":/")
           device ; nfs-root
           ;; It used to be that we would not distinguish between labels and
           ;; device names.  Try to infer the right thing here.
           (if (string-prefix? "/" device)
               device
               (file-system-label device))))))
  (define uuid-sexp->uuid
    (match-lambda
      (('uuid (? symbol? type) (? bytevector? bv))
       (bytevector->uuid bv type))
      (x
       (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
       #f)))

  ;; New versions are not backward-compatible, so only accept past and current
  ;; versions, not future ones.
  (define (version? n)
    (member n (iota (1+ %boot-parameters-version))))

  (match (read port)
    (('boot-parameters ('version (? version? version))
                       ('label label) ('root-device root)
                       ('kernel kernel)
                       rest ...)
     (boot-parameters
      (version version)
      (label label)
      (root-device (device-sexp->device root))

      (bootloader-name
       (match (assq 'bootloader-name rest)
         ((_ args) args)
         (#f       'grub))) ; for compatibility reasons.

      (bootloader-menu-entries
       (match (assq 'bootloader-menu-entries rest)
         ((_ entries) (map sexp->menu-entry entries))
         (#f          '())))

      ;; In the past, we would store the directory name of linux instead of
      ;; the absolute file name of its image.  Detect that and correct it.
      (kernel (if (string=? kernel (direct-store-path kernel))
                  (string-append kernel "/"
                                 (system-linux-image-file-name))
                  kernel))

      (kernel-arguments
       (match (assq 'kernel-arguments rest)
         ((_ args) args)
         (#f       '())))                         ;the old format

      (initrd
       (match (assq 'initrd rest)
         (('initrd ('string-append directory file)) ;the old format
          (string-append directory file))
         (('initrd (? string? file))
          file)
         (#f #f)))

      (multiboot-modules
       (match (assq 'multiboot-modules rest)
         ((_ args) args)
         (#f       '())))

      (locale
       (match (assq 'locale rest)
         ((_ locale) locale)
         (#f         #f)))

      (store-device
       ;; Linux device names like "/dev/sda1" are not suitable GRUB device
       ;; identifiers, so we just filter them out.
       (ensure-not-/dev
        (match (assq 'store rest)
          (('store ('device #f) _ ...)
           root-device)
          (('store ('device device) _ ...)
           (device-sexp->device device))
          (_                                      ;the old format
           root-device))))

      (store-directory-prefix
       (match (assq 'store rest)
         (('store . store-data)
          (match (assq 'directory-prefix store-data)
            (('directory-prefix prefix) prefix)
            ;; No directory-prefix found.
            (_ #f)))
         (_
          ;; No store found, old format.
          #f)))

      (store-crypto-devices
       (match (assq 'store rest)
         (('store . store-data)
          (match (assq 'crypto-devices store-data)
            (('crypto-devices (devices ...))
             (map uuid-sexp->uuid devices))
            (('crypto-devices dev)
             (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
                      dev (port-filename port))
             '())
            (_
             ;; No crypto-devices found.
             '())))
         (_
          ;; No store found, old format.
          '())))

      (store-mount-point
       (match (assq 'store rest)
         (('store ('device _) ('mount-point mount-point) _ ...)
          mount-point)
         (_                                       ;the old format
          "/")))))
    (x                                            ;unsupported format
     (raise
      (make-compound-condition
       (formatted-message
        (G_ "unrecognized boot parameters at '~a'~%")
        (port-filename port))
       (condition
        (&fix-hint (hint (format #f (G_ "This probably means that this version
of Guix is older than the one that created @file{~a}.  To address this, you
need to update Guix:

@example
guix pull
@end example")
                                 (port-filename port))))))))))

(define (read-boot-parameters-file system)
  "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
file and returns the corresponding <boot-parameters> object or #f if the
format is unrecognized.
The object has its kernel-arguments extended in order to make it bootable."
  (let* ((file (string-append system "/parameters"))
         (params (call-with-input-file file read-boot-parameters))
         (root (boot-parameters-root-device params))
         (version (boot-parameters-version params)))
    (boot-parameters
     (inherit params)
     (kernel-arguments (append (bootable-kernel-arguments system root version)
                               (boot-parameters-kernel-arguments params))))))

(define (boot-parameters->menu-entry conf)
  "Return a <menu-entry> instance given CONF, a <boot-parameters> instance."
  (let* ((kernel (boot-parameters-kernel conf))
         (multiboot-modules (boot-parameters-multiboot-modules conf))
         (multiboot? (pair? multiboot-modules)))
    (menu-entry
     (label (boot-parameters-label conf))
     (device (boot-parameters-store-device conf))
     (device-mount-point (boot-parameters-store-mount-point conf))
     (linux (and (not multiboot?) kernel))
     (linux-arguments (if (not multiboot?)
                          (boot-parameters-kernel-arguments conf)
                          '()))
     (initrd (boot-parameters-initrd conf))
     (multiboot-kernel (and multiboot? kernel))
     (multiboot-arguments (if multiboot?
                              (boot-parameters-kernel-arguments conf)
                              '()))
     (multiboot-modules (if multiboot?
                            (boot-parameters-multiboot-modules conf)
                            '())))))


;;;
;;; Services.
;;;

(define (non-boot-file-system-service os)
  "Return the file system service for the file systems of OS that are not
marked as 'needed-for-boot'."
  (define file-systems
    (remove file-system-needed-for-boot?
            (operating-system-file-systems os)))

  (define mapped-devices-for-boot
    (operating-system-boot-mapped-devices os))

  (define (device-mappings fs)
    (let ((device (file-system-device fs)))
      (if (string? device)                        ;title is 'device
          (filter (lambda (md)
                    (any (cut string=? device <>)
                         (map (cut string-append "/dev/mapper" <>)
                              (mapped-device-targets md))))
                  (operating-system-mapped-devices os))
          '())))

  (define (add-dependencies fs)
    ;; Add the dependencies due to device mappings to FS.
    (file-system
      (inherit fs)
      (dependencies
       (delete-duplicates
        (remove (cut member <> mapped-devices-for-boot)
                (append (device-mappings fs)
                        (file-system-dependencies fs)))
        eq?))))

  (service file-system-service-type
           (map add-dependencies file-systems)))

(define (boot-file-system-service os)
  "Return a service which adds, to the system profile, packages providing the
utilities for the file systems marked as 'needed-for-boot' in OS."
  (let ((file-systems (filter file-system-needed-for-boot?
                              (operating-system-file-systems os))))
    (simple-service 'boot-file-system-utilities profile-service-type
                    (file-system-utilities file-systems))))

(define (mapped-device-users device file-systems)
  "Return the subset of FILE-SYSTEMS that use DEVICE."
  (let ((targets (map (cut string-append "/dev/mapper/" <>)
                      (mapped-device-targets device))))
    (filter (lambda (fs)
              (or (member device (file-system-dependencies fs))
                  (and (string? (file-system-device fs))
                       (any (cut string=? (file-system-device fs) <>) targets))))
            file-systems)))

(define (operating-system-user-mapped-devices os)
  "Return the subset of mapped devices that can be installed in
user-land--i.e., those not needed during boot."
  (let ((devices      (operating-system-mapped-devices os))
        (file-systems (operating-system-file-systems os)))
   (filter (lambda (md)
             (let ((users (mapped-device-users md file-systems)))
               (not (any file-system-needed-for-boot? users))))
           devices)))

(define (operating-system-boot-mapped-devices os)
  "Return the subset of mapped devices that must be installed during boot,
from the initrd."
  (let ((devices      (operating-system-mapped-devices os))
        (file-systems (operating-system-file-systems os)))
   (filter (lambda (md)
             (let ((users (mapped-device-users md file-systems)))
               (any file-system-needed-for-boot? users)))
           devices)))

(define operating-system-bootloader-crypto-devices
  (mlambdaq (os)                        ;to avoid duplicated output
    "Return the sources of the LUKS mapped devices specified by UUID."
    ;; XXX: Device ordering is important, we trust the returned one.
    (let* ((luks-devices (filter (lambda (m)
                                   (eq? luks-device-mapping
                                        (mapped-device-type m)))
                                 (operating-system-boot-mapped-devices os)))
           (uuid-crypto-devices non-uuid-crypto-devices
                                (partition (compose uuid? mapped-device-source)
                                           luks-devices)))
      (when (not (null? non-uuid-crypto-devices))
        (for-each (lambda (dev)
                    (warning
                     (source-properties->location (mapped-device-location dev))
                     (G_ "mapped device '~a' may be ignored by bootloader~%")
                     (mapped-device-source dev)))
                  non-uuid-crypto-devices)
        (display-hint "Specify mapped device sources via their LUKS UUID."))
      (map mapped-device-source uuid-crypto-devices))))

(define (device-mapping-services os)
  "Return the list of device-mapping services for OS as a list."
  (map device-mapping-service
       (operating-system-user-mapped-devices os)))

(define-syntax-rule (warn-swap-devices-change value)
  (%warn-swap-devices-change value (current-source-location)))

(define (%warn-swap-devices-change value location)
  (map (lambda (x)
         (unless (swap-space? x)
           (warning
            (source-properties->location
             location)
            (G_ "List elements of the field 'swap-devices' should \
now use the <swap-space> record, as the old method is deprecated. \
See \"(guix) operating-system Reference\" for more details.~%")))
         x) value))

(define (swap-services os)
  "Return the list of swap services for OS."
  (define early-userspace-file-systems
    (filter file-system-needed-for-boot?
            (operating-system-file-systems os)))

  (define early-userspace-mapped-devices
    (operating-system-boot-mapped-devices os))

  (define (filter-deps swap)
    (if (swap-space? swap)
        (swap-space
         (inherit swap)
         (dependencies (remove (lambda (dep)
                                 (or (member dep early-userspace-mapped-devices)
                                     (member dep early-userspace-file-systems)))
                               (swap-space-dependencies swap))))
        swap))

  (map (compose swap-service filter-deps)
       (operating-system-swap-devices os)))

(define* (system-linux-image-file-name #:optional
                                       (target (or (%current-target-system)
                                                   (%current-system))))
  "Return the basename of the kernel image file for TARGET."
  (cond
   ((string-prefix? "arm" target) "zImage")
   ((string-prefix? "mips" target) "vmlinuz")
   ((string-prefix? "aarch64" target) "Image")
   ((string-prefix? "riscv64" target) "Image")
   (else "bzImage")))

(define (operating-system-kernel-file os)
  "Return an object representing the absolute file name of the kernel image of
OS."
  (if (operating-system-hurd os)
      (file-append (operating-system-kernel os) "/boot/gnumach")
      (file-append (operating-system-kernel os)
                      "/" (system-linux-image-file-name))))

(define %default-modprobe-blacklist
  ;; List of kernel modules to blacklist by default.
  '("usbmouse" ;races with bcm5974, see <https://bugs.gnu.org/35574>
    "usbkbd")) ;races with usbhid, see <https://issues.guix.gnu.org/35574#18>

(define %default-kernel-arguments
  ;; Default arguments passed to the kernel.
  (list (string-append "modprobe.blacklist="
                       (string-join %default-modprobe-blacklist ","))
        "quiet"))

(define* (operating-system-directory-base-entries os)
  "Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
  (let* ((locale  (operating-system-locale-directory os))
         (kernel  (operating-system-kernel os))
         (hurd    (operating-system-hurd os))
         (initrd  (and (not hurd) (operating-system-initrd-file os)))
         (params  (operating-system-boot-parameters-file os)))
    `(,@(if hurd
          `(("hurd" ,hurd)
            ("kernel" ,kernel))
          '())
      ("parameters" ,params)
      ,@(if initrd `(("initrd" ,initrd)) '())
      ("locale" ,locale))))   ;used by libc

(define (operating-system-default-essential-services os)
  "Return the list of essential services for OS.  These are special services
that implement part of what's declared in OS are responsible for low-level
bookkeeping."
  (define known-fs
    (map file-system-mount-point (operating-system-file-systems os)))

  (let* ((mappings     (device-mapping-services os))
         (root-fs      (root-file-system-service))
         (boot-fs      (boot-file-system-service os))
         (non-boot-fs  (non-boot-file-system-service os))
         (swaps        (swap-services os))
         (procs        (service user-processes-service-type))
         (host-name    (operating-system-host-name os))
         (hosts-file   (%operating-system-hosts-file os))
         (entries      (operating-system-directory-base-entries os)))
    (cons* (service system-service-type entries)
           (service linux-builder-service-type
                    (linux-builder-configuration
                      (kernel   (operating-system-kernel os))
                      (modules  (operating-system-kernel-loadable-modules os))))
           %boot-service

           ;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that
           ;; execs shepherd comes last in the boot script (XXX).  Likewise,
           ;; the cleanup service must come first so that its gexp runs before
           ;; activation code.
           (service cleanup-service-type #f)
           %activation-service
           %shepherd-root-service

           (pam-root-service (operating-system-pam-services os))
           (account-service (append (operating-system-accounts os)
                                    (operating-system-groups os))
                            (operating-system-skeletons os))
           (operating-system-etc-service os)
           ;; XXX: hosts-file is deprecated
           (if hosts-file
               (simple-service 'deprecated-hosts-file etc-service-type
                               (list `("hosts" ,hosts-file)))
               (service hosts-service-type
                        (local-host-entries host-name)))
           (service fstab-service-type
                    (filter file-system-needed-for-boot?
                            (operating-system-file-systems os)))
           (session-environment-service
            (operating-system-environment-variables os))
           (service host-name-service-type host-name)
           procs root-fs
           (service setuid-program-service-type
                    (operating-system-setuid-programs os))
           (service profile-service-type
                    (operating-system-packages os))
           boot-fs non-boot-fs
           (append mappings swaps

                   ;; Add the firmware service.
                   (list %linux-bare-metal-service
                         (service firmware-service-type
                                  (operating-system-firmware os)))))))

(define (hurd-default-essential-services os)
  (let ((host-name    (operating-system-host-name os))
        (hosts-file   (%operating-system-hosts-file os))
        (entries      (operating-system-directory-base-entries os)))
    (list (service system-service-type entries)
          %boot-service
          %hurd-startup-service
          %activation-service
          (service shepherd-root-service-type)

          (service user-processes-service-type)
          (account-service (append (operating-system-accounts os)
                                   (operating-system-groups os))
                           (operating-system-skeletons os))
          (root-file-system-service)
          (service file-system-service-type '())
          (service fstab-service-type
                   (filter file-system-needed-for-boot?
                           (operating-system-file-systems os)))
          (pam-root-service (operating-system-pam-services os))
          (operating-system-etc-service os)
          ;; XXX: hosts-file is deprecated
          (if hosts-file
              (simple-service 'deprecated-hosts-file etc-service-type
                              (list `("hosts" ,hosts-file)))
              (service hosts-service-type
                       (local-host-entries host-name)))
          (service setuid-program-service-type
                   (operating-system-setuid-programs os))
          (service profile-service-type (operating-system-packages os)))))

(define* (operating-system-services os)
  "Return all the services of OS, including \"essential\" services."
  (instantiate-missing-services
   (append (operating-system-user-services os)
           (operating-system-essential-services os))))

(define (operating-system-with-gc-roots os roots)
  "Return a variant of OS where ROOTS are registered as GC roots."
  (operating-system
    (inherit os)

    ;; We use this procedure for the installation OS, which already defines GC
    ;; roots.  Add ROOTS to those.
    (services (cons (simple-service 'extra-root
                                    gc-root-service-type roots)
                    (operating-system-user-services os)))))

(define (operating-system-configuration-file os)
  "Return the configuration file of OS, based on its 'location' field, or #f
if it could not be determined."
  (let ((file (and=> (operating-system-location os)
                     location-file)))
    (and file
         (or (and (string-prefix? "/" file) file)
             (search-path %load-path file)))))

(define* (operating-system-with-provenance os
                                           #:optional
                                           (config-file
                                            (operating-system-configuration-file
                                             os)))
  "Return a variant of OS that stores its own provenance information,
including CONFIG-FILE, if available.  This is achieved by adding an instance
of PROVENANCE-SERVICE-TYPE to its services."
  (operating-system
    (inherit os)
    (services (cons (service provenance-service-type config-file)
                    (operating-system-user-services os)))))


;;;
;;; /etc.
;;;

(define %base-firmware
  ;; Firmware usable by default.
  (list ath9k-htc-firmware
        openfwwf-firmware))

(define %base-packages-artwork
  ;; Default set of artwork packages.
  (list guix-icons))

(define %base-packages-utils
  ;; Default set of  utilities packages.
 (cons* procps psmisc which
        shadow                          ;for 'passwd'

        e2fsprogs                 ;for lsattr, chattr, etc.

        guile-3.0-latest

        ;; The packages below are also in %FINAL-INPUTS, so take them from
        ;; there to avoid duplication.
        (list bash coreutils findutils grep sed
              diffutils patch gawk tar gzip bzip2 xz lzip)))

(define %base-packages-linux
  ;; Default set of linux specific packages.
  (list pciutils usbutils
        util-linux+udev
        ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
        ;; already depends on it anyway.
        kmod eudev))

(define %base-packages-interactive
  ;; Default set of common interactive packages.
  (list less mg nano
        nvi
        man-db
        info-reader                     ;the standalone Info reader (no Perl)
        bash-completion
        kbd
        ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
        ;; want the other commands and the man pages (notably because
        ;; auto-completion in Emacs shell relies on man pages.)
        sudo
        guile-readline guile-colorized))

(define %base-packages-networking
  ;; Default set of networking packages.
  (list inetutils isc-dhcp
        iproute
        wget
        ;; wireless-tools is deprecated in favor of iw, but it's still what
        ;; many people are familiar with, so keep it around.
        iw wireless-tools))

(define-deprecated %base-packages-disk-utilities #f '())

(define %base-packages
  ;; Default set of packages globally visible.  It should include anything
  ;; required for basic administrator tasks.
  (append %base-packages-artwork
          %base-packages-interactive
          %base-packages-linux
          %base-packages-networking
          %base-packages-utils))

(define %default-issue
  ;; Default contents for /etc/issue.
  "
This is the GNU system.  Welcome.\n")

(define-deprecated (local-host-aliases host-name)
  local-host-entries
  "Return aliases for HOST-NAME, to be used in /etc/hosts."
  (string-append "127.0.0.1 localhost " host-name "\n"
                 "::1       localhost " host-name "\n"))

(define (local-host-entries host-name)
  "Return <host> records for @var{host-name}."
  (map (lambda (address)
         (host address "localhost" (list host-name)))
       '("127.0.0.1" "::1")))

(define (validated-sudoers-file file)
  "Return a copy of FILE, a sudoers file, after checking that it is
syntactically correct."
  (computed-file "sudoers"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils))

                       (invoke #+(file-append sudo "/sbin/visudo")
                               "--check" "--file" #$file)
                       (copy-file #$file #$output)))))

(define os-release
  (plain-file "os-release" "\
NAME=\"Guix System\"
ID=guix
PRETTY_NAME=\"Guix System\"
LOGO=guix-icon
HOME_URL=\"https://guix.gnu.org\"
DOCUMENTATION_URL=\"https://guix.gnu.org/en/manual\"
SUPPORT_URL=\"https://guix.gnu.org/en/help\"
BUG_REPORT_URL=\"https://lists.gnu.org/mailman/listinfo/bug-guix\"
"))

(define* (operating-system-etc-service os)
  "Return a <service> that builds a directory containing the static part of
the /etc directory."
  (let* ((login.defs
          (plain-file "login.defs"
                      (string-append
                        "# Default paths for non-login shells started by su(1).\n"
                        "ENV_PATH    /run/setuid-programs:"
                        "/run/current-system/profile/bin:"
                        "/run/current-system/profile/sbin\n"
                        "ENV_SUPATH  /run/setuid-programs:"
                        "/run/current-system/profile/bin:"
                        "/run/current-system/profile/sbin\n"

                        "\n"
                        "# Allow 'chfn' to change the full name,\n"
                        "# room number, and so on.\n"
                        "CHFN_RESTRICT   frwh\n")))

         (hurd       (operating-system-hurd os))
         (issue      (plain-file "issue" (operating-system-issue os)))
         (nsswitch   (and=> (operating-system-name-service-switch os)
                            (compose (cut plain-file "nsswitch.conf" <>)
                                     name-service-switch->string)))
         (sudoers    (operating-system-sudoers-file os))

        ;; Startup file for POSIX-compliant login shells, which set system-wide
        ;; environment variables.
        (profile    (mixed-text-file "profile"  "\
# Crucial variables that could be missing in the profiles' 'etc/profile'
# because they would require combining both profiles.
# FIXME: See <http://bugs.gnu.org/20255>.
export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg

# Make sure libXcursor finds cursors installed into user or system profiles.  See <http://bugs.gnu.org/24445>
export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons

# Ignore the default value of 'PATH'.
unset PATH

# Load the system profile's settings.
GUIX_PROFILE=/run/current-system/profile ; \\
. /run/current-system/profile/etc/profile

# Since 'lshd' does not use pam_env, /etc/environment must be explicitly
# loaded when someone logs in via SSH.  See <http://bugs.gnu.org/22175>.
# We need 'PATH' to be defined here, for 'cat' and 'cut'.  Do this before
# reading the user's 'etc/profile' to allow variables to be overridden.
if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
     -a -z \"$LINUX_MODULE_DIRECTORY\" ]
then
  . /etc/environment
  export `cat /etc/environment | cut -d= -f1`
fi

# Arrange so that ~/.config/guix/current comes first.
for profile in \"$HOME/.guix-profile\" \"$HOME/.config/guix/current\"
do
  if [ -f \"$profile/etc/profile\" ]
  then
    # Load the user profile's settings.
    GUIX_PROFILE=\"$profile\" ; \\
    . \"$profile/etc/profile\"
  else
    # At least define this one so that basic things just work
    # when the user installs their first package.
    export PATH=\"$profile/bin:$PATH\"
  fi
done

# Prepend setuid programs.
export PATH=/run/setuid-programs:$PATH

# Arrange so that ~/.config/guix/current/share/info comes first.
export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\"

# Set the umask, notably for users logging in via 'lsh'.
# See <http://bugs.gnu.org/22650>.
umask 022

# Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to
# find dictionaries.
export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\"

# Allow GStreamer-based applications to find plugins.
export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"

if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
then
  # Load Bash-specific initialization code.
  . /etc/bashrc
fi
"))

        (bashrc    (plain-file "bashrc" "\
# Bash-specific initialization.

# Provide a default prompt.  The user's ~/.bashrc can override it.
PS1='\\u@\\h \\w${GUIX_ENVIRONMENT:+ [env]}\\$ '

# The 'bash-completion' package.
if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
then
  # Bash-completion sources ~/.bash_completion.  It installs a dynamic
  # completion loader that searches its own completion files as well
  # as those in ~/.guix-profile and /run/current-system/profile.
  source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")))
    (service etc-service-type
     `(("os-release" ,os-release)
       ("services" ,(file-append net-base "/etc/services"))
       ("protocols" ,(file-append net-base "/etc/protocols"))
       ("rpc" ,(file-append net-base "/etc/rpc"))
       ("login.defs" ,login.defs)
       ("issue" ,issue)
       ,@(if nsswitch `(("nsswitch.conf" ,nsswitch)) '())
       ("profile" ,profile)
       ("bashrc" ,bashrc)
       ;; Write the operating-system-host-name to /etc/hostname to prevent
       ;; NetworkManager from changing the system's hostname when connecting
       ;; to certain networks.  Some discussion at
       ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
       ("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
       ;; Some programs (e.g., GLib) look at /etc/timezone to find the
       ;; name of the current timezone.  For details, see
       ;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html
       ;; Some programs expect a terminating newline.
       ("timezone" ,(plain-file "timezone"
                                (string-append
                                 (string-trim-both
                                  (operating-system-timezone os))
                                 "\n")))
       ("localtime" ,(file-append tzdata "/share/zoneinfo/"
                                  (operating-system-timezone os)))
       ,@(if sudoers
             `(("sudoers" ,(validated-sudoers-file sudoers)))
             '())
       ,@(if hurd
             `(("login" ,(file-append hurd "/etc/login"))
               ("motd"  ,(file-append hurd "/etc/motd"))
               ("ttys"  ,(file-append hurd "/etc/ttys")))
             '())))))

(define %root-account
  ;; Default root account.
  (user-account
   (name "root")
   (password "")
   (uid 0) (group "root")
   (comment "System administrator")
   (home-directory "/root")))

(define (operating-system-accounts os)
  "Return the user accounts for OS, including an obligatory 'root' account,
and excluding accounts requested by services."
  ;; Make sure there's a root account.
  (if (find (lambda (user)
              (and=> (user-account-uid user) zero?))
            (operating-system-users os))
      (operating-system-users os)
      (cons %root-account (operating-system-users os))))

(define (maybe-string->file file-name thing)
  "If THING is a string, return a <plain-file> with THING as its content.
Otherwise just return THING.

This is for backward-compatibility of fields that used to be strings and are
now file-like objects.."
  (match thing
    ((? string?)
     (warning (G_ "using a string for file '~a' is deprecated; \
use 'plain-file' instead~%")
              file-name)
     (plain-file file-name thing))
    (x
     x)))

(define (maybe-file->monadic file-name thing)
  "If THING is a value in %STORE-MONAD, return it as is; otherwise return
THING in the %STORE-MONAD.

This is for backward-compatibility of fields that used to be monadic values
and are now file-like objects."
  (with-monad %store-monad
    (match thing
      ((? procedure?)
       (warning (G_ "using a monadic value for '~a' is deprecated; \
use 'plain-file' instead~%")
                file-name)
       thing)
      (x
       (return x)))))

(define (operating-system-etc-directory os)
  "Return that static part of the /etc directory of OS."
  (etc-directory
   (fold-services (operating-system-services os)
                  #:target-type etc-service-type)))

(define (operating-system-environment-variables os)
  "Return the environment variables of OS for
@var{session-environment-service-type}, to be used in @file{/etc/environment}."
  `(("LANG" . ,(operating-system-locale os))
    ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2)
    ;; it doesn't work for setuid binaries.  See <https://bugs.gnu.org/29212>.
    ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
    ;; Tell 'modprobe' & co. where to look for modules.
    ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
    ;; These variables are honored by OpenSSL (libssl) and Git.
    ("SSL_CERT_DIR" . "/etc/ssl/certs")
    ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
    ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")

    ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
    ;; searched for.
    ("GTK_DATA_PREFIX" . "/run/current-system/profile")

    ;; By default, applications that use D-Bus, such as Emacs, abort at startup
    ;; when /etc/machine-id is missing.  Make sure these warnings are non-fatal.
    ("DBUS_FATAL_WARNINGS" . "0")))

;; Ensure LST is a list of <setuid-program> records and warn otherwise.
(define-with-syntax-properties (ensure-setuid-program-list (lst properties))
  (%ensure-setuid-program-list lst properties))

;; We want to be able to use defines, so define a procedure.
(define (%ensure-setuid-program-list lst properties)
  (define warned? #f)

  (define (warn-once)
    (unless warned?
      (warning (source-properties->location properties)
               (G_ "representing setuid programs with file-like objects is \
deprecated; use 'setuid-program' instead~%"))
      (set! warned? #t)))

  (map (match-lambda
         ((? setuid-program? program)
          program)
         (program
          ;; PROGRAM is a file-like or a gexp like #~(string-append #$foo
          ;; "/bin/bar").
          (warn-once)
          (setuid-program (program program))))
       lst))

(define %setuid-programs
  ;; Default set of setuid-root programs.
  (let ((shadow (@ (gnu packages admin) shadow)))
    (map file-like->setuid-program
         (list (file-append shadow "/bin/passwd")
               (file-append shadow "/bin/chfn")
               (file-append shadow "/bin/sg")
               (file-append shadow "/bin/su")
               (file-append shadow "/bin/newgrp")
               (file-append shadow "/bin/newuidmap")
               (file-append shadow "/bin/newgidmap")
               (file-append inetutils "/bin/ping")
               (file-append inetutils "/bin/ping6")
               (file-append sudo "/bin/sudo")
               (file-append sudo "/bin/sudoedit")
               (file-append fuse-2 "/bin/fusermount")
               (file-append fuse "/bin/fusermount3")

               ;; To allow mounts with the "user" option, "mount" and "umount" must
               ;; be setuid-root.
               (file-append util-linux "/bin/mount")
               (file-append util-linux "/bin/umount")))))

(define %sudoers-specification
  ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
  ;; group can do anything.  See
  ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
  ;; TODO: Add a declarative API.
  (plain-file "sudoers" "\
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))

(define* (operating-system-activation-script os)
  "Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories,
etc."
  (let* ((services   (operating-system-services os))
         (activation (fold-services services
                                    #:target-type activation-service-type)))
    (activation-service->script activation)))

(define* (operating-system-boot-script os)
  "Return the boot script for OS---i.e., the code started by the initrd once
we're running in the final root."
  (let* ((services (operating-system-services os))
         (boot     (fold-services services #:target-type boot-service-type)))
    (service-value boot)))

(define (operating-system-user-accounts os)
  "Return the list of user accounts of OS."
  (let* ((services (operating-system-services os))
         (account  (fold-services services
                                  #:target-type account-service-type)))
    (filter user-account?
            (service-value account))))

(define (operating-system-shepherd-service-names os)
  "Return the list of Shepherd service names for OS."
  (append-map shepherd-service-provision
              (shepherd-configuration-services
               (service-value
                (fold-services (operating-system-services os)
                               #:target-type
                               shepherd-root-service-type)))))

(define* (operating-system-derivation os)
  "Return a derivation that builds OS."
  (let* ((services (operating-system-services os))
         (system   (fold-services services)))
    ;; SYSTEM contains the derivation as a monadic value.
    (service-value system)))

(define* (operating-system-profile os)
  "Return a derivation that builds the system profile of OS."
  (mlet* %store-monad
      ((services -> (operating-system-services os))
       (profile (fold-services services
                               #:target-type profile-service-type)))
    (match profile
      (("profile" profile)
       (return profile)))))

(define (operating-system-root-file-system os)
  "Return the root file system of OS."
  (or (find (lambda (fs)
              (string=? "/" (file-system-mount-point fs)))
            (operating-system-file-systems os))
      (raise (condition
              (&message (message "missing root file system"))
              (&error-location
               (location (operating-system-location os)))))))

(define (operating-system-initrd-file os)
  "Return a gexp denoting the initrd file of OS."
  (define boot-file-systems
    (filter file-system-needed-for-boot?
            (operating-system-file-systems os)))

  (define mapped-devices
    (operating-system-boot-mapped-devices os))

  (define make-initrd
    (operating-system-initrd os))

  (make-initrd boot-file-systems
               #:linux (operating-system-kernel os)
               #:linux-modules
               (operating-system-initrd-modules os)
               #:mapped-devices mapped-devices
               #:keyboard-layout (operating-system-keyboard-layout os)))

(define* (operating-system-uuid os #:optional (type 'dce))
  "Compute UUID object with a deterministic \"UUID\" for OS, of the given
TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
  ;; Note: For this to be deterministic, we must not hash things that contains
  ;; (directly or indirectly) procedures, for example.  That rules out
  ;; anything that contains gexps, thunk or delayed record fields, etc.

  (define service-name
    (compose service-type-name service-kind))

  (define (file-system-digest fs)
    ;; Return a hashable digest that does not contain 'dependencies' since
    ;; this field can contain procedures.
    (let ((device (file-system-device fs)))
      (list (file-system-mount-point fs)
            (file-system-type fs)
            (file-system-device->string device)
            (file-system-options fs))))

  (if (eq? type 'iso9660)
      (let ((pad (compose (cut string-pad <> 2 #\0)
                          number->string))
            (h   (hash (map service-name (operating-system-services os))
                       3600)))
        (bytevector->uuid
         (string->iso9660-uuid
          (string-append "1970-01-01-"
                         (pad (hash (operating-system-host-name os) 24)) "-"
                         (pad (quotient h 60)) "-"
                         (pad (modulo h 60)) "-"
                         (pad (hash (map file-system-digest
                                         (operating-system-file-systems os))
                                    100))))
         'iso9660))
      (bytevector->uuid
       (uint-list->bytevector
        (list (hash (map file-system-digest
                         (operating-system-file-systems os))
                    (- (expt 2 32) 1))
              (hash (operating-system-host-name os)
                    (- (expt 2 32) 1))
              (hash (map service-name (operating-system-services os))
                    (- (expt 2 32) 1))
              (hash (map file-system-digest (operating-system-file-systems os))
                    (- (expt 2 32) 1)))
        (endianness little)
        4)
       type)))

(define (locale-name->definition* name)
  "Variant of 'locale-name->definition' that raises an error upon failure."
  (match (locale-name->definition name)
    (#f
     (raise (formatted-message (G_ "~a: invalid locale name") name)))
    (def def)))

(define (operating-system-locale-directory os)
  "Return the directory containing the locales compiled for the definitions
listed in OS.  The C library expects to find it under
/run/current-system/locale."
  (define name
    (operating-system-locale os))

  (define definitions
    ;; While we're at it, check whether NAME is defined and add it if needed.
    (if (member name (map locale-definition-name
                          (operating-system-locale-definitions os)))
        (operating-system-locale-definitions os)
        (cons (locale-name->definition* name)
              (operating-system-locale-definitions os))))

  (locale-directory definitions
                    #:libcs (operating-system-locale-libcs os)))

(define* (kernel->boot-label kernel #:key hurd)
  "Return a label for the bootloader menu entry that boots KERNEL."
  (cond ((package? hurd)
         (string-append "GNU with the "
                        (string-titlecase (package-name hurd)) " "
                        (package-version hurd)))
        ((package? kernel)
         (string-append "GNU with "
                        (string-titlecase (package-name kernel)) " "
                        (package-version kernel)))
        ((inferior-package? kernel)
         (string-append "GNU with "
                        (string-titlecase (inferior-package-name kernel)) " "
                        (inferior-package-version kernel)))
        (else "GNU")))

(define (operating-system-default-label os)
  "Return the default label for OS, as it will appear in the bootloader menu
entry."
  (kernel->boot-label (operating-system-kernel os)
                      #:hurd (operating-system-hurd os)))

(define (store-file-system file-systems)
  "Return the file system object among FILE-SYSTEMS that contains the store."
  (match (filter (lambda (fs)
                   (and (file-system-mount? fs)
                        (not (memq 'bind-mount (file-system-flags fs)))
                        (string-prefix? (file-system-mount-point fs)
                                        (%store-prefix))))
                 file-systems)
    ((and candidates (head . tail))
     (reduce (lambda (fs1 fs2)
               (if (> (string-length (file-system-mount-point fs1))
                      (string-length (file-system-mount-point fs2)))
                   fs1
                   fs2))
             head
             candidates))))

(define (operating-system-store-file-system os)
  "Return the file system that contains the store of OS."
  (store-file-system (operating-system-file-systems os)))

(define* (operating-system-bootcfg os #:optional (old-entries '()))
  "Return the bootloader configuration file for OS.  Use OLD-ENTRIES,
a list of <menu-entry>, to populate the \"old entries\" menu."
  (let* ((file-systems    (operating-system-file-systems os))
         (root-fs         (operating-system-root-file-system os))
         (root-device     (file-system-device root-fs))
         (locale          (operating-system-locale os))
         (crypto-devices  (operating-system-bootloader-crypto-devices os))
         (params          (operating-system-boot-parameters
                           os root-device
                           #:system-kernel-arguments? #t))
         (entry           (boot-parameters->menu-entry params))
         (bootloader-conf (operating-system-bootloader os)))

    (define generate-config-file
      (bootloader-configuration-file-generator
       (bootloader-configuration-bootloader bootloader-conf)))

    (generate-config-file bootloader-conf (list entry)
                          #:old-entries old-entries
                          #:locale locale
                          #:store-crypto-devices crypto-devices
                          #:store-directory-prefix
			  (btrfs-store-subvolume-file-name file-systems))))

(define (operating-system-multiboot-modules os)
  (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))

(define (hurd-multiboot-modules os)
  (let* ((hurd (operating-system-hurd os))
         (pci-arbiter-command
          (list (file-append hurd "/hurd/pci-arbiter.static")
                "pci-arbiter"
                "--host-priv-port='${host-port}'"
                "--device-master-port='${device-port}'"
                "--next-task='${disk-task}'"
                "'$(pci-task=task-create)'"
                "'$(task-resume)'"))
         (rumpdisk-command
          (list (file-append hurd "/hurd/rumpdisk.static")
                "rumpdisk"
                "--next-task='${fs-task}'"
                "'$(disk-task=task-create)'"))
         (root-file-system-command
          (list (file-append hurd "/hurd/ext2fs.static")
                "ext2fs"
                "--multiboot-command-line='${kernel-command-line}'"
                "--exec-server-task='${exec-task}'"
                "--store-type=typed"
                "--x-xattr-translator-records"
                "'${root}'"
                "'$(fs-task=task-create)'"))
         (target (%current-target-system))
         (libc (if target
                   (with-parameters ((%current-target-system #f))
                     ;; TODO: cross-libc has extra patches for the Hurd;
                     ;; remove in next rebuild cycle
                     (cross-libc target))
                   glibc))
         (exec-server-command
          ;; XXX: Run the statically-linked 'exec' to work around
          ;; <https://issues.guix.gnu.org/58320>, which manifests on some
          ;; machines.

          ;; (list (file-append libc "/lib/ld.so.1") "exec"
          ;;       (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")
          (list (file-append hurd "/hurd/exec.static") "exec"
                "'$(exec-task=task-create)'")))
    (list pci-arbiter-command
          rumpdisk-command
          root-file-system-command
          exec-server-command)))

(define* (operating-system-boot-parameters os root-device
                                           #:key system-kernel-arguments?)
  "Return a monadic <boot-parameters> record that describes the boot
parameters of OS.  When SYSTEM-KERNEL-ARGUMENTS? is true, add the kernel
arguments 'root', 'gnu.load' and 'gnu.system' to <boot-parameters>.  The
SYSTEM-KERNEL-ARGUMENTS? should only be used in necessity, as the 'gnu.load'
and 'gnu.system' values are self-referential (they refer to the system), thus
susceptible to introduce a cyclic dependency."
  (let* ((initrd          (and (not (operating-system-hurd os))
                               (operating-system-initrd-file os)))
         (store           (operating-system-store-file-system os))
         (file-systems    (operating-system-file-systems os))
         (crypto-devices  (operating-system-bootloader-crypto-devices os))
         (locale          (operating-system-locale os))
         (bootloader      (bootloader-configuration-bootloader
                           (operating-system-bootloader os)))
         (bootloader-name (bootloader-name bootloader))
         (label           (operating-system-label os))
         (multiboot-modules (operating-system-multiboot-modules os)))
    (boot-parameters
     (label label)
     (root-device root-device)
     (kernel (operating-system-kernel-file os))
     (kernel-arguments
      (if system-kernel-arguments?
          (operating-system-kernel-arguments os root-device)
          (operating-system-user-kernel-arguments os)))
     (initrd initrd)
     (multiboot-modules multiboot-modules)
     (bootloader-name bootloader-name)
     (bootloader-menu-entries
      (bootloader-configuration-menu-entries (operating-system-bootloader os)))
     (locale locale)
     (store-device (ensure-not-/dev (file-system-device store)))
     (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
     (store-crypto-devices crypto-devices)
     (store-mount-point (file-system-mount-point store)))))

(define (device->sexp device)
  "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
  (match device
    ((? uuid? uuid)
     `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
    ((? file-system-label? label)
     `(file-system-label ,(file-system-label->string label)))
    (_
     device)))

(define* (operating-system-boot-parameters-file os)
   "Return a file that describes the boot parameters of OS.  The primary use
of this file is the reconstruction of GRUB menu entries for old
configurations."
   (let* ((root   (operating-system-root-file-system os))
          (device (file-system-device root))
          (params (operating-system-boot-parameters os device)))
     (scheme-file "parameters"
                  #~(boot-parameters
                     (version #$(boot-parameters-version params))
                     (label #$(boot-parameters-label params))
                     (root-device
                      #$(device->sexp
                         (boot-parameters-root-device params)))
                     (kernel #$(boot-parameters-kernel params))
                     (kernel-arguments
                      #$(boot-parameters-kernel-arguments params))
                     #$@(if (boot-parameters-initrd params)
                            #~((initrd #$(boot-parameters-initrd params)))
                            #~())
                     #$@(if (pair? (boot-parameters-multiboot-modules params))
                            #~((multiboot-modules
                                #$(boot-parameters-multiboot-modules params)))
                            #~())
                     (bootloader-name #$(boot-parameters-bootloader-name params))
                     (bootloader-menu-entries
                      #$(map menu-entry->sexp
                             (or (and=> (operating-system-bootloader os)
                                        bootloader-configuration-menu-entries)
                                 '())))
                     (locale #$(boot-parameters-locale params))
                     (store
                      (device
                       #$(device->sexp (boot-parameters-store-device params)))
                      (mount-point #$(boot-parameters-store-mount-point
                                      params))
                      (directory-prefix
                       #$(boot-parameters-store-directory-prefix params))
                      (crypto-devices
                       #$(map device->sexp
                              (boot-parameters-store-crypto-devices params)))))
                  #:set-load-path? #f)))

(define-gexp-compiler (operating-system-compiler (os <operating-system>)
                                                 system target)
  ((store-lift
    (lambda (store)
      ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
      ;; 'operating-system-derivation'.
      (parameterize ((%current-system system)
                     (%current-target-system target))
        (run-with-store store
          (mbegin %store-monad
            (set-guile-for-build (default-guile))
            (operating-system-derivation os))
          #:system system
          #:target target))))))

;;; system.scm ends here