diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/haskell.scm | 135 | ||||
| -rw-r--r-- | guix/build/glib-or-gtk-build-system.scm | 4 | ||||
| -rw-r--r-- | guix/build/haskell-build-system.scm | 220 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 63 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 243 | ||||
| -rw-r--r-- | guix/store.scm | 34 | ||||
| -rw-r--r-- | guix/ui.scm | 2 |
7 files changed, 672 insertions, 29 deletions
diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm new file mode 100644 index 0000000000..79faa5a09e --- /dev/null +++ b/guix/build-system/haskell.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; +;;; 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 (guix build-system haskell) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (haskell-build + haskell-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Haskell packages using 'Setup.hs'. This is +;; implemented as an extension of 'gnu-build-system'. +;; +;; Code: + +(define (default-haskell) + "Return the default Haskell package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((haskell (resolve-interface '(gnu packages haskell)))) + (module-ref haskell 'ghc))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (haskell (default-haskell)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:haskell #: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 `(("haskell" ,haskell) + ,@native-inputs)) + (outputs outputs) + (build haskell-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (haskell-build store name inputs + #:key source + (haddock? #t) + (haddock-flags ''()) + (tests? #t) + (test-target "test") + (configure-flags ''()) + (phases '(@ (guix build haskell-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules '((guix build haskell-build-system) + (guix build gnu-build-system) + (guix build utils))) + (modules '((guix build haskell-build-system) + (guix build utils)))) + "Build SOURCE using HASKELL, and with INPUTS. This assumes that SOURCE +provides a 'Setup.hs' file as its build system." + (define builder + `(begin + (use-modules ,@modules) + (haskell-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:configure-flags ,configure-flags + #:haddock-flags ,haddock-flags + #:system ,system + #:test-target ,test-target + #:tests? ,tests? + #:haddock? ,haddock? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (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 + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define haskell-build-system + (build-system + (name 'haskell) + (description "The standard Haskell build system") + (lower lower))) + +;;; haskell.scm ends here diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 9c0104365d..15d7de2236 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -140,7 +140,9 @@ add a dependency of that output on GLib and GTK+." ((output . directory) (unless (member output glib-or-gtk-wrap-excluded-outputs) (let* ((bindir (string-append directory "/bin")) - (bin-list (find-files bindir ".*")) + (libexecdir (string-append directory "/libexec")) + (bin-list (append (find-files bindir ".*") + (find-files libexecdir ".*"))) (datadirs (data-directories (alist-cons output directory inputs))) (gtk-mod-dirs (gtk-module-directories diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm new file mode 100644 index 0000000000..52b9c79d2f --- /dev/null +++ b/guix/build/haskell-build-system.scm @@ -0,0 +1,220 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; +;;; 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 (guix build haskell-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:export (%standard-phases + haskell-build)) + +;; Commentary: +;; +;; Builder-side code of the standard Haskell package build procedure. +;; +;; The Haskell compiler, to find libraries, relies on a library database with +;; a binary cache. For GHC the cache has to be named 'package.cache'. If every +;; library would generate the cache at build time, then they would clash in +;; profiles. For this reason we do not generate the cache when we generate +;; libraries substitutes. Instead: +;; +;; - At build time we use the 'setup-compiler' phase to generate a temporary +;; library database and its cache. +;; +;; - We generate the cache when a profile is created. +;; +;; Code: + +;; Directory where we create the temporary libraries database with its cache +;; as required by the compiler. +(define %tmp-db-dir + (string-append (or (getenv "TMP") "/tmp") + "/package.conf.d")) + +(define (run-setuphs command params) + (let ((setup-file (cond + ((file-exists? "Setup.hs") + "Setup.hs") + ((file-exists? "Setup.lhs") + "Setup.lhs") + (else + #f)))) + (if setup-file + (begin + (format #t "running \"runhaskell Setup.hs\" with command ~s \ +and parameters ~s~%" + command params) + (zero? (apply system* "runhaskell" setup-file command params))) + (error "no Setup.hs nor Setup.lhs found")))) + +(define* (configure #:key outputs inputs tests? (configure-flags '()) + #:allow-other-keys) + "Configure a given Haskell package." + (let* ((out (assoc-ref outputs "out")) + (input-dirs (match inputs + (((_ . dir) ...) + dir) + (_ '()))) + (params (append `(,(string-append "--prefix=" out)) + `(,(string-append + "--docdir=" out "/share/doc/" + (package-name-version out))) + `(,(string-append "--package-db=" %tmp-db-dir)) + '("--global") + `(,(string-append + "--extra-include-dirs=" + (list->search-path-as-string + (search-path-as-list '("include") input-dirs) + ":"))) + `(,(string-append + "--extra-lib-dirs=" + (list->search-path-as-string + (search-path-as-list '("lib") input-dirs) + ":"))) + (if tests? + '("--enable-tests") + '()) + configure-flags))) + (run-setuphs "configure" params))) + +(define* (build #:rest empty) + "Build a given Haskell package." + (run-setuphs "build" '())) + +(define* (install #:rest empty) + "Install a given Haskell package." + (run-setuphs "copy" '())) + +(define (package-name-version store-dir) + "Given a store directory STORE-DIR return 'name-version' of the package." + (let* ((base (basename store-dir))) + (string-drop base + (+ 1 (string-index base #\-))))) + +(define (grep rx port) + "Given a regular-expression RX including a group, read from PORT until the +first match and return the content of the group." + (let ((line (read-line port))) + (if (eof-object? line) + #f + (let ((rx-result (regexp-exec rx line))) + (if rx-result + (match:substring rx-result 1) + (grep rx port)))))) + +(define* (setup-compiler #:key system inputs outputs #:allow-other-keys) + "Setup the compiler environment." + (let* ((haskell (assoc-ref inputs "haskell")) + (name-version (package-name-version haskell))) + (cond + ((string-match "ghc" name-version) + (make-ghc-package-database system inputs outputs)) + (else + (format #t + "Compiler ~a not supported~%" name-version))))) + +(define (make-ghc-package-database system inputs outputs) + "Generate the GHC package database." + (let* ((haskell (assoc-ref inputs "haskell")) + (input-dirs (match inputs + (((_ . dir) ...) + dir) + (_ '()))) + (conf-dirs (search-path-as-list + `(,(string-append "lib/" system "-" + (package-name-version haskell) + "/package.conf.d")) + input-dirs)) + (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) + (mkdir-p %tmp-db-dir) + (for-each (lambda (file) + (copy-file file + (string-append %tmp-db-dir "/" (basename file)))) + conf-files) + (zero? (system* "ghc-pkg" + (string-append "--package-db=" %tmp-db-dir) + "recache")))) + +(define* (register #:key name system inputs outputs #:allow-other-keys) + "Generate the compiler registration file for a given Haskell package. Don't +generate the cache as it would clash in user profiles." + (let* ((out (assoc-ref outputs "out")) + (haskell (assoc-ref inputs "haskell")) + (lib (string-append out "/lib")) + (config-dir (string-append lib "/" system + "-" (package-name-version haskell) + "/package.conf.d")) + (id-rx (make-regexp "^id: *(.*)$")) + (lib-rx (make-regexp "lib.*\\.(a|so)")) + (config-file (string-append config-dir "/" name ".conf")) + (params + (list (string-append "--gen-pkg-config=" config-file)))) + (unless (null? (find-files lib lib-rx)) + (mkdir-p config-dir) + (run-setuphs "register" params) + (let ((config-file-name+id + (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (rename-file config-file + (string-append config-dir "/" config-file-name+id + ".conf")))) + #t)) + +(define* (check #:key tests? test-target #:allow-other-keys) + "Run the test suite of a given Haskell package." + (if tests? + (run-setuphs test-target '()) + (begin + (format #t "test suite not run~%") + #t))) + +(define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys) + "Run the test suite of a given Haskell package." + (if haddock? + (let* ((out (assoc-ref outputs "out")) + (doc-src (string-append (getcwd) "/dist/doc")) + (doc-dest (string-append out "/share/doc/" + (package-name-version out)))) + (if (run-setuphs "haddock" haddock-flags) + (begin + (copy-recursively doc-src doc-dest) + #t) + #f)) + #t)) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (add-before configure setup-compiler setup-compiler) + (add-after install haddock haddock) + (add-after install register register) + (replace install install) + (replace check check) + (replace build build) + (replace configure configure))) + +(define* (haskell-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Haskell package, applying all of PHASES in order." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) + +;;; haskell-build-system.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 3cc7ae760f..6190f3286d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -232,6 +232,41 @@ DURATION-RELATION with the current time." filter-by-duration) (else #f))) +(define (delete-matching-generations store profile pattern) + "Delete from PROFILE all the generations matching PATTERN. PATTERN must be +a string denoting a set of generations: the empty list means \"all generations +but the current one\", a number designates a generation, and other patterns +denote ranges as interpreted by 'matching-derivations'." + (let ((current (generation-number profile))) + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (delete-generations (%store) profile + (delv current (profile-generations profile)))) + ;; Do not delete the zeroth generation. + ((equal? 0 (string->number pattern)) + #t) + + ;; If PATTERN is a duration, match generations that are + ;; older than the specified duration. + ((matching-generations pattern profile + #:duration-relation >) + => + (lambda (numbers) + (when (memv current numbers) + (warning (_ "not removing generation ~a, which is current~%") + current)) + + ;; Make sure we don't inadvertently remove the current + ;; generation. + (let ((numbers (delv current numbers))) + (when (null-list? numbers) + (leave (_ "no matching generation~%"))) + (delete-generations (%store) profile numbers)))) + (else + (leave (_ "invalid syntax: ~a~%") pattern))))) + ;;; ;;; Package specifications. @@ -751,9 +786,6 @@ more information.~%")) (define dry-run? (assoc-ref opts 'dry-run?)) (define profile (assoc-ref opts 'profile)) - (define current-generation-number - (generation-number profile)) - ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) @@ -782,30 +814,7 @@ more information.~%")) (for-each (match-lambda (('delete-generations . pattern) - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (delete-generations - (%store) profile - (delete current-generation-number - (profile-generations profile)))) - ;; Do not delete the zeroth generation. - ((equal? 0 (string->number pattern)) - (exit 0)) - - ;; If PATTERN is a duration, match generations that are - ;; older than the specified duration. - ((matching-generations pattern profile - #:duration-relation >) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (delete-generations (%store) profile numbers)))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) + (delete-matching-generations (%store) profile pattern) (process-actions (alist-delete 'delete-generations opts))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm new file mode 100644 index 0000000000..c7c66fefbe --- /dev/null +++ b/guix/scripts/publish.scm @@ -0,0 +1,243 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@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 (guix scripts publish) + #:use-module ((system repl server) #:prefix repl:) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web uri) + #:use-module (guix base32) + #:use-module (guix base64) + #:use-module (guix config) + #:use-module (guix derivations) + #:use-module (guix hash) + #:use-module (guix pki) + #:use-module (guix pk-crypto) + #:use-module (guix store) + #:use-module (guix serialization) + #:use-module (guix ui) + #:export (guix-publish)) + +(define (show-help) + (format #t (_ "Usage: guix publish [OPTION]... +Publish ~a over HTTP.\n") %store-directory) + (display (_ " + -p, --port=PORT listen on PORT")) + (display (_ " + -r, --repl[=PORT] spawn REPL server on PORT")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (list (option '(#\h "help") #f #f + (lambda _ + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda _ + (show-version-and-exit "guix publish"))) + (option '(#\p "port") #t #f + (lambda (opt name arg result) + (alist-cons 'port (string->number* arg) result))) + (option '(#\r "repl") #f #t + (lambda (opt name arg result) + ;; If port unspecified, use default Guile REPL port. + (let ((port (and arg (string->number* arg)))) + (alist-cons 'repl (or port 37146) result)))))) + +(define %default-options + '((port . 8080) + (repl . #f))) + +(define (lazy-read-file-sexp file) + "Return a promise to read the canonical sexp from FILE." + (delay + (call-with-input-file file + (compose string->canonical-sexp + get-string-all)))) + +(define %private-key + (lazy-read-file-sexp %private-key-file)) + +(define %public-key + (lazy-read-file-sexp %public-key-file)) + +(define %nix-cache-info + `(("StoreDir" . ,%store-directory) + ("WantMassQuery" . 0) + ("Priority" . 100))) + +(define (load-derivation file) + "Read the derivation from FILE." + (call-with-input-file file read-derivation)) + +(define (signed-string s) + "Sign the hash of the string S with the daemon's key." + (let* ((public-key (force %public-key)) + (hash (bytevector->hash-data (sha256 (string->utf8 s)) + #:key-type (key-type public-key)))) + (signature-sexp hash (force %private-key) public-key))) + +(define base64-encode-string + (compose base64-encode string->utf8)) + +(define (narinfo-string store-path path-info key) + "Generate a narinfo key/value string for STORE-PATH using the details in +PATH-INFO. The narinfo is signed with KEY." + (let* ((url (string-append "nar/" (basename store-path))) + (hash (bytevector->base32-string + (path-info-hash path-info))) + (size (path-info-nar-size path-info)) + (references (string-join + (map basename (path-info-references path-info)) + " ")) + (deriver (path-info-deriver path-info)) + (base-info (format #f + "StorePath: ~a +URL: ~a +Compression: none +NarHash: sha256:~a +NarSize: ~d +References: ~a~%" + store-path url hash size references)) + ;; Do not render a "Deriver" or "System" line if we are rendering + ;; info for a derivation. + (info (if (string-null? deriver) + base-info + (let ((drv (load-derivation deriver))) + (format #f "~aSystem: ~a~%Deriver: ~a~%" + base-info (derivation-system drv) + (basename deriver))))) + (signature (base64-encode-string + (canonical-sexp->string (signed-string info))))) + (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) + +(define (not-found request) + "Render 404 response for REQUEST." + (values (build-response #:code 404) + (string-append "Resource not found: " + (uri-path (request-uri request))))) + +(define (render-nix-cache-info) + "Render server information." + (values '((content-type . (text/plain))) + (lambda (port) + (for-each (match-lambda + ((key . value) + (format port "~a: ~a~%" key value))) + %nix-cache-info)))) + +(define (render-narinfo store request hash) + "Render metadata for the store path corresponding to HASH." + (let* ((store-path (hash-part->path store hash)) + (path-info (and (not (string-null? store-path)) + (query-path-info store store-path)))) + (if path-info + (values '((content-type . (application/x-nix-narinfo))) + (cut display + (narinfo-string store-path path-info (force %private-key)) + <>)) + (not-found request)))) + +(define (render-nar request store-item) + "Render archive of the store path corresponding to STORE-ITEM." + (let ((store-path (string-append %store-directory "/" store-item))) + ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will + ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte + ;; sequences. + (if (file-exists? store-path) + (values '((content-type . (application/x-nix-archive + (charset . "ISO-8859-1")))) + (lambda (port) + (write-file store-path port))) + (not-found request)))) + +(define extract-narinfo-hash + (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$"))) + (lambda (str) + "Return the hash within the narinfo resource string STR, or false if STR +is invalid." + (and=> (regexp-exec regexp str) + (cut match:substring <> 1))))) + +(define (get-request? request) + "Return #t if REQUEST uses the GET method." + (eq? (request-method request) 'GET)) + +(define (request-path-components request) + "Split the URI path of REQUEST into a list of component strings. For +example: \"/foo/bar\" yields '(\"foo\" \"bar\")." + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (make-request-handler store) + (lambda (request body) + (format #t "~a ~a~%" + (request-method request) + (uri-path (request-uri request))) + (if (get-request? request) ; reject POST, PUT, etc. + (match (request-path-components request) + ;; /nix-cache-info + (("nix-cache-info") + (render-nix-cache-info)) + ;; /<hash>.narinfo + (((= extract-narinfo-hash (? string? hash))) + (render-narinfo store request hash)) + ;; /nar/<store-item> + (("nar" store-item) + (render-nar request store-item)) + (_ (not-found request))) + (not-found request)))) + +(define (run-publish-server port store) + (run-server (make-request-handler store) + 'http + `(#:addr ,INADDR_ANY + #:port ,port))) + +(define (guix-publish . args) + (with-error-handling + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (port (assoc-ref opts 'port)) + (repl-port (assoc-ref opts 'repl))) + (format #t (_ "publishing ~a on port ~d~%") %store-directory port) + (when repl-port + (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) + (with-store store + (run-publish-server (assoc-ref opts 'port) store))))) diff --git a/guix/store.scm b/guix/store.scm index 3d6b06989c..10b9062db2 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -60,6 +60,7 @@ valid-path? query-path-hash hash-part->path + query-path-info add-text-to-store add-to-store build-things @@ -79,6 +80,13 @@ substitutable-paths substitutable-path-info + path-info? + path-info-deriver + path-info-hash + path-info-references + path-info-registration-time + path-info-nar-size + references requisites referrers @@ -212,6 +220,24 @@ (cons (substitutable path deriver refs dl-size nar-size) result)))))) +;; Information about a store path. +(define-record-type <path-info> + (path-info deriver hash references registration-time nar-size) + path-info? + (deriver path-info-deriver) + (hash path-info-hash) + (references path-info-references) + (registration-time path-info-registration-time) + (nar-size path-info-nar-size)) + +(define (read-path-info p) + (let ((deriver (read-store-path p)) + (hash (base16-string->bytevector (read-string p))) + (refs (read-store-path-list p)) + (registration-time (read-int p)) + (nar-size (read-long-long p))) + (path-info deriver hash refs registration-time nar-size))) + (define-syntax write-arg (syntax-rules (integer boolean file string string-list string-pairs store-path store-path-list base16) @@ -236,7 +262,7 @@ (define-syntax read-arg (syntax-rules (integer boolean string store-path store-path-list - substitutable-path-list base16) + substitutable-path-list path-info base16) ((_ integer p) (read-int p)) ((_ boolean p) @@ -249,6 +275,8 @@ (read-store-path-list p)) ((_ substitutable-path-list p) (read-substitutable-path-list p)) + ((_ path-info p) + (read-path-info p)) ((_ base16 p) (base16-string->bytevector (read-string p))))) @@ -541,6 +569,10 @@ string). Raise an error if no such path exists." ;; /HASH.narinfo. (query-path-from-hash-part server hash-part)))) +(define-operation (query-path-info (store-path path)) + "Return the info (hash, references, etc.) for PATH." + path-info) + (define add-text-to-store ;; A memoizing version of `add-to-store', to avoid repeated RPCs with ;; the very same arguments during a given session. diff --git a/guix/ui.scm b/guix/ui.scm index 9e75a35d16..5ca5afe457 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -902,6 +902,8 @@ found." (format (current-error-port) (_ "guix: unrecognized option '~a'~%") o) (show-guix-usage)) + (("help" args ...) + (show-guix-help)) ((command args ...) (apply run-guix-command (string->symbol command) |