tracifyjs - Reverse engineer's tool for tracing the flow of data in JS program, based on UglifyJS

diff options
Diffstat (limited to 'test/compress/evaluate.js')
0 files changed, 0 insertions, 0 deletions
0' href='#n80'>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 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022, 2024 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
                                       version>?))
  #: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 certs) #:select (nss-certs))
  #: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)
            (sanitize validate-service-list))

  (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))

;;; XXX: Remove after a new release of Guix no longer suggests to install
;;; nss-certs.
(define (operating-system-packages os)
  "Return the packages of the OS <operating-system> record object."
  ;; This wrapper is used to warn users that their operating system packages
  ;; field contains a duplicated nss-certs packages.
  (let* ((packages (%operating-system-packages os))
         (nss-certs-packages (sort (filter (lambda (p)
                                             (and (package? p)
                                                  (string=? "nss-certs"
                                                            (package-name p))))
                                           packages)
                                   (lambda (x y)
                                     ;; Sort from newer to older versions.
                                     (version>? (package-version x)
                                                (package-version y))))))
    (if (> (length nss-certs-packages) 1)
        (begin
          (warning #f
                   (G_ "multiple 'nss-certs' packages found; 'nss-certs' \
is now included by default in '%base-packages'; ensure it is not explicitly \
listed in the operating system 'packages' field~%"))
          (let ((nss-certs-packages (delete-duplicates nss-certs-packages eq?)))
            (if (> (length nss-certs-packages) 1)
                ;; Only mismatched nss-certs packages need to be handled to
                ;; avoid profile collisions; same objects are later
                ;; deduplicated in `packages->profile-entry'.
                (fold delete packages (drop nss-certs-packages 1))
                packages)))             ;no-op
        packages)))

(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-ar7010-firmware
        ath9k-htc-ar9271-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
	nss-certs
        ;; 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

context:
space:
mode: