diff options
Diffstat (limited to 'nonguix')
| -rw-r--r-- | nonguix/build-system/binary.scm | 162 | ||||
| -rw-r--r-- | nonguix/build/binary-build-system.scm | 155 | ||||
| -rw-r--r-- | nonguix/build/utils.scm | 111 | ||||
| -rw-r--r-- | nonguix/download.scm | 62 | ||||
| -rw-r--r-- | nonguix/licenses.scm | 41 | ||||
| -rw-r--r-- | nonguix/modules.scm | 35 | ||||
| -rw-r--r-- | nonguix/utils.scm | 38 |
7 files changed, 0 insertions, 604 deletions
diff --git a/nonguix/build-system/binary.scm b/nonguix/build-system/binary.scm deleted file mode 100644 index 038bd89..0000000 --- a/nonguix/build-system/binary.scm +++ /dev/null @@ -1,162 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> -;;; -;;; This file is not 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 (nonguix build-system binary) - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (guix derivations) - #:use-module (guix search-paths) - #:use-module (guix build-system) - #:use-module (guix build-system gnu) - #:use-module (guix build-system copy) - #:use-module (guix packages) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (nonguix utils) - #:export (%binary-build-system-modules - default-patchelf - default-glibc - lower - binary-build - binary-build-system)) - -;; Commentary: -;; -;; Standard build procedure for binary packages. This is implemented as an -;; extension of `copy-build-system'. -;; -;; Code: - -(define %binary-build-system-modules - ;; Build-side modules imported by default. - `((nonguix build binary-build-system) - (nonguix build utils) - ,@%copy-build-system-modules)) - -(define (default-patchelf) - "Return the default patchelf package." - - ;; Do not use `@' to avoid introducing circular dependencies. - (let ((module (resolve-interface '(gnu packages elf)))) - (module-ref module 'patchelf))) - -(define (default-glibc) - "Return the default glibc package." - ;; Do not use `@' to avoid introducing circular dependencies. - (let ((module (resolve-interface '(gnu packages base)))) - (module-ref module 'glibc))) - -(define* (lower name - #:key source inputs native-inputs outputs system target - (patchelf (default-patchelf)) - (glibc (default-glibc)) - #:allow-other-keys - #:rest arguments) - "Return a bag for NAME." - (define private-keywords - '(#:source #:target #:patchelf #:inputs #:native-inputs)) - - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("patchelf" ,patchelf) - ,@native-inputs - ;; If current system is i686, the *32 packages will be the - ;; same as the non-32, but that's OK. - ("libc32" ,(to32 glibc)))) - (outputs outputs) - (build binary-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) - -(define* (binary-build store name inputs - #:key (guile #f) - (outputs '("out")) - (patchelf-plan ''()) - (install-plan ''(("." "./"))) - (search-paths '()) - (out-of-source? #t) - (validate-runpath? #t) - (patch-shebangs? #t) - (strip-binaries? #t) - (strip-flags ''("--strip-debug")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) - (phases '(@ (nonguix build binary-build-system) - %standard-phases)) - (system (%current-system)) - (imported-modules %binary-build-system-modules) - (modules '((nonguix build binary-build-system) - (guix build utils) - (nonguix build utils)))) - "Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE -provides its own binaries." - (define builder - `(begin - (use-modules ,@modules) - (binary-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:patchelf-plan ,patchelf-plan - #:install-plan ,install-plan - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:out-of-source? ,out-of-source? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) - -(define binary-build-system - (build-system - (name 'binary) - (description "The standard binary build system") - (lower lower))) - -;;; binary.scm ends here diff --git a/nonguix/build/binary-build-system.scm b/nonguix/build/binary-build-system.scm deleted file mode 100644 index 6a676ae..0000000 --- a/nonguix/build/binary-build-system.scm +++ /dev/null @@ -1,155 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> -;;; -;;; This file is not 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 (nonguix build binary-build-system) - #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (nonguix build utils) - #:use-module (guix build utils) - #:use-module (ice-9 match) - #:export (%standard-phases - binary-build)) - -;; Commentary: -;; -;; Builder-side code of the standard binary build procedure. -;; -;; Code: - -(define (new-install) - "Return the copy-build-system `install' procedure." - (@@ (guix build copy-build-system) install)) - -(define* (old-install #:key install-plan outputs #:allow-other-keys) - "Copy files from the \"source\" build input to the \"out\" output according to INSTALL-PLAN. - -An INSTALL-PLAN is made of three elements: - -- A source path which is a file or directory from the \"source\" build input. -- Patterns of the files to copy (only useful if the source path is a directory). -- The target destination. - -If the target ends with a slash, it represents the target directory. If not, it -represent the target full path, which only makes sense for single files." - (define (install-file file target) - (let ((target (string-append (assoc-ref outputs "out") - "/" target - (if (string-suffix? "/" target) - (string-append "/" file) - "")))) - (mkdir-p (dirname target)) - (copy-file file target))) - - (define (install-file-pattern pattern target) - (for-each - (lambda (file) - (install-file file target)) - (find-files "." pattern))) - - (define (install plan) - (match plan - ((file-or-directory files target) - (if (file-is-directory? file-or-directory) - (with-directory-excursion file-or-directory - (for-each - (lambda (pattern) - (install-file-pattern pattern target)) - files)) - (install-file file-or-directory target))))) - - (for-each install install-plan) - #t) - -(define* (install #:key install-plan outputs #:allow-other-keys) - (define (install-old-format) - (warn "Install-plan format deprecated. -Please update to the format of the copy-build-system.") - (old-install #:install-plan install-plan #:outputs outputs)) - (match (car install-plan) - ((source (. matches) target) - (install-old-format)) - ((source #f target) - (install-old-format)) - (_ ((new-install) #:install-plan install-plan #:outputs outputs)))) - -(define* (patchelf #:key inputs outputs patchelf-plan #:allow-other-keys) - "Set the interpreter and the RPATH of files as per the PATCHELF-PLAN. - -The PATCHELF-PLAN elements are lists of: - -- The file to patch. -- The inputs (as strings) to include in the rpath, e.g. \"mesa\". - -Both executables and dynamic libraries are accepted. -The inputs are optional when the file is an executable." - (define (binary-patch binary interpreter runpath) - (unless (string-contains binary ".so") - ;; Use `system*' and not `invoke' since this may raise an error if - ;; library does not end with .so. - (system* "patchelf" "--set-interpreter" interpreter binary)) - (when runpath - (let ((rpath (string-join - (map - (lambda (input-or-output) - (cond - ((assoc-ref outputs input-or-output) - (string-append (assoc-ref outputs input-or-output) "/lib")) - ((assoc-ref inputs input-or-output) - (string-append (assoc-ref inputs input-or-output) "/lib")) - (else (error (format #f "`~a' not found among the inputs nor the outputs." input-or-output))))) - runpath) - ":"))) - (invoke "patchelf" "--set-rpath" rpath binary))) - #t) - - (when (and patchelf-plan - (not (null? patchelf-plan))) - (let ((interpreter (car (find-files (assoc-ref inputs "libc") "ld-linux.*\\.so"))) - (interpreter32 (car (find-files (assoc-ref inputs "libc32") "ld-linux.*\\.so")))) - (for-each - (lambda (plan) - (match plan - ((binary runpath) - (binary-patch binary (if (64-bit? binary) - interpreter - interpreter32) - runpath)) - ((binary) - (binary-patch binary (if (64-bit? binary) - interpreter - interpreter32) - #f)))) - patchelf-plan))) - #t) - -(define %standard-phases - ;; Everything is as with the GNU Build System except for the `configure' - ;; , `build', `check' and `install' phases. - (modify-phases gnu:%standard-phases - (delete 'bootstrap) - (delete 'configure) - (delete 'build) - (delete 'check) - (add-before 'install 'patchelf patchelf) - (replace 'install install))) - -(define* (binary-build #:key inputs (phases %standard-phases) - #:allow-other-keys #:rest args) - "Build the given package, applying all of PHASES in order." - (apply gnu:gnu-build #:inputs inputs #:phases phases args)) - -;;; binary-build-system.scm ends here diff --git a/nonguix/build/utils.scm b/nonguix/build/utils.scm deleted file mode 100644 index ab437f2..0000000 --- a/nonguix/build/utils.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> -;;; -;;; This file is not 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 (nonguix build utils) - #:use-module (ice-9 match) - #:use-module (ice-9 binary-ports) - #:use-module (guix build utils) - #:use-module (srfi srfi-26) - #:export (64-bit? - make-wrapper - concatenate-files)) - -(define (64-bit? file) - "Return true if ELF file is in 64-bit format, false otherwise. -See https://en.wikipedia.org/wiki/Executable_and_Linkable_Format#File_header." - (with-input-from-file file - (lambda () - (= 2 - (array-ref (get-bytevector-n (current-input-port) 5) 4))) - #:binary #t)) - -(define* (make-wrapper wrapper real-file #:key (skip-argument-0? #f) #:rest vars) - "Like `wrap-program' but create WRAPPER around REAL-FILE. -The wrapper automatically changes directory to that of REAL-FILE. - -Example: - - (make-wrapper \"bin/foo\" \"sub-dir/original-foo\" - '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\")) - '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\" - \"/qux/certs\"))) - -will create 'bin/foo' with the following -contents: - - #!location/of/bin/bash - export PATH=\"/gnu/.../bar/bin\" - export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\" - cd sub-dir - exec -a $0 sub-dir/original-foo \"$@\"." - (define (export-variable lst) - ;; Return a string that exports an environment variable. - (match lst - ((var sep '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest sep))) - ((var sep 'prefix rest) - (format #f "export ~a=\"~a${~a:+~a}$~a\"" - var (string-join rest sep) var sep var)) - ((var sep 'suffix rest) - (format #f "export ~a=\"$~a${~a+~a}~a\"" - var var var sep (string-join rest sep))) - ((var '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest ":"))) - ((var 'prefix rest) - (format #f "export ~a=\"~a${~a:+:}$~a\"" - var (string-join rest ":") var var)) - ((var 'suffix rest) - (format #f "export ~a=\"$~a${~a:+:}~a\"" - var var var (string-join rest ":"))))) - - (define (remove-keyword-arguments lst) - (match lst - (() '()) - (((? keyword? _) _ lst ...) - (remove-keyword-arguments lst)) - (_ lst))) - - (mkdir-p (dirname wrapper)) - (call-with-output-file wrapper - (lambda (port) - (format port - (if skip-argument-0? - "#!~a~%~a~%cd \"~a\"~%exec \"~a\" \"$@\"~%" - "#!~a~%~a~%cd \"~a\"~%exec -a \"$0\" \"~a\" \"$@\"~%") - (which "bash") - (string-join - (map export-variable (remove-keyword-arguments vars)) - "\n") - (dirname real-file) - (canonicalize-path real-file)))) - (chmod wrapper #o755)) - -(define (concatenate-files files result) - "Make RESULT the concatenation of all of FILES." - (define (dump file port) - (put-bytevector - port - (call-with-input-file file - get-bytevector-all))) - - (call-with-output-file result - (lambda (port) - (for-each (cut dump <> port) files)))) diff --git a/nonguix/download.scm b/nonguix/download.scm deleted file mode 100644 index 11087ff..0000000 --- a/nonguix/download.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> -;;; -;;; This program 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. -;;; -;;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. - -(define-module (nonguix download) - #:use-module (guix derivations) - #:use-module (guix monads) - #:use-module (guix packages) - #:use-module (guix store) - #:use-module (ice-9 match) - #:export (unredistributable-url-fetch)) - -(define* (unredistributable-url-fetch url hash-algo hash - #:optional name - #:key (system (%current-system)) - (guile (default-guile))) - "Return a fixed-output derivation that fetches URL (a string) which is expected -to have HASH of type HASH-ALGO (a symbol). By default, the file name is the base -name of URL; optionally, NAME can specify a different file name. - -This is a simpler version of url-fetch from Guix, that doesn't support mirror:// -or file:// uris. It is specifically designed to prevent substitution of the -source, for the purpose of downloading copyrighted content you have access to, -but you don't have the right to redistribute. By marking the derivation as non -substitutable, this fetch prevents you from giving others access to the source -if you run a substitute server on your machine." - (define file-name - (match url - ((head _ ...) - (basename head)) - (_ - (basename url)))) - - (mlet %store-monad () - (raw-derivation (or name file-name) "builtin:download" '() - #:system system - #:hash-algo hash-algo - #:hash hash - - ;; Honor the user's proxy and locale settings. - #:leaked-env-vars '("http_proxy" "https_proxy" - "LC_ALL" "LC_MESSAGES" "LANG" - "COLUMNS") - #:env-vars `(("url" . ,(object->string url))) - - ;; Do not offload because the remote daemon may not support - ;; the 'download' builtin. - #:local-build? #t - - ;; Do not substitute copyrighted material - #:substitutable? #f))) diff --git a/nonguix/licenses.scm b/nonguix/licenses.scm deleted file mode 100644 index 84d2346..0000000 --- a/nonguix/licenses.scm +++ /dev/null @@ -1,41 +0,0 @@ -;;; Copyright © 2019 Alex Griffin <a@ajgrf.com> -;;; -;;; This program 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. -;;; -;;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. - -(define-module (nonguix licenses) - #:use-module (guix licenses) - #:export (nonfree - undistributable)) - -(define license (@@ (guix licenses) license)) - -(define* (nonfree uri #:optional (comment "")) - "Return a nonfree license, whose full text can be found -at URI, which may be a file:// URI pointing the package's tree." - (license "Nonfree" - uri - (string-append - "This a nonfree license. Check the URI for details. " - comment))) - -(define* (undistributable uri #:optional (comment "")) - "Return a nonfree license for packages which may not be redistributed, whose -full text can be found at URI, which may be a file:// URI pointing the -package's tree." - (license "Nonfree Undistributable" - uri - (string-append - "This a nonfree license. This package may NOT be redistributed " - "in prebuilt form. Check the URI for details. " - comment))) diff --git a/nonguix/modules.scm b/nonguix/modules.scm deleted file mode 100644 index 24d4267..0000000 --- a/nonguix/modules.scm +++ /dev/null @@ -1,35 +0,0 @@ -;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> -;;; -;;; This program 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. -;;; -;;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. - -(define-module (nonguix modules) - #:use-module (ice-9 match) - #:export (import-nonguix-module?)) - -(define (nonguix-module-name? name) - "Return true if NAME (a list of symbols) denotes a Guix or Nonguix module." - (match name - (('guix _ ...) #t) - (('gnu _ ...) #t) - (('nonguix _ ...) #t) - (('nongnu _ ...) #t) - (_ #f))) - -;; Since we don't use deduplication support in 'populate-store', don't -;; import (guix store deduplication) and its dependencies, which -;; includes Guile-Gcrypt. -(define (import-nonguix-module? module) - "Return true if MODULE is not (guix store deduplication)" - (and (nonguix-module-name? module) - (not (equal? module '(guix store deduplication))))) diff --git a/nonguix/utils.scm b/nonguix/utils.scm deleted file mode 100644 index 7611a47..0000000 --- a/nonguix/utils.scm +++ /dev/null @@ -1,38 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz> -;;; -;;; This file is not 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 (nonguix utils) - #:use-module (srfi srfi-26) - #:use-module (ice-9 match) - #:use-module (ice-9 textual-ports) - #:use-module (ice-9 popen) - #:use-module (guix utils) - #:use-module (guix packages)) - -(define-public (to32 package64) - "Build package for i686-linux. -Only x86_64-linux and i686-linux are supported. -- If i686-linux, return the package unchanged. -- If x86_64-linux, return the 32-bit version of the package." - (match (%current-system) - ("x86_64-linux" - (package - (inherit package64) - (arguments `(#:system "i686-linux" - ,@(package-arguments package64))))) - (_ package64))) |