aboutsummaryrefslogtreecommitdiff
path: root/tests/cve.scm
blob: b69da0e1204c9c9ee20e77087718f8981ece369b (about) (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
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-cve)
  #:use-module (guix cve)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-64))

(define %sample
  (search-path %load-path "tests/cve-sample.json"))

(define (vulnerability id packages)
  (make-struct/no-tail (@@ (guix cve) <vulnerability>) id packages))

(define %expected-vulnerabilities
  ;; What we should get when reading %SAMPLE.
  (list
   (vulnerability "CVE-2019-0001"
                  ;; Only the "a" CPE configurations are kept; the "o"
                  ;; configurations are discarded.
                  '(("junos" (or "18.21-s4" (or "18.21-s3" "18.2")))))
   (vulnerability "CVE-2019-0005"
                  '(("junos" (or "18.11" "18.1"))))
   ;; CVE-2019-0005 has no "a" configurations.
   (vulnerability "CVE-2019-14811"
                  '(("ghostscript" (< "9.28"))))
   (vulnerability "CVE-2019-17365"
                  '(("nix" (<= "2.3"))))
   (vulnerability "CVE-2019-1010180"
                  '(("gdb" _)))                   ;any version
   (vulnerability "CVE-2019-1010204"
                  '(("binutils" (and (>= "2.21") (<= "2.31.1")))
                    ("binutils_gold" (and (>= "1.11") (<= "1.16")))))
   ;; CVE-2019-18192 has no associated configurations.
   ))


(test-begin "cve")

(test-equal "json->cve-items"
  '("CVE-2019-0001"
    "CVE-2019-0005"
    "CVE-2019-14811"
    "CVE-2019-17365"
    "CVE-2019-1010180"
    "CVE-2019-1010204"
    "CVE-2019-18192")
  (map (compose cve-id cve-item-cve)
       (call-with-input-file %sample json->cve-items)))

(test-equal "cve-item-published-date"
  '(2019)
  (delete-duplicates
   (map (compose date-year cve-item-published-date)
        (call-with-input-file %sample json->cve-items))))

(test-equal "json->vulnerabilities"
  %expected-vulnerabilities
  (call-with-input-file %sample json->vulnerabilities))

(test-equal "vulnerabilities->lookup-proc"
  (list (list (third %expected-vulnerabilities))  ;ghostscript
        (list (third %expected-vulnerabilities))
        '()

        (list (fifth %expected-vulnerabilities))  ;gdb
        (list (fifth %expected-vulnerabilities))

        (list (fourth %expected-vulnerabilities)) ;nix
        '()

        (list (sixth %expected-vulnerabilities))  ;binutils
        '()
        (list (sixth %expected-vulnerabilities))
        '())
  (let* ((vulns  (call-with-input-file %sample json->vulnerabilities))
         (lookup (vulnerabilities->lookup-proc vulns)))
    (list (lookup "ghostscript")
          (lookup "ghostscript" "9.27")
          (lookup "ghostscript" "9.28")
          (lookup "gdb")
          (lookup "gdb" "42.0")
          (lookup "nix")
          (lookup "nix" "2.4")
          (lookup "binutils" "2.31.1")
          (lookup "binutils" "2.10")
          (lookup "binutils_gold" "1.11")
          (lookup "binutils" "2.32"))))

(test-end "cve")
e "linux-modules" build-exp)) (define* (raw-initrd file-systems #:key (linux linux-libre) (linux-modules '()) (pre-mount #t) (mapped-devices '()) (keyboard-layout #f) (helper-packages '()) qemu-networking? volatile-root? (on-error 'debug)) "Return as a file-like object a raw initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via 'root'. LINUX-MODULES is a list of kernel modules to be loaded at boot time. MAPPED-DEVICES is a list of device mappings to realize before FILE-SYSTEMS are mounted. PRE-MOUNT is a G-expression to evaluate before realizing MAPPED-DEVICES. HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include e2fsck/static or other packages needed by the initrd to check root partition. When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired console keyboard layout. This is done before MAPPED-DEVICES are set up and before FILE-SYSTEMS are mounted such that, should the user need to enter a passphrase or use the REPL, this happens using the intended keyboard layout. When QEMU-NETWORKING? is true, set up networking with the standard QEMU parameters. When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost. ON-ERROR is passed to 'call-with-error-handling'; it determines what happens upon error." (define device-mapping-commands ;; List of gexps to open the mapped devices. (map (lambda (md) (let* ((source (mapped-device-source md)) (targets (mapped-device-targets md)) (type (mapped-device-type md)) (open (mapped-device-kind-open type))) (open source targets))) mapped-devices)) (define file-system-scan-commands ;; File systems like btrfs need help to assemble multi-device file systems ;; but do not use manually-specified <mapped-devices>. (let ((file-system-types (map file-system-type file-systems))) (if (member "btrfs" file-system-types) ;; Ignore errors: if the system manages to boot anyway, the better. #~((system* (string-append #$btrfs-progs/static "/bin/btrfs") "device" "scan")) #~()))) (define kodir (flat-linux-module-directory linux linux-modules)) (expression->initrd (with-imported-modules (source-module-closure '((gnu build linux-boot) (guix build utils) (guix build bournish) (gnu system file-systems) (gnu build file-systems))) #~(begin (use-modules (gnu build linux-boot) (gnu system file-systems) ((guix build utils) #:hide (delete)) (guix build bournish) ;add the 'bournish' meta-command (srfi srfi-1) ;for lvm-device-mapping (srfi srfi-26) ;; Load extra modules needed by the mapped device code. #$@(append-map (compose mapped-device-kind-modules mapped-device-type) mapped-devices)) (with-output-to-port (%make-void-port "w") (lambda () (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) (parameterize ((current-warning-port (%make-void-port "w"))) (boot-system #:mounts (map spec->file-system '#$(map file-system->spec file-systems)) #:pre-mount (lambda () (and #$pre-mount #$@device-mapping-commands #$@file-system-scan-commands)) #:linux-modules '#$linux-modules #:linux-module-directory '#$kodir #:keymap-file #+(and=> keyboard-layout keyboard-layout->console-keymap) #:qemu-guest-networking? #$qemu-networking? #:volatile-root? '#$volatile-root? #:on-error '#$on-error)))) #:name "raw-initrd")) (define* (file-system-packages file-systems #:key (volatile-root? #f)) "Return the list of statically-linked, stripped packages to check FILE-SYSTEMS." `(,@(if (find (lambda (fs) (string-prefix? "ext" (file-system-type fs))) file-systems) (list e2fsck/static) '()) ,@(if (find (lambda (fs) (string-suffix? "fat" (file-system-type fs))) file-systems) (list fatfsck/static) '()) ,@(if (find (file-system-type-predicate "bcachefs") file-systems) (list bcachefs/static) '()) ,@(if (find (file-system-type-predicate "btrfs") file-systems) (list btrfs-progs/static) '()) ,@(if (find (file-system-type-predicate "jfs") file-systems) (list jfs_fsck/static) '()) ,@(if (find (file-system-type-predicate "ntfs") file-systems) (list ntfsfix/static) '()) ,@(if (find (file-system-type-predicate "f2fs") file-systems) (list f2fs-fsck/static) '()) ,@(if (find (file-system-type-predicate "xfs") file-systems) (list xfs_repair/static) '()))) (define-syntax vhash ;TODO: factorize (syntax-rules (=>) "Build a vhash with the given key/value mappings." ((_) vlist-null) ((_ (key others ... => value) rest ...) (vhash-cons key value (vhash (others ... => value) rest ...))) ((_ (=> value) rest ...) (vhash rest ...)))) (define-syntax lookup-procedure (syntax-rules (else) "Return a procedure that lookups keys in the given dictionary." ((_ mapping ... (else default)) (let ((table (vhash mapping ...))) (lambda (key) (match (vhash-assoc key table) (#f default) ((key . value) value))))))) (define file-system-type-modules ;; Given a file system type, return the list of modules it needs. (lookup-procedure ("cifs" => '("md4" "ecb" "cifs")) ("9p" => '("9p" "9pnet_virtio")) ("bcachefs" => '("bcachefs")) ("btrfs" => '("btrfs")) ("iso9660" => '("isofs")) ("jfs" => '("jfs")) ("f2fs" => '("f2fs" "crc32_generic")) ("xfs" => '("xfs")) (else '()))) (define (file-system-modules file-systems) "Return the list of Linux modules needed to mount FILE-SYSTEMS." (append-map (compose file-system-type-modules file-system-type) file-systems)) (define* (default-initrd-modules #:optional (system (or (%current-target-system) (%current-system)))) "Return the list of modules included in the initrd by default." (define virtio-modules ;; Modules for Linux para-virtualized devices, for use in QEMU guests. '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" "virtio_console" "virtio-rng")) `("ahci" ;for SATA controllers "usb-storage" "uas" ;for the installation image etc. "usbhid" "hid-generic" ;keyboards during early boot ,@(if (target-riscv64? system) '() '("hid-apple")) "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions "nls_iso8859-1" ;for `mkfs.fat`, et.al ,@(if (string-match "^(x86_64|i[3-6]86)-" system) '("pata_acpi" "pata_atiixp" ;for ATA controllers "isci") ;for SAS controllers like Intel C602 '()) ,@virtio-modules)) (define-syntax %base-initrd-modules ;; This more closely matches our naming convention. (identifier-syntax (default-initrd-modules))) (define* (base-initrd file-systems #:key (linux linux-libre) (linux-modules '()) (mapped-devices '()) (keyboard-layout #f) qemu-networking? volatile-root? (extra-modules '()) ;deprecated (on-error 'debug)) "Return as a file-like object a generic initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via 'root'. MAPPED-DEVICES is a list of device mappings to realize before FILE-SYSTEMS are mounted. When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired console keyboard layout. This is done before MAPPED-DEVICES are set up and before FILE-SYSTEMS are mounted such that, should the user need to enter a passphrase or use the REPL, this happens using the intended keyboard layout. QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd. The initrd is automatically populated with all the kernel modules necessary for FILE-SYSTEMS and for the given options. Additional kernel modules can be listed in LINUX-MODULES. They will be added to the initrd, and loaded at boot time in the order in which they appear." (define linux-modules* ;; Modules added to the initrd and loaded from the initrd. `(,@linux-modules ,@(file-system-modules file-systems) ,@(if volatile-root? '("overlay") '()) ,@extra-modules)) (define helper-packages (append (file-system-packages file-systems #:volatile-root? volatile-root?) (if keyboard-layout (list loadkeys-static) '()))) (raw-initrd file-systems #:linux linux #:linux-modules linux-modules* #:mapped-devices mapped-devices #:helper-packages helper-packages #:keyboard-layout keyboard-layout #:qemu-networking? qemu-networking? #:volatile-root? volatile-root? #:on-error on-error)) ;;; linux-initrd.scm ends here