;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Christopher Allan Webber ;;; Copyright © 2016, 2017 Leo Famulari ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2018 Chris Marusich ;;; ;;; 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 sh
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Theodoros Foradis <theodoros@foradis.org>
;;; Copyright © 2018–2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
;;; Copyright © 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2024 Juliana Sims <juli@incana.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 (gnu packages electronics)
  #:use-module (guix download)
  #:use-module (guix gexp)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system cmake)
  #:use-module (gnu packages)
  #:use-module (gnu packages algebra)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages base)
  #:use-module (gnu packages boost)
  #:use-module (gnu packages c)
  #:use-module (gnu packages check)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages documentation)
  #:use-module (gnu packages embedded)
  #:use-module (gnu packages fontutils)
  #:use-module (gnu packages gl)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages graphviz)
  #:use-module (gnu packages gtk)
  #:use-module (gnu packages libftdi)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages m4)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python)
  #:use-module (gnu packages qt)
  #:use-module (gnu packages sdl)
  #:use-module (gnu packages sqlite)
  #:use-module (gnu packages stb)
  #:use-module (gnu packages toolkits))

(define-public libserialport
  (package
    (name "libserialport")
    (version "0.1.1")
    (source (origin
              (method url-fetch)
              (uri (string-append
                    "http://sigrok.org/download/source/libserialport/libserialport-"
                    version ".tar.gz"))
              (sha256
               (base32
                "17ajlwgvyyrap8z7f16zcs59pksvncwbmd3mzf98wj7zqgczjaja"))))
    (build-system gnu-build-system)
    (home-page "https://sigrok.org/wiki/Libserialport")
    (synopsis "Library for using serial ports")
    (description "Libserialport is a minimal shared library written in C that is intended
to take care of the OS-specific details when writing software that uses serial ports.")
    (license license:lgpl3+)))

(define-public libsigrokdecode
  (let ((commit "e6962b3fe8260382bb9932a1cfdd7ee7090ce267")
        (revision "0"))
    (package
      (name "libsigrokdecode")
      (version (git-version "0.5.3" revision commit))
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url "https://github.com/sigrokproject/libsigrokdecode")
                      (commit commit)))
                (file-name (git-file-name name version))
                (sha256
                 (base32
                  "0ik93p6k8hpv8ahchjnmir8paz2w718y1j8pnmrmagjx8vvqd9y6"))))
      (outputs '("out" "doc"))
      (arguments
       `(#:phases
         (modify-phases %standard-phases
           (add-after 'build 'build-doc
             (lambda _
               (invoke "doxygen")
               #t))
           (add-after 'install 'install-doc
             (lambda* (#:key outputs #:allow-other-keys)
               (copy-recursively "doxy/html-api"
                                 (string-append (assoc-ref outputs "doc")
                                                "/share/doc/libsigrokdecode"))
               #t)))))
      (native-inputs
       (list check doxygen graphviz pkg-config automake autoconf libtool))
      ;; libsigrokdecode.pc lists "python" in Requires.private, and "glib" in
      ;; Requires.
      (propagated-inputs
       (list glib python))
      (build-system gnu-build-system)
      (home-page "https://www.sigrok.org/wiki/Libsigrokdecode")
      (synopsis
       "Library providing (streaming) protocol decoding functionality")
      (description
       "Libsigrokdecode is a shared library written in C, which provides
(streaming) protocol decoding functionality.")
      (license license:gpl3+))))

(define-public sigrok-firmware-fx2lafw
  ;; The project's last formal release was in 2019.
  ;;
  ;; The changes since then allow it to build with the latest version of SDCC,
  ;; 4.3.0.
  (let ((commit "96b0b476522c3f93a47ff8f479ec08105ba6a2a5")
        (revision "1"))
    (package
      (name "sigrok-firmware-fx2lafw")
      (version (git-version "0.1.7" revision commit))
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url "git://sigrok.org/sigrok-firmware-fx2lafw")
                      (commit commit)))
                (file-name (git-file-name name version))
                (sha256
                 (base32
                  "1n5nj2g2m5ih59591ny2drrv25zviqcwyx1cfdhy8ijl82yxjkmb"))))
      (build-system gnu-build-system)
      (arguments
       (list #:tests? #f))              ; no test suite
      (native-inputs
       (list autoconf automake sdcc))
      (home-page "https://www.sigrok.org/wiki/Fx2lafw")
      (synopsis "Firmware for Cypress FX2 chips")
      (description "Fx2lafw is free firmware for Cypress FX2 chips which makes
them usable as simple logic analyzer and/or oscilloscope hardware.")
      (license license:gpl2+))))

(define-public libsigrok
  (let ((commit "a7e919a3a6b7fd511acbe1a280536b76c70c28d2")
        (revision "1"))
    (package
      (name "libsigrok")
      (version (git-version "0.5.2" revision commit))
      (source
       (origin
         (method git-fetch)
         (uri (git-reference
               (url "git://sigrok.org/libsigrok")
               (commit commit)))
         (sha256
          (base32 "0km3fyv5s2byrm4zpbss2527ynhw4nb67imnbawwic2a6zh9jiyc"))
         (file-name (git-file-name name version))))
      (outputs '("out" "doc"))
      (arguments
       `(#:tests? #f                      ; tests need USB access
         #:phases
         (modify-phases %standard-phases
           (add-before 'configure 'change-udev-group
             (lambda _
               (substitute* (find-files "contrib" "\\.rules$")
                 (("plugdev") "dialout"))))
           (add-after 'build 'build-doc
             (lambda _
               (invoke "doxygen")))
           (add-after 'install 'install-doc
             (lambda* (#:key outputs #:allow-other-keys)
               (copy-recursively "doxy/html-api"
                                 (string-append (assoc-ref outputs "doc")
                                                "/share/doc/libsigrok"))))
           (add-after 'install-doc 'install-udev-rules
             (lambda* (#:key outputs #:allow-other-keys)
               (let* ((out   (assoc-ref outputs "out"))
                      (rules (string-append out "/lib/udev/rules.d/")))
                 (for-each (lambda (file)
                             (install-file file rules))
                           (find-files "contrib" "\\.rules$")))))
           (add-after 'install-udev-rules 'install-fw
             (lambda* (#:key inputs outputs #:allow-other-keys)
               (let* ((fx2lafw (assoc-ref inputs "sigrok-firmware-fx2lafw"))
                      (out (assoc-ref outputs "out"))
                      (dir-suffix "/share/sigrok-firmware/")
                      (input-dir (string-append fx2lafw dir-suffix))
                      (output-dir (string-append out dir-suffix)))
                 (for-each
                  (lambda (file)
                    (install-file file output-dir))
                  (find-files input-dir "."))))))))
      (native-inputs
       (list autoconf automake doxygen graphviz libtool
             sigrok-firmware-fx2lafw pkg-config))
      (inputs
       (list python zlib))
      ;; libsigrokcxx.pc lists "glibmm" in Requires libsigrok.pc lists
      ;; "libserialport", "libusb", "libftdi" and "libzip" in Requires.private
      ;; and "glib" in Requires
      (propagated-inputs
       (list glib
             glibmm-2.66
             libserialport
             libusb
             libftdi
             libzip))
      (build-system gnu-build-system)
      (home-page "https://www.sigrok.org/wiki/Libsigrok")
      (synopsis "Basic hardware access drivers for logic analyzers")
      (description "@code{libsigrok} is a shared library written in C which
provides the basic hardware access drivers for logic analyzers and other
supported devices, as well as input/output file format support.")
      (license license:gpl3+))))

(define-public sigrok-cli
  (package
    (name "sigrok-cli")
    (version "0.7.2")
    (source (origin
              (method url-fetch)
              (uri (string-append
                    "http://sigrok.org/download/source/sigrok-cli/sigrok-cli-"
                    version ".tar.gz"))
              (sha256
               (base32
                "1f0a2k8qdcin0pqiqq5ni4khzsnv61l21v1dfdjzayw96qzl9l3i"))))
    (native-inputs
     (list pkg-config))
    (inputs
     (list glib libsigrok libsigrokdecode))
    (build-system gnu-build-system)
    (home-page "https://sigrok.org/wiki/Sigrok-cli")
    (synopsis "Command-line frontend for sigrok")
    (description "Sigrok-cli is a command-line frontend for sigrok.")
    (license license:gpl3+)))

(define-public openboardview
  (package
    (name "openboardview")
    (version "9.95.0")
    (source (origin
              (method git-fetch)
              (uri (git-reference
                    (url "https://github.com/OpenBoardView/OpenBoardView")
                    (commit version)))
              (file-name (git-file-name name version))
              (modules '((ice-9 ftw)
                         (srfi srfi-26)
                         (guix build utils)))
              (snippet
               '(with-directory-excursion "src"
                  (define keep (list "." ".." "openboardview"))
                  (for-each (lambda (f)
                              (when (eq? 'directory (stat:type (lstat f)))
                                (delete-file-recursively f)))
                            (scandir "." (negate (cut member <> keep))))))
              (patches
               (search-patches "openboardview-use-system-imgui.patch"
                               "openboardview-use-system-mpc.patch"))
              (sha256
               (base32
                "1safjd729a7591rigkiy3c678bivrj5q1qwg1f18sijhlsfkf5b3"))))
    (build-system cmake-build-system)
    (arguments
     (list
      #:tests? #f                       ;no test suite
      #:imported-modules `((guix build glib-or-gtk-build-system)
                           ,@%cmake-build-system-modules)
      #:modules '((guix build cmake-build-system)
                  (guix build utils)
                  ((guix build glib-or-gtk-build-system) #:prefix gtk:))
      #:phases
      #~(modify-phases %standard-phases
          (add-before 'configure 'configure-glad
            (lambda* (#:key inputs #:allow-other-keys)
              (substitute* "src/CMakeLists.txt"
                (("add_subdirectory\\(glad\\)")
                 (string-append
                  ;; Configure Glad to use static Khronos XML specifications
                  ;; instead of attempting to fetch them from the Internet.
                  "option(GLAD_REPRODUCIBLE \"Reproducible build\" ON)\n"
                  ;; Use the CMake files from our glad package.
                  "add_subdirectory("
                  (search-input-directory inputs "share/glad") ;source_dir
                  " src/glad)\n")))))                          ;binary dir
          (add-before 'configure 'dynamically-load-gtk-via-absolute-path
            ;; The GTK library is not linked thus not present in the RUNPATH of
            ;; the produced binary; the absolute path of the libraries must to
            ;; the dynamic loader otherwise they aren't found.
            (lambda* (#:key inputs #:allow-other-keys)
              (substitute* "src/openboardview/unix.cpp"
                (("libgtk-3.so")
                 (search-input-file inputs "lib/libgtk-3.so")))))
          ;; Add the two extra phases from `glib-or-gtk-build-system'.
          (add-after 'install 'glib-or-gtk-compile-schemas
            (assoc-ref gtk:%standard-phases 'glib-or-gtk-compile-schemas))
          (add-after 'install 'glib-or-gtk-wrap
            (assoc-ref gtk:%standard-phases 'glib-or-gtk-wrap)))))
    (native-inputs
     (list pkg-config
           python
           glad-0.1
           stb-image
           utf8-h))
    (inputs
     (list fontconfig
           gtk+
           ;; OpenBoardView can build with Dear ImGui 1.88, but there are some
           ;; usability problems such as the difficulty to register clicks.
           imgui-1.87
           orangeduck-mpc
           sdl2
           sqlite
           zlib))
    (home-page "https://github.com/OpenBoardView/OpenBoardView")
    (synopsis "Viewer for BoardView files")
    (description "OpenBoardView is a viewer for BoardView files, which present
the details of a printed circuit board (PCB).  It comes with features
such as:
@itemize
@item Dynamic part outline rendering, including complex connectors
@item Annotations, for leaving notes about parts, nets, pins or location
@item Configurable colour themes
@item Configurable DPI to facilitate usage on 4K monitors
@item Configurable for running on slower systems
@item Reads FZ (with key), BRD, BRD2, BDV and BV* formats.
@end itemize")
    (license license:expat)))

(define-public pulseview
  (package
    (name "pulseview")
    (version "0.4.2")
    (source (origin
              (method url-fetch)
              (uri (string-append
                    "https://sigrok.org/download/source/pulseview/pulseview-"
                    version ".tar.gz"))
              (sha256
               (base32
                "1jxbpz1h3m1mgrxw74rnihj8vawgqdpf6c33cqqbyd8v7rxgfhph"))
              (patches (search-patches "pulseview-qt515-compat.patch"
                                       "pulseview-glib-2.68.patch"))))
    (build-system cmake-build-system)
    (arguments
     `(#:tests? #f ;format_time_minutes_test is failing
       #:phases
       (modify-phases %standard-phases
         (add-after 'install 'remove-empty-doc-directory
           (lambda* (#:key outputs #:allow-other-keys)
             (let ((out (assoc-ref outputs "out")))
               (with-directory-excursion (string-append out "/share")
                 ;; Use RMDIR to never risk silently deleting files.
                 (rmdir "doc/pulseview")
                 (rmdir "doc"))))))))
    (native-inputs
     (list pkg-config qttools-5))
    (inputs
     (list boost
           glib
           glibmm
           libsigrok
           libsigrokdecode
           qtbase-5
           qtsvg-5))
    (home-page "https://www.sigrok.org/wiki/PulseView")
    (synopsis "Qt based logic analyzer, oscilloscope and MSO GUI for sigrok")
    (description "PulseView is a Qt based logic analyzer, oscilloscope and MSO GUI
for sigrok.")
    (license license:gpl3+)))

(define-public comedilib
  (package
    (name "comedilib")
    (version "0.12.0")
    (source (origin
              (method url-fetch)
              (uri (string-append "https://www.comedi.org/download/comedilib-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "0wzh23iyix4xj211fsd8hwrdcjhg2w5jswk9kywb1gpd3h8afajj"))))
    (build-system gnu-build-system)
    (synopsis "Library for Comedi")
    (description "Comedilib is a user-space library that provides a
developer-friendly interface to Comedi devices.  Comedi is a collection of
drivers for a variety of common data acquisition plug-in boards.  The drivers
are implemented as a core Linux kernel module providing common functionality and
individual low-level driver modules.")
    (home-page "https://www.comedi.org/")
    (license license:lgpl2.1)))

(define-public xoscope
  (package
    (name "xoscope")
    (version "2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "mirror://sourceforge/xoscope/xoscope/"
                                  version "/xoscope-" version ".tar.gz"))
              (sha256
               (base32
                "0a5ycfc1qdmibvagc82r2mhv2i99m6pndy5i6ixas3j2297g6pgq"))))
    (build-system gnu-build-system)
    (native-inputs
     (list m4 pkg-config))
    (inputs
     (list alsa-lib comedilib fftw gtk+ gtkdatabox))
    (synopsis "Digital oscilloscope")
    (description "Xoscope is a digital oscilloscope that can acquire signals
from ALSA, ESD, and COMEDI sources.  This package currently does not include
support for ESD sources.")
    (home-page "https://xoscope.sourceforge.net/")
    (license license:gpl2+)))

(define-public m8c
  (package
    (name "m8c")
    (version "1.7.0")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/laamaa/m8c")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
        (base32 "1wsknqgya2vkalbjq6rvmknsdk4lrqkn0z5rpjf4pd5vxgr8qryb"))))
    (build-system gnu-build-system)
    (arguments
     (list
      #:make-flags #~(list (string-append "PREFIX=" #$output))
      #:phases
      #~(modify-phases %standard-phases
          (delete 'configure))
      #:tests? #f)) ;no tests
    (native-inputs (list pkg-config))
    (inputs (list libserialport
                  sdl2))
    (home-page "https://github.com/laamaa/m8c")
    (synopsis "Cross-platform M8 tracker headless client")
    (description
     "The @url{https://dirtywave.com/products/m8-tracker,Dirtywave M8 Tracker}
is a portable sequencer and synthesizer, featuring 8 tracks of assignable
instruments such as FM, waveform synthesis, virtual analog, sample playback, and
MIDI output.  It is powered by a @url{https://www.pjrc.com/teensy/,Teensy}
micro-controller and inspired by the Gameboy tracker
@url{https://www.littlesounddj.com/lsd/index.php,Little Sound DJ}.  m8c is a
client for @url{https://github.com/Dirtywave/M8HeadlessFirmware,M8 Headless}
which allows one to install the M8 firmware on any Teensy.")
    (license (list license:cc-by-sa3.0
                   license:expat
                   license:public-domain
                   license:zlib))))

(define-public minipro
  ;; Information needed to fix Makefile
   (let* ((commit "c181c2cf1619d00a520627d475e3fadb1eea5dac")
         (commit-short (substring commit 0 8))
         (date "2022-09-10 21:44:06 -0700"))
    (package
      (name "minipro")
      (version "0.6")
      (source (origin
                (method git-fetch)
                (uri (git-reference
                      (url "https://gitlab.com/DavidGriffith/minipro.git")
                      (commit version)))
                (file-name (git-file-name name version))
                (sha256
                 (base32
                  "03xgmvvsxmqrz7blg7cqk0pb9ynhlq6v6jfl532zmjdzp5p3h10d"))))
      (native-inputs (list pkg-config which))
      (inputs (list libusb))
      (build-system gnu-build-system)
      (arguments
       (list
        #:tests? #f ; no test suite
        #:phases
        #~(modify-phases %standard-phases
            (delete 'configure) ; No ./configure script
            (add-before 'build 'fix-makefile
              (lambda _
                ;; Fix some git related variables that minipro expects
                (substitute* "Makefile"
                  (("GIT_BRANCH = .*")
                   (string-append "GIT_BRANCH = \"master\"\n"))
                  (("GIT_HASH = .*")
                   (string-append "GIT_HASH = \"" #$commit "\"\n"))
                  (("GIT_HASH_SHORT = .*")
                   (string-append "GIT_HASH_SHORT = \"" #$commit-short "\"\n"))
                  (("GIT_DATE = .*")
                   (string-append "GIT_DATE = \"" #$date "\"\n"))))))
        #:make-flags
        #~(list (string-append "VERSION=" #$version)
                (string-append "PREFIX=" #$output)
                (string-append "UDEV_DIR=" #$output "/lib/udev")
                (string-append "COMPLETIONS_DIR=" #$output
                               "/share/bash-completion/completions"))))
      (synopsis "Controls the TL866xx series of chip programmers")
      (description
       "minipro is designed to program or read the contents of
chips supported by the TL866xx series of programmers.  This includes many
microcontrollers, ROMs, EEPROMs and PLDs.

To use this program without root privileges you must install the necessary udev
rules.  This can be done by extending @code{udev-service-type} in your
@code{operating-system} configuration with this package.  E.g.:
@code{(udev-rules-service 'minipro minipro #:groups '(\"plugdev\")}.
Additionally your user must be member of the @code{plugdev} group.")
      (home-page "https://gitlab.com/DavidGriffith/minipro")
      (license license:gpl3+))))
generated by cgit
#:entry-point '(#$boot-program #$os) #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) #:transformations `((,root-directory -> "")))))))) (expression->derivation-in-linux-vm name build #:make-disk-image? #f #:single-file-output? #t #:references-graphs `((,graph ,os))))) ;;; ;;; VM and disk images. ;;; (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) (cond ((file-system-label? device) (file-system-label->string device)) ((uuid? device) (uuid->string device)) ((string? device) device) (else #f)) (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 file-system-type (- (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* (system-disk-image os #:key (name "disk-image") (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20))) (volatile? #t)) "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the system described by OS. Said image can be copied on a USB stick as is. When VOLATILE? is true, the root file system is made volatile; this is useful to USB sticks meant to be read-only." (define normalize-label ;; ISO labels are all-caps (case-insensitive), but since ;; 'find-partition-by-label' is case-sensitive, make it all-caps here. (if (string=? "iso9660" file-system-type) string-upcase identity)) (define root-label ;; Volume name of the root file system. (normalize-label "Guix_image")) (define (root-uuid os) ;; UUID of the root file system, computed in a deterministic fashion. ;; This is what we use to locate the root file system so it has to be ;; different from the user's own file system UUIDs. (operating-system-uuid os (if (string=? file-system-type "iso9660") 'iso9660 'dce))) (define file-systems-to-keep (remove (lambda (fs) (string=? (file-system-mount-point fs) "/")) (operating-system-file-systems os))) (let* ((os (operating-system (inherit os) ;; Since this is meant to be used on real hardware, don't ;; install QEMU networking or anything like that. Assume USB ;; mass storage devices (usb-storage.ko) are available. (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems #:volatile-root? volatile? rest))) (bootloader (if (string=? "iso9660" file-system-type) (bootloader-configuration (inherit (operating-system-bootloader os)) (bootloader grub-mkrescue-bootloader)) (operating-system-bootloader os))) ;; Force our own root file system. (We need a "/" file system ;; to call 'root-uuid'.) (file-systems (cons (file-system (mount-point "/") (device "/dev/placeholder") (type file-system-type)) file-systems-to-keep)))) (uuid (root-uuid os)) (os (operating-system (inherit os) (file-systems (cons (file-system (mount-point "/") (device uuid) (type file-system-type)) file-systems-to-keep)))) (bootcfg (operating-system-bootcfg os))) (if (string=? "iso9660" file-system-type) (iso9660-image #:name name #:file-system-label root-label #:file-system-uuid uuid #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)) #:grub-mkrescue-environment '(("MKRESCUE_SED_MODE" . "mbr_hfs"))) (qemu-image #:name name #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:disk-image-format "raw" #:file-system-type file-system-type #:file-system-label root-label #:file-system-uuid uuid #:copy-inputs? #t #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)))))) (define* (system-qemu-image os #:key (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." (define file-systems-to-keep ;; Keep only file systems other than root and not normally bound to real ;; devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target "/") (string-prefix? "/dev/" source)))) (operating-system-file-systems os))) (define root-uuid ;; UUID of the root file system. (operating-system-uuid os (if (string=? file-system-type "iso9660") 'iso9660 'dce))) (let* ((os (operating-system (inherit os) ;; Assume we have an initrd with the whole QEMU shebang. ;; Force our own root file system. Refer to it by UUID so that ;; it works regardless of how the image is used ("qemu -hda", ;; Xen, etc.). (file-systems (cons (file-system (mount-point "/") (device root-uuid) (type file-system-type)) file-systems-to-keep)))) (bootcfg (operating-system-bootcfg os))) (qemu-image #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:file-system-type file-system-type #:file-system-uuid root-uuid #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)) #:copy-inputs? #t))) ;;; ;;; VMs that share file systems with the host. ;;; (define (file-system->mount-tag fs) "Return a 9p mount tag for host file system FS." ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain ;; slashes, and cannot start with '_'. Compute an identifier that ;; corresponds to the rules. (string-append "TAG" (string-drop (bytevector->base32-string (sha1 (string->utf8 fs))) 4))) (define (mapping->file-system mapping) "Return a 9p file system that realizes MAPPING." (match mapping (($ source target writable?) (file-system (mount-point target) (device (file-system->mount-tag source)) (type "9p") (flags (if writable? '() '(read-only))) (options "trans=virtio,cache=loose") (check? #f) (create-mount-point? #t))))) (define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of to realize in the virtualized OS." (define user-file-systems ;; Remove file systems that conflict with those added below, or that are ;; normally bound to real devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target (%store-prefix)) (string=? target "/") (and (string? source) (string-prefix? "/dev/" source)) ;; Labels and UUIDs are necessarily invalid in the VM. (and (file-system-mount? fs) (or (file-system-label? source) (uuid? source)))))) (operating-system-file-systems os))) (define virtual-file-systems (cons (file-system (mount-point "/") (device "/dev/vda1") (type "ext4")) (append (map mapping->file-system mappings) user-file-systems))) (operating-system (inherit os) ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware), ;; force the traditional i386/BIOS method. ;; See . (bootloader (bootloader-configuration (inherit (operating-system-bootloader os)) (bootloader grub-bootloader) (target "/dev/vda"))) (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems #:volatile-root? #t rest))) ;; Disable swap. (swap-devices '()) ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store ;; since that would lead the bootloader config to look for the kernel and ;; initrd in it. (file-systems (if full-boot? virtual-file-systems (cons (file-system (inherit (mapping->file-system %store-mapping)) (needed-for-boot? #t)) virtual-file-systems))))) (define* (system-qemu-image/shared-store os #:key full-boot? (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store with the host. When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." (define root-uuid ;; Use a fixed UUID to improve determinism. (operating-system-uuid os 'dce)) (define bootcfg (operating-system-bootcfg os)) ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains ;; BOOTCFG and all its dependencies, including the output of OS. ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:file-system-uuid root-uuid #:inputs (if full-boot? `(("bootcfg" ,bootcfg)) '()) ;; XXX: Passing #t here is too slow, so let it off by default. #:register-closures? #f #:copy-inputs? full-boot?)) (define* (common-qemu-options image shared-fs) "Return the a string-value gexp with the common QEMU options to boot IMAGE, with '-virtfs' options for the host file systems listed in SHARED-FS." (define (virtfs-option fs) #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s" #$fs #$(file-system->mount-tag fs))) #~(;; Only enable kvm if we see /dev/kvm exists. ;; This allows users without hardware virtualization to still use these ;; commands. #$@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) "-no-reboot" "-net nic,model=virtio" "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" "-device" "virtio-rng-pci,rng=guixsd-vm-rng" #$@(map virtfs-option shared-fs) "-vga std" (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" #$image))) (define* (system-qemu-image/shared-store-script os #:key (qemu qemu) (graphic? #t) (memory-size 256) (mappings '()) full-boot? (disk-image-size (* (if full-boot? 500 70) (expt 2 20))) (options '())) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host. The virtual machine runs with MEMORY-SIZE MiB of memory. MAPPINGS is a list of specifying mapping of host file systems into the guest. When FULL-BOOT? is true, the returned script runs everything starting from the bootloader; otherwise it directly starts the operating system kernel. The DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; it is mostly useful when FULL-BOOT? is true." (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) (image (system-qemu-image/shared-store os #:full-boot? full-boot? #:disk-image-size disk-image-size))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os "/dev/vda1"))) (define qemu-exec #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) #$@(if full-boot? #~() #~("-kernel" #$(operating-system-kernel-file os) "-initrd" #$(file-append os "/initrd") (format #f "-append ~s" (string-join #$kernel-arguments " ")))) #$@(common-qemu-options image (map file-system-mapping-source (cons %store-mapping mappings))) "-m " (number->string #$memory-size) #$@options)) (define builder #~(call-with-output-file #$output (lambda (port) (format port "#!~a~% exec ~a \"$@\"~%" #$(file-append bash "/bin/sh") (string-join #$qemu-exec " ")) (chmod port #o555)))) (gexp->derivation "run-vm.sh" builder))) ;;; ;;; High-level abstraction. ;;; (define-record-type* %virtual-machine make-virtual-machine virtual-machine? (operating-system virtual-machine-operating-system) ; (qemu virtual-machine-qemu ; (default qemu)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) (memory-size virtual-machine-memory-size ;integer (MiB) (default 256)) (disk-image-size virtual-machine-disk-image-size ;integer (bytes) (default 'guess)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs (default '()))) (define-syntax virtual-machine (syntax-rules () "Declare a virtual machine running the specified OS, with the given options." ((_ os) ;shortcut (%virtual-machine (operating-system os))) ((_ fields ...) (%virtual-machine fields ...)))) (define (port-forwardings->qemu-options forwardings) "Return the QEMU option for the given port FORWARDINGS as a string, where FORWARDINGS is a list of host-port/guest-port pairs." (string-join (map (match-lambda ((host-port . guest-port) (string-append "hostfwd=tcp::" (number->string host-port) "-:" (number->string guest-port)))) forwardings) ",")) (define-gexp-compiler (virtual-machine-compiler (vm ) system target) ;; XXX: SYSTEM and TARGET are ignored. (match vm (($ os qemu graphic? memory-size disk-image-size ()) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size #:disk-image-size disk-image-size)) (($ os qemu graphic? memory-size disk-image-size forwardings) (let ((options `("-net" ,(string-append "user," (port-forwardings->qemu-options forwardings))))) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size #:disk-image-size disk-image-size #:options options))))) ;;; vm.scm ends here