<
aboutsummaryrefslogtreecommitdiff
path: root/emacs/guix-history.el
blob: 5d301a689e8bbc3c7957c3de2f6ff9d147f4f0db (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
;;; guix-history.el --- History of buffer information

;; Copyright © 2014 Alex Kost <alezost@gmail.com>

;; 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This file provides support for history of buffers similar to the
;; history of a `help-mode' buffer.

;;; Code:

(require 'cl-macs)

(defvar-local guix-history-stack-item nil
  "Current item of the history.
A list of the form (FUNCTION [ARGS ...]).
The item is used by calling (apply FUNCTION ARGS).")
(put 'guix-history-stack-item 'permanent-local t)

(defvar-local guix-history-back-stack nil
  "Stack (list) of visited items.
Each element of the list has a form of `guix-history-stack-item'.")
(put 'guix-history-back-stack 'permanent-local t)

(defvar-local guix-history-forward-stack nil
  "Stack (list) of items visited with `guix-history-back'.
Each element of the list has a form of `guix-history-stack-item'.")
(put 'guix-history-forward-stack 'permanent-local t)

(defvar guix-history-size 0
  "Maximum number of items saved in history.
If 0, the history is disabled.")

(defun guix-history-add (item)
  "Add ITEM to history."
  (and guix-history-stack-item
       (push guix-history-stack-item guix-history-back-stack))
  (setq guix-history-forward-stack nil
        guix-history-stack-item item)
  (when (>= (length guix-history-back-stack)
            guix-history-size)
    (setq guix-history-back-stack
          (cl-loop for elt in guix-history-back-stack
                   for i from 1 to guix-history-size
                   collect elt))))

(defun guix-history-replace (item)
  "Replace current item in history with ITEM."
  (setq guix-history-stack-item item))

(defun guix-history-goto (item)
  "Go to the ITEM of history.
ITEM should have the form of `guix-history-stack-item'."
  (or (listp item)
      (error "Wrong value of history element"))
  (setq guix-history-stack-item item)
  (apply (car item) (cdr item)))

(defun guix-history-back ()
  "Go back to the previous element of history in the current buffer."
  (interactive)
  (or guix-history-back-stack
      (user-error "No previous element in history"))
  (push guix-history-stack-item guix-history-forward-stack)
  (guix-history-goto (pop guix-history-back-stack)))

(defun guix-history-forward ()
  "Go forward to the next element of history in the current buffer."
  (interactive)
  (or guix-history-forward-stack
      (user-error "No next element in history"))
  (push guix-history-stack-item guix-history-back-stack)
  (guix-history-goto (pop guix-history-forward-stack)))

(provide 'guix-history)

;;; guix-history.el ends here
h-output-file (ungexp output) (lambda (port) ;; Note: that makes a long shebang. When the store ;; is /gnu/store, that fits within the 128-byte ;; limit imposed by Linux, but that may go beyond ;; when running tests. (format port "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) (write '(ungexp set-load-path) port) (write '(ungexp exp) port) (chmod port #o555)))) #:module-path module-path))) (define (date-version-string) "Return the current date and hour in UTC timezone, for use as a poor person's version identifier." ;; XXX: Replace with a Git commit id. (date->string (current-date 0) "~Y~m~d.~H")) (define guile-gcrypt ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in ;; August 2018. If it has it, it's at least version 0.1.0, which is good ;; enough. If it doesn't, specify our own package because the target Guix ;; requires it. (match (find-best-packages-by-name "guile-gcrypt" #f) (() (package (name "guile-gcrypt") (version "0.1.0") (home-page "https://notabug.org/cwebber/guile-gcrypt") (source (origin (method url-fetch) (uri (string-append home-page "/archive/v" version ".tar.gz")) (sha256 (base32 "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3")) (file-name (string-append name "-" version ".tar.gz")))) (build-system gnu-build-system) (arguments ;; The 'bootstrap' phase appeared in 'core-updates', which was merged ;; into 'master' ca. June 2018. '(#:phases (modify-phases %standard-phases (delete 'bootstrap) (add-before 'configure 'bootstrap (lambda _ (unless (zero? (system* "autoreconf" "-vfi")) (error "autoreconf failed")) #t))))) (native-inputs `(("pkg-config" ,(specification->package "pkg-config")) ("autoconf" ,(specification->package "autoconf")) ("automake" ,(specification->package "automake")) ("texinfo" ,(specification->package "texinfo")))) (inputs `(("guile" ,(specification->package "guile")) ("libgcrypt" ,(specification->package "libgcrypt")))) (synopsis "Cryptography library for Guile using Libgcrypt") (description "Guile-Gcrypt provides a Guile 2.x interface to a subset of the GNU Libgcrypt crytographic library. It provides modules for cryptographic hash functions, message authentication codes (MAC), public-key cryptography, strong randomness, and more. It is implemented using the foreign function interface (FFI) of Guile.") (license #f))) ;license:gpl3+ ((package . _) package))) (define* (build-program source version #:optional (guile-version (effective-version)) #:key (pull-version 0) (channel-metadata #f) built-in-builders) "Return a program that computes the derivation to build Guix from SOURCE. If BUILT-IN-BUILDERS is provided, it should be a list of strings and this will be used instead of the builtin builders provided by the build daemon, from within the generated build program." (define select? ;; Select every module but (guix config) and non-Guix modules. ;; Also exclude (guix channels): it is autoloaded by (guix describe), but ;; only for peripheral functionality. (match-lambda (('guix 'config) #f) (('guix 'channels) #f) (('guix 'build 'download) #f) ;autoloaded by (guix download) (('guix _ ...) #t) (('gnu _ ...) #t) (_ #f))) (define fake-gcrypt-hash ;; Fake (gcrypt hash) module; see below. (scheme-file "hash.scm" #~(define-module (gcrypt hash) #:export (sha1 sha256)))) (define fake-git (scheme-file "git.scm" #~(define-module (git)))) (with-imported-modules `(((guix config) => ,(make-config.scm)) ;; To avoid relying on 'with-extensions', which was ;; introduced in 0.15.0, provide a fake (gcrypt ;; hash) just so that we can build modules, and ;; adjust %LOAD-PATH later on. ((gcrypt hash) => ,fake-gcrypt-hash) ;; (guix git-download) depends on (git) but only ;; for peripheral functionality. Provide a dummy ;; (git) to placate it. ((git) => ,fake-git) ,@(source-module-closure `((guix store) (guix self) (guix derivations) (gnu packages bootstrap)) (list source) #:select? select?)) (gexp->script "compute-guix-derivation" #~(begin (use-modules (ice-9 match)) (eval-when (expand load eval) ;; (gnu packages …) modules are going to be looked up ;; under SOURCE. (guix config) is looked up in FRONT. (match (command-line) ((_ source _ ...) (match %load-path ((front _ ...) (unless (string=? front source) ;already done? (set! %load-path (list source (string-append #$guile-gcrypt "/share/guile/site/" (effective-version)) front))))))) ;; Only load Guile-Gcrypt, our own modules, or those ;; of Guile. (set! %load-compiled-path (cons (string-append #$guile-gcrypt "/lib/guile/" (effective-version) "/site-ccache") %load-compiled-path)) ;; Disable position recording to save time and space ;; when loading the package modules. (read-disable 'positions)) (use-modules (guix store) (guix self) (guix derivations) (srfi srfi-1)) (match (command-line) ((_ source system version protocol-version build-output) ;; The current input port normally wraps a file ;; descriptor connected to the daemon, or it is ;; connected to /dev/null. In the former case, reuse ;; the connection such that we inherit build options ;; such as substitute URLs and so on; in the latter ;; case, attempt to open a new connection. (let* ((proto (string->number protocol-version)) (store (if (integer? proto) (port->connection (duplicate-port (current-input-port) "w+0") #:version proto #:built-in-builders '#$built-in-builders) (open-connection #:built-in-builders '#$built-in-builders))) (sock (socket AF_UNIX SOCK_STREAM 0))) ;; Connect to BUILD-OUTPUT and send it the raw ;; build output. (connect sock AF_UNIX build-output) (display (and=> ;; Silence autoload warnings and the likes. (parameterize ((current-warning-port (%make-void-port "w")) (current-build-output-port sock)) (run-with-store store (guix-derivation source version #$guile-version #:channel-metadata '#$channel-metadata #:pull-version #$pull-version) #:system system)) derivation-file-name)))))) #:module-path (list source)))) (define (proxy input output) "Dump the contents of INPUT to OUTPUT until EOF is reached on INPUT. Display a spinner when nothing happens." (define spin (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/")) (setvbuf input 'block 16384) (let loop ((spin spin)) (match (select (list input) '() '() 1) ((() () ()) (when (isatty? (current-error-port)) (display (string-append "\b" (car spin)) (current-error-port)) (force-output (current-error-port))) (loop (cdr spin))) (((_) () ()) ;; Read from INPUT as much as can be read without blocking. (let ((bv (get-bytevector-some input))) (unless (eof-object? bv) (put-bytevector output bv) (loop spin))))))) (define (call-with-clean-environment thunk) (let ((env (environ))) (dynamic-wind (lambda () (environ '())) thunk (lambda () (environ env))))) (define-syntax-rule (with-clean-environment exp ...) "Evaluate EXP in a context where zero environment variables are defined." (call-with-clean-environment (lambda () exp ...))) ;; The procedure below is our return value. (define* (build source #:key verbose? (version (date-version-string)) channel-metadata system (pull-version 0) ;; For the standalone Guix, default to Guile 3.0. For old ;; versions of 'guix pull' (pre-0.15.0), we have to use the ;; same Guile as the current one. (guile-version (if (> pull-version 0) "3.0" (effective-version))) built-in-builders #:allow-other-keys #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." ;; Build the build program and then use it as a trampoline to build from ;; SOURCE. (mlet %store-monad ((build (build-program source version guile-version #:channel-metadata channel-metadata #:pull-version pull-version #:built-in-builders built-in-builders)) (system (if system (return system) (current-system))) (home -> (getenv "HOME")) ;; Note: Use the deprecated names here because the ;; caller might be Guix <= 0.16.0. (port ((store-lift nix-server-socket))) (major ((store-lift nix-server-major-version))) (minor ((store-lift nix-server-minor-version)))) (mbegin %store-monad ;; Before 'with-build-handler' was implemented and used, we had to ;; explicitly call 'show-what-to-build*'. (munless (module-defined? (resolve-module '(guix store)) 'with-build-handler) (show-what-to-build* (list build))) (built-derivations (list build)) ;; Use the port beneath the current store as the stdin of BUILD. This ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is ;; not a file port (e.g., it's an SSH channel), then the subprocess's ;; stdin will actually be /dev/null. (let* ((sock (socket AF_UNIX SOCK_STREAM 0)) (node (let ((file (string-append (or (getenv "TMPDIR") "/tmp") "/guix-build-output-" (number->string (getpid))))) (bind sock AF_UNIX file) (listen sock 1) file)) (pipe (with-input-from-port port (lambda () ;; Make sure BUILD is not influenced by ;; $GUILE_LOAD_PATH & co. (with-clean-environment (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive (setenv "COLUMNS" "120") ;show wider backtraces (when home ;; Inherit HOME so that 'xdg-directory' works. (setenv "HOME" home)) (open-pipe* OPEN_READ (derivation->output-path build) source system version (if (file-port? port) (number->string (logior major minor)) "none") node)))))) (format (current-error-port) "Computing Guix derivation for '~a'... " system) ;; Wait for a connection on SOCK and proxy build output so it can be ;; processed according to the settings currently in effect (build ;; traces, verbosity level, and so on). (match (accept sock) ((port . _) (close-port sock) (delete-file node) (proxy port (current-build-output-port)))) ;; Now that the build output connection was closed, read the result, a ;; derivation file name, from PIPE. (let ((str (get-string-all pipe)) (status (close-pipe pipe))) (match str ((? eof-object?) (error "build program failed" (list build status))) ((? derivation-path? drv) (mbegin %store-monad (return (newline (current-error-port))) ((store-lift add-temp-root) drv) (return (read-derivation-from-file drv)))) ("#f" ;; Unsupported PULL-VERSION. (return #f)) ((? string? str) (raise (condition (&message (message (format #f "You found a bug: the program '~a' failed to compute the derivation for Guix (version: ~s; system: ~s; host version: ~s; pull-version: ~s). Please report the COMPLETE output above by email to <~a>.~%" (derivation->output-path build) version system %guix-version pull-version %guix-bug-report-address)))))))))))) ;; This file is loaded by 'guix pull'; return it the build procedure. build ;; Local Variables: ;; eval: (put 'with-load-path 'scheme-indent-function 1) ;; End: ;;; build-self.scm ends here