;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 John Darrington ;;; Copyright © 2015 Andreas Enge ;;; Copyright © 2015 David Hashe ;;; Copyright © 2015, 2016, 2020 Efraim Flashner ;;; Copyright © 2016 Lukas Gradl ;;; Copyright © 2016 Francesco Frassinelli ;;; Copyright © 2016, 2017 Nikita ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice ;;; Copyright © 2017 Adonay Felipe Nogueira ;;; Copyright © 2018 Jovany Leandro G.C ;;; Copyright © 2018 Tim Gesthuizen ;;; Copyright © 2019 Pierre Neidhardt ;;; Copyright © 2019 Jan Wielkiewicz ;;; Copyright © 2019 Ivan Vilat
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2020, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 linux-initrd)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module ((guix store)
                #:select (%store-prefix))
  #:use-module ((guix derivations)
                #:select (derivation->output-path))
  #:use-module (guix modules)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages file-systems)
  #:use-module (gnu packages guile)
  #:use-module ((gnu packages xorg)
                #:select (console-setup xkeyboard-config))
  #:use-module ((gnu packages make-bootstrap)
                #:select (%guile-static-initrd))
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (gnu system keyboard)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (expression->initrd
            %base-initrd-modules
            raw-initrd
            file-system-packages
            base-initrd))


;;; Commentary:
;;;
;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
;;; particular initrd's that run Guile.
;;;
;;; Code:


(define* (expression->initrd exp
                             #:key
                             (guile %guile-static-initrd)
                             (gzip gzip)
                             (name "guile-initrd")
                             (system (%current-system)))
  "Return as a file-like object a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
the derivations referenced by EXP are automatically copied to the initrd."

  ;; General Linux overview in `Documentation/early-userspace/README' and
  ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.

  (define init
    (program-file "init" exp #:guile guile))

  (define (import-module? module)
    ;; Since we don't use deduplication support in 'populate-store', don't
    ;; import (guix store deduplication) and its dependencies, which includes
    ;; Guile-Gcrypt.  That way we can run tests with '--bootstrap'.
    (and (guix-module-name? module)
         (not (equal? module '(guix store deduplication)))))

  (define builder
    ;; Do not use "guile-zlib" extension here, otherwise it would drag the
    ;; non-static "zlib" package to the initrd closure.  It is not needed
    ;; anyway because the modules are stored uncompressed within the initrd.
    (with-imported-modules (source-module-closure
                            '((gnu build linux-initrd))
                            #:select? import-module?)
      #~(begin
          (use-modules (gnu build linux-initrd))

          (mkdir #$output)

          ;; The guile used in the initrd must be present in the store, so
          ;; that module loading works once the root is switched.
          ;;
          ;; To ensure that is the case, add an explicit reference to the
          ;; guile package used in the initrd to the output.
          ;;
          ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
          ;; add a basic test".
          (call-with-output-file (string-append #$ output "/references")
            (lambda (port)
              (simple-format port "~A\n" #$guile)))

          (build-initrd (string-append #$output "/initrd.cpio.gz")
                        #:guile #$guile
                        #:init #$init
                        ;; Copy everything INIT refers to into the initrd.
                        #:references-graphs '("closure")
                        #:gzip (string-append #+gzip "/bin/gzip")))))

  (file-append (computed-file name builder
                              #:options
                              `(#:references-graphs (("closure" ,init))))
               "/initrd.cpio.gz"))

(define (flat-linux-module-directory linux modules)
  "Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
  (define imported-modules
    (source-module-closure '((gnu build linux-modules)
                             (guix build utils))))

  (define build-exp
    (with-imported-modules imported-modules
      (with-extensions (list guile-zlib guile-zstd)
        #~(begin
            (use-modules (gnu build linux-modules)
                         (guix build utils)
                         (rnrs io ports)
                         (srfi srfi-1)
                         (srfi srfi-26)
                         (ice-9 match))

            (define module-dir
              (string-append #$linux "/lib/modules"))

            (define builtin-modules
              (match (find-files module-dir (lambda (file stat)
                                              (string=? (basename file)
                                                        "modules.builtin")))
                ((file . _)
                 (call-with-input-file file
                   (lambda (port)
                     (map file-name->module-name
                          (string-tokenize (get-string-all port))))))
                (_
                 '())))

            (define modules-to-lookup
              (lset-difference string=? '#$modules builtin-modules))

            (define modules
              (let* ((lookup  (cut find-module-file module-dir <>))
                     (modules (map lookup modules-to-lookup)))
                (append modules
                        (recursive-module-dependencies
                         modules
                         #:lookup-module lookup))))

            (define (maybe-uncompress file)
              ;; If FILE is a compressed module, uncompress it, as the initrd
              ;; is already gzipped as a whole.
              (cond
               ((string-contains file ".ko.gz")
                (invoke #+(file-append gzip "/bin/gunzip") file))
               ((string-contains file ".ko.zst")
                (invoke #+(file-append zstd "/bin/zstd") "-d" file))))

            (mkdir #$output)
            (for-each (lambda (module)
                        (let ((out-module
                               (string-append #$output "/"
                                              (basename module))))
                          (format #t "copying '~a'...~%" module)
                          (copy-file module out-module)
                          (maybe-uncompress out-module)))
                      (delete-duplicates modules))

            ;; Hyphen or underscore?  This database tells us.
            (write-module-name-database #$output)))))

  (computed-file "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
generated by cgit
z")) (sha256 (base32 "101gw1334zmqsbjrba5dq1v4p2nxcs37g2yrzvkcra6s9ri4fw3j")) (modules '((guix build utils))) (snippet `(begin ;; Remove bundled software. Keep arc4random, celt-0.7.0, ;; celt-0.11.0, qqbonjour, rnnoise, smallft. (for-each delete-file-recursively '("3rdparty/GL" ; in mesa "3rdparty/mach-override-build" ; for macx "3rdparty/mach-override-src" "3rdparty/minhook-build" ; for win32 "3rdparty/minhook-src" "3rdparty/opus-build" ; in opus "3rdparty/opus-src" "3rdparty/speex-build" ; in speex "3rdparty/speex-src" "3rdparty/speexdsp-src" ; in speexdsp "3rdparty/xinputcheck-build" ; for win32 "3rdparty/xinputcheck-src")) #t)))) (build-system qt-build-system) (arguments `(#:tests? #f ; no "check" target #:phases (modify-phases %standard-phases (replace 'configure (lambda* (#:key inputs outputs #:allow-other-keys) (invoke "qmake" "main.pro" "QMAKE_LRELEASE=lrelease" (string-append "MUMBLE_PYTHON=" (string-append (assoc-ref inputs "python") "/bin/python3")) (string-append "CONFIG+=" (string-join ;; Options used are listed in the same order ;; as in the "INSTALL" file ;; (plus the final "packaged" and "release"). (list "no-bundled-speex" ; in speex "no-bundled-opus" ; in opus "no-g15" ; not packaged "no-jackaudio" ; use pulse "no-oss" ; use pulse "no-alsa" ; use pulse "no-update" "no-embed-qt-translations" "no-ice" ; not packaged "packaged" "release"))) (string-append "DEFINES+=" "PLUGIN_PATH=" (assoc-ref outputs "out") "/lib/mumble")))) (add-before 'configure 'fix-libspeechd-include (lambda _ (substitute* "src/mumble/TextToSpeech_unix.cpp" (("libspeechd.h") "speech-dispatcher/libspeechd.h")) #t)) ;; disable statistic gathering by default. see (add-before 'configure 'fix-statistic-gathering-default (lambda _ (substitute* "src/mumble/Settings.cpp" (("bUsage = true;") "bUsage = false;")) #t)) (add-before 'configure 'fix-mumble-overlay (lambda* (#:key outputs #:allow-other-keys) (with-output-to-file "scripts/mumble-overlay" (lambda () (format #t "#!~a~%" (which "bash")) (format #t "export LD_PRELOAD=\"~a $LD_PRELOAD\"~%" (string-append (assoc-ref outputs "out") "/lib/mumble/libmumble.so.1")) (format #t "exec \"${@}\""))) #t)) (add-before 'install 'disable-murmur-ice (lambda _ (substitute* "scripts/murmur.ini.system" (("^ice=") ";ice=")) #t)) (replace 'install ; install phase does not exist (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (etc (string-append out "/etc/murmur")) (dbus (string-append out "/etc/dbus-1/system.d/")) (bin (string-append out "/bin")) (services (string-append out "/share/services")) (applications (string-append out "/share/applications")) (icons (string-append out "/share/icons/hicolor/scalable/apps")) (man (string-append out "/share/man/man1")) (lib (string-append out "/lib/mumble"))) (install-file "release/mumble" bin) (install-file "scripts/mumble-overlay" bin) (install-file "scripts/mumble.protocol" services) (install-file "scripts/mumble.desktop" applications) (install-file "icons/mumble.svg" icons) (install-file "man/mumble-overlay.1" man) (install-file "man/mumble.1" man) (install-file "release/murmurd" bin) (install-file "scripts/murmur.ini.system" etc) (rename-file (string-append etc "/murmur.ini.system") (string-append etc "/murmur.ini")) (install-file "scripts/murmur.conf" dbus) (install-file "man/murmurd.1" man) (for-each (lambda (file) (install-file file lib)) (find-files "." "\\.so\\.")) (for-each (lambda (file) (install-file file lib)) (find-files "release/plugins" "\\.so$")) #t)))))) (inputs `(("avahi" ,avahi) ("boost" ,boost) ("libsndfile" ,libsndfile) ("libxi" ,libxi) ("mesa" ,mesa) ; avoid bundled ("openssl" ,openssl) ("opus" ,opus) ; avoid bundled ("protobuf" ,protobuf) ("pulseaudio" ,pulseaudio) ("qtbase" ,qtbase) ("qtsvg" ,qtsvg) ("speech-dispatcher" ,speech-dispatcher) ("speex" ,speex) ; avoid bundled ("speexdsp" ,speexdsp))) ; avoid bundled (native-inputs `(("pkg-config" ,pkg-config) ("python" ,python) ("qttools" ,qttools))) (synopsis "Low-latency, high quality voice chat software") (description "Mumble is an low-latency, high quality voice chat software primarily intended for use while gaming. Mumble consists of two applications for separate usage: @code{mumble} for the client, and @code{murmur} for the server.") (home-page "https://wiki.mumble.info/wiki/Main_Page") (license (list license:bsd-3 ; mumble celt-0.7.0 qqbonjour rnnoise smallft license:bsd-2 ; celt-0.11.0 license:isc)))) ; arc4random (define-public twinkle (package (name "twinkle") (version "1.10.2") (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/LubosD/twinkle") (commit (string-append "v" version)))) (file-name (git-file-name name version)) (patches (search-patches "twinkle-bcg729.patch")) ; To support new BCG729 API. (sha256 (base32 "0s0gi03xwvzp02ah4q6j33r9jx9nbayr6dxlg2ck9pwbay1nq1hx")))) (build-system qt-build-system) (arguments `(#:tests? #f ; no test target #:configure-flags (list ;; FIX-ME: Make Twinkle compatible with libre version of iLBC. ;; "-DWITH_ILBC=On" ; For iLBC Codec Support "-DWITH_ZRTP=On" ; For ZRTP Support "-DWITH_G729=On" ; For G729 Codec Support "-DWITH_SPEEX=On"))) ; For Speex Codec Support (native-inputs `(("bison" ,bison) ("flex" ,flex) ("qttools" ,qttools))) (inputs `(("alsa-lib" ,alsa-lib) ("bcg729" ,bcg729) ("zrtpcpp" ,zrtpcpp) ("ccrtp" ,ccrtp) ("file" ,file) ("libilbc" ,libilbc) ("libsndfile" ,libsndfile) ("libxml2" ,libxml2) ("qtbase" ,qtbase) ("qtdeclarative" ,qtdeclarative) ("qtquickcontrols" ,qtquickcontrols) ("readline" ,readline) ("speex" ,speex) ("speexdsp" ,speexdsp) ("ucommon" ,ucommon))) (synopsis "Softphone for voice over IP and instant messaging") (description "Twinkle is a softphone for your voice over IP and instant messaging communcations using the SIP protocol. You can use it for direct IP phone to IP phone communication or in a network using a SIP proxy to route your calls and messages.") (home-page "http://twinkle.dolezel.info/") (license license:gpl2+))) (define-public pjproject (package (name "pjproject") (version "2.10") (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/pjsip/pjproject") (commit version))) (file-name (git-file-name name version)) (sha256 (base32 "1aklicpgwc88578k03i5d5cm5h8mfm7hmx8vfprchbmaa2p8f4z0")) (modules '((guix build utils))) ;; The patches upstream status can be tracked at: ;; https://github.com/pjsip/pjproject/pull/2501. (patches (search-patches "pjproject-correct-the-cflags-field.patch" "pjproject-fix-pkg-config-ldflags.patch")) (snippet '(begin ;; Remove bundled libraries. (delete-file-recursively "third_party") (substitute* "aconfigure.ac" (("third_party/build/os-auto.mak") "")) (substitute* "Makefile" (("third_party/build") "")) #t)))) (build-system gnu-build-system) (outputs '("out" "debug" "static")) (arguments `(#:tests? #t #:test-target "selftest" #:configure-flags (list "--enable-shared" "--with-external-speex" "--with-external-gsm" "--with-external-srtp" "--with-external-pa" ;; The following flag is Linux specific. ,@(if (string-contains (or (%current-system) (%current-target-system)) "linux") '("--enable-epoll") '()) "--with-gnutls" ;disable OpenSSL checks "--disable-libyuv" ;TODO: add missing package "--disable-silk" ;TODO: add missing package "--disable-libwebrtc" ;TODO: add missing package "--disable-ilbc-codec" ;cannot be unbundled "--disable-g7221-codec" ;TODO: add missing package "--enable-libsamplerate" ;; -DNDEBUG is set to prevent pjproject from raising ;; assertions that aren't critical, crashing ;; applications as the result. "CFLAGS=-DNDEBUG" ;; Specify a runpath reference to itself, which is missing and ;; causes the validate-runpath phase to fail. (string-append "LDFLAGS=-Wl,-rpath=" (assoc-ref %outputs "out") "/lib")) #:phases (modify-phases %standard-phases (add-after 'unpack 'make-source-files-writable ;; Make all the files writable to prevent the following error: ;; "autom4te: cannot open aconfigure: Permission denied". (lambda _ (for-each make-file-writable (find-files ".")) #t)) (add-before 'build 'build-dep (lambda _ (invoke "make" "dep"))) ;; The check phases is moved after the install phase so to ;; use the installed shared libraries for the tests. (delete 'check) (add-after 'install 'move-static-libraries (lambda* (#:key outputs #:allow-other-keys) (let ((out (assoc-ref outputs "out")) (s (string-append (assoc-ref outputs "static") "/lib"))) (mkdir-p s) (with-directory-excursion out (for-each (lambda (f) (rename-file f (string-append s "/" (basename f)))) (find-files "." "\\.a$"))) #t))) (add-after 'install 'check (assoc-ref %standard-phases 'check)) (add-before 'patch-source-shebangs 'autoconf (lambda _ (invoke "autoconf" "-v" "-f" "-i" "-o" "aconfigure" "aconfigure.ac"))) (add-before 'autoconf 'disable-some-tests (lambda _ (substitute* "pjlib/src/pjlib-test/test.h" ;; Disable network tests which are slow and/or require an ;; actual network. (("#define GROUP_NETWORK.*") "#define GROUP_NETWORK 0\n")) (substitute* "self-test.mak" ;; Fails with: pjlib-util-test-x86_64-unknown-linux-gnu: ;; ../src/pjlib-util-test/resolver_test.c:1501: action2_1: ;; Assertio n `pj_strcmp2(&pkt->q[0].name, "_sip._udp." ;; "domain2.com")==0' failed. ((" pjlib_util_test ") "")) (substitute* "pjsip/src/test/test.h" ;; Fails with: Error: unable to acquire TCP transport: ;; [pj_status_t=120101] Network is unreachable. (("#define INCLUDE_TCP_TEST.*") "#define INCLUDE_TCP_TEST 0\n") ;; The TSX tests takes a very long time to run; skip them. (("#define INCLUDE_TSX_GROUP.*") "#define INCLUDE_TSX_GROUP 0\n")) (substitute* "pjsip/src/test/dns_test.c" ;; The round_robin_test fails non-deterministically (depending ;; on load); skip it (see: ;; https://github.com/pjsip/pjproject/issues/2500). (("round_robin_test(pool)") 0)) (substitute* "pjmedia/src/test/test.h" ;; The following tests require a sound card. (("#define HAS_MIPS_TEST.*") "#define HAS_MIPS_TEST 0\n") (("#define HAS_JBUF_TEST.*") "#define HAS_JBUF_TEST 0\n")) (substitute* "Makefile" ;; Disable the pjnath and pjsua tests, which require an actual ;; network and an actual sound card, respectively. (("pjnath-test pjmedia-test pjsip-test pjsua-test") "pjmedia-test pjsip-test")) #t))))) (native-inputs `(("autoconf" ,autoconf) ("automake" ,automake) ("libtool" ,libtool) ("pkg-config" ,pkg-config))) (inputs `(("bcg729" ,bcg729) ("gnutls" ,gnutls) ("gsm" ,gsm) ("libsamplerate" ,libsamplerate) ("libsrtp" ,libsrtp) ("opus" ,opus) ("portaudio" ,portaudio) ("speex" ,speex) ("speexdsp" ,speexdsp))) (home-page "https://www.pjsip.org") (synopsis "Session Initiation Protocol (SIP) stack") (description "PJProject provides an implementation of the Session Initiation Protocol (SIP) and a multimedia framework.") (license license:gpl2+))) (define-public libtgvoip (package (name "libtgvoip") (version "2.4.4") (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/grishka/libtgvoip") (commit version))) (file-name (git-file-name name version)) ;; Fix compilation on i686-linux architecture. ;; NOTE: Applying these patches is order-dependent! ;; The patch for WebRTC /must/ precede the patch for SSE2. (patches (search-patches "libtgvoip-disable-webrtc.patch" "libtgvoip-disable-sse2.patch")) (sha256 (base32 "122kn3jx6v0kkldlzlpzvlwqxgp6pmzxsjhrhcxw12bx9c08sar5")))) (build-system gnu-build-system) (inputs `(("alsa-lib" ,alsa-lib) ("libopusenc" ,libopusenc) ("openssl" ,openssl) ("pulseaudio" ,pulseaudio))) (arguments `(#:phases (modify-phases %standard-phases ;; libtgvoip wants to dlopen libpulse and libasound, so tell it where ;; they are. (add-after 'unpack 'patch-dlopen (lambda* (#:key inputs #:allow-other-keys) (substitute* "os/linux/AudioPulse.cpp" (("libpulse\\.so") (string-append (assoc-ref inputs "pulseaudio") "/lib/libpulse.so"))) (substitute* '("os/linux/AudioInputALSA.cpp" "os/linux/AudioOutputALSA.cpp") (("libasound\\.so") (string-append (assoc-ref inputs "alsa-lib") "/lib/libasound.so"))) #t))))) (synopsis "VoIP library for Telegram clients") (description "A collection of libraries and header files for implementing telephony functionality into custom Telegram clients.") (home-page "https://github.com/zevlg/libtgvoip") (license license:unlicense)))