code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@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 monad-repl)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (ice-9 pretty-print)
  #:use-module (system repl repl)
  #:use-module (system repl common)
  #:use-module (system repl command)
  #:use-module (system base language)
  #:use-module (system base compile)
  #:use-module (srfi srfi-26)
  #:export (run-in-store
            enter-store-monad))

;;; Comment:
;;;
;;; This modules provides a couple of REPL meta-commands that make it easier
;;; to work with monadic procedures in the store monad.
;;;
;;; Code:

(define* (monad-language monad run #:optional (name 'monad))
  "Return a language with a special evaluator that causes monadic values
 to be \"run\" in MONAD using procedure RUN."
  (let ((scheme (lookup-language 'scheme)))
    (define (evaluate-monadic-expression exp env)
      (let ((mvalue (compile exp #:to 'value #:env env)))
        (run mvalue)))

    (make-language #:name name
                   #:title "Monad"
                   #:reader (language-reader scheme)
                   #:compilers (language-compilers scheme)
                   #:decompilers (language-decompilers scheme)
                   #:evaluator evaluate-monadic-expression
                   #:printer (language-printer scheme)
                   #:make-default-environment
                   (language-make-default-environment scheme))))

(define* (default-guile-derivation store #:optional (system (%current-system)))
  "Return the derivation of the default "
  (package-derivation store (default-guile) system))

(define (store-monad-language store)
  "Return a compiler language for the store monad using STORE."
  (let ((guile (or (%guile-for-build)
                   (default-guile-derivation store))))
    (monad-language %store-monad
                    (cut run-with-store store <>
                         #:guile-for-build guile)
                    'store-monad)))

(define-meta-command ((run-in-store guix) repl (form))
  "run-in-store EXP
Run EXP through the store monad."
  (with-store store
    (let* ((guile (or (%guile-for-build)
                      (default-guile-derivation store)))
           (value (run-with-store store (repl-eval repl form)
                                  #:guile-for-build guile)))
      (run-hook before-print-hook value)
      (pretty-print value))))

(define-meta-command ((enter-store-monad guix) repl)
  "enter-store-monad
Enter a REPL for values in the store monad."
  (with-store store
    (let ((new (make-repl (store-monad-language store))))
      ;; Force interpretation so that our specially-crafted language evaluator
      ;; is actually used.
      (repl-option-set! new 'interp #t)
      (run-repl new))))

;;; monad-repl.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@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 monads)
  #:use-module ((system syntax)
                #:select (syntax-local-binding))
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:export (;; Monads.
            define-monad
            monad?
            monad-bind
            monad-return

            template-directory

            ;; Syntax.
            >>=
            return
            with-monad
            mlet
            mlet*
            mbegin
            mwhen
            munless
            lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
            listm
            foldm
            mapm
            sequence
            anym

            ;; Concrete monads.
            %identity-monad

            %state-monad
            state-return
            state-bind
            current-state
            set-current-state
            state-push
            state-pop
            run-with-state))

;;; Commentary:
;;;
;;; This module implements the general mechanism of monads, and provides in
;;; particular an instance of the "state" monad.  The API was inspired by that
;;; of Racket's "better-monads" module (see
;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
;;; The implementation and use case were influenced by Oleg Kysielov's
;;; "Monadic Programming in Scheme" (see
;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
;;;
;;; Code:

;; Record type for monads manipulated at run time.
(define-record-type <monad>
  (make-monad bind return)
  monad?
  (bind   monad-bind)
  (return monad-return))                         ; TODO: Add 'plus' and 'zero'

(define-syntax define-monad
  (lambda (s)
    "Define the monad under NAME, with the given bind and return methods."
    (define prefix (string->symbol "% "))
    (define (make-rtd-name name)
      (datum->syntax name
                     (symbol-append prefix (syntax->datum name) '-rtd)))

    (syntax-case s (bind return)
      ((_ name (bind b) (return r))
       (with-syntax ((rtd (make-rtd-name #'name)))
         #`(begin
             (define rtd
               ;; The record type, for use at run time.
               (make-monad b r))

             ;; Instantiate all the templates, specialized for this monad.
             (template-directory instantiations name)

             (define-syntax name
               ;; An "inlined record", for use at expansion time.  The goal is
               ;; to allow 'bind' and 'return' to be resolved at expansion
               ;; time, in the common case where the monad is accessed
               ;; directly as NAME.
               (lambda (s)
                 (syntax-case s (%bind %return)
                   ((_ %bind)   #'b)
                   ((_ %return) #'r)
                   (_           #'rtd))))))))))

;; Expansion- and run-time state of the template directory.  This needs to be
;; available at run time (and not just at expansion time) so we can
;; instantiate templates defined in other modules, or use instances defined
;; elsewhere.
(eval-when (load expand eval)
  ;; Mapping of syntax objects denoting the template to a pair containing (1)
  ;; the syntax object of the parameter over which it is templated, and (2)
  ;; the syntax of its body.
  (define-once %templates (make-hash-table))

  (define (register-template! name param body)
    (hash-set! %templates name (cons param body)))

  ;; List of template instances, where each entry is a triplet containing the
  ;; syntax of the name, the actual parameter for which the template is
  ;; specialized, and the syntax object referring to this specialization (the
  ;; procedure's identifier.)
  (define-once %template-instances '())

  (define (register-template-instance! name actual instance)
    (set! %template-instances
      (cons (list name actual instance) %template-instances))))

(define-syntax template-directory
  (lambda (s)
    "This is a \"stateful macro\" to register and lookup templates and
template instances."
    (define location
      (syntax-source s))

    (define current-info-port
      ;; Port for debugging info.
      (const (%make-void-port "w")))

    (define location-string
      (format #f "~a:~a:~a"
              (assq-ref location 'filename)
              (and=> (assq-ref location 'line) 1+)
              (assq-ref location 'column)))

    (define (matching-instance? name actual)
      (match-lambda
        ((name* instance-param proc)
         (and (free-identifier=? name name*)
              (or (equal? actual instance-param)
                  (and (identifier? actual)
                       (identifier? instance-param)
                       (free-identifier=? instance-param
                                          actual)))
              proc))))

    (define (instance-identifier name actual)
      (define stem
        (string-append
         " "
         (symbol->string (syntax->datum name))
         (if (identifier? actual)
             (string-append " " (symbol->string (syntax->datum actual)))
             "")
         " instance"))
      (datum->syntax actual (string->symbol stem)))

    (define (instance-definition name template actual)
      (match template
        ((formal . body)
         (let ((instance (instance-identifier name actual)))
           (format (current-info-port)
                   "~a: info: specializing '~a' for '~a' as '~a'~%"
                   location-string
                   (syntax->datum name) (syntax->datum actual)
                   (syntax->datum instance))

           (register-template-instance! name actual instance)

           #`(begin
               (define #,instance
                 (let-syntax ((#,formal (identifier-syntax #,actual)))
                   #,body))

               ;; Generate code to register the thing at run time.
               (register-template-instance! #'#,name #'#,actual
                                            #'#,instance))))))

    (syntax-case s (register! lookup exists? instantiations)
      ((_ register! name param body)
       ;; Register NAME as a template on PARAM with the given BODY.
       (begin
         (register-template! #'name #'param #'body)

         ;; Generate code to register the template at run time.  XXX: Because
         ;; of this, BODY must not contain ellipses.
         #'(register-template! #'name #'param #'body)))
      ((_ lookup name actual)
       ;; Search for an instance of template NAME for this ACTUAL parameter.
       ;; On success, expand to the identifier of the instance; otherwise
       ;; expand to #f.
       (any (matching-instance? #'name #'actual) %template-instances))
      ((_ exists? name actual)
       ;; Likewise, but return a Boolean.
       (let ((result (->bool
                      (any (matching-instance? #'name #'actual)
                           %template-instances))))
         (unless result
           (format (current-warning-port)
                   "~a: warning: no specialization of template '~a' for '~a'~%"
                   location-string
                   (syntax->datum #'name) (syntax->datum #'actual)))
         result))
      ((_ instantiations actual)
       ;; Expand to the definitions of all the existing templates
       ;; specialized for ACTUAL.
       #`(begin
           #,@(hash-map->list (cut instance-definition <> <> #'actual)
                              %templates))))))

(define-syntax define-template
  (lambda (s)
    "Define a template, which is a procedure that can be specialized over its
first argument.  In our case, the first argument is typically the identifier
of a monad.

Defining templates for procedures like 'mapm' allows us to make have a
specialized version of those procedures for each monad that we define, such
that calls to:

  (mapm %state-monad proc lst)

automatically expand to:

  (#{ mapm %state-monad instance}# proc lst)

Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and
thus it contains inline calls to %state-bind and %state-return.  This avoids
repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the
monad, and allows 'bind' and 'return' to be inlined, which in turn allows for
more optimizations."
    (syntax-case s ()
      ((_ (name arg0 args ...) body ...)
       (with-syntax ((generic-name (datum->syntax
                                    #'name
                                    (symbol-append '#{ %}#
                                                   (syntax->datum #'name)
                                                   '-generic)))
                     (original-name #'name))
         #`(begin
             (template-directory register! name arg0
                                 (lambda (args ...)
                                   body ...))
             (define (generic-name arg0 args ...)
               ;; The generic instance of NAME, for when no specialization was
               ;; found.
               body ...)

             (define-syntax name
               (lambda (s)
                 (syntax-case s ()
                   ((_ arg0* args ...)
                    ;; Expand to either the specialized instance or the
                    ;; generic instance of template ORIGINAL-NAME.
                    #'(if (template-directory exists? original-name arg0*)
                          ((template-directory lookup original-name arg0*)
                           args ...)
                          (generic-name arg0* args ...)))
                   (_
                    #'generic-name))))))))))

(define-syntax-parameter >>=
  ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
  (lambda (s)
    (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))

(define-syntax-parameter return
  (lambda (s)
    (syntax-violation 'return "return used outside of 'with-monad'" s)))

(define-syntax-rule (bind-syntax bind)
  "Return a macro transformer that handles the expansion of '>>=' expressions
using BIND as the binary bind operator.

This macro exists to allow the expansion of n-ary '>>=' expressions, even
though BIND is simply binary, as in:

  (with-monad %state-monad
    (>>= (return 1)
         (lift 1+ %state-monad)
         (lift 1+ %state-monad)))
"
  (lambda (stx)
    (define (expand body)
      (syntax-case body ()
        ((_ mval mproc)
         #'(bind mval mproc))
        ((x mval mproc0 mprocs (... ...))
         (expand #'(>>= (>>= mval mproc0)
                        mprocs (... ...))))))

    (expand stx)))

(define-syntax with-monad
  (lambda (s)
    "Evaluate BODY in the context of MONAD, and return its result."
    (syntax-case s ()
      ((_ monad body ...)
       (eq? 'macro (syntax-local-binding #'monad))
       ;; MONAD is a syntax transformer, so we can obtain the bind and return
       ;; methods by directly querying it.
       #'(syntax-parameterize ((>>=    (bind-syntax (monad %bind)))
                               (return (identifier-syntax (monad %return))))
           body ...))
      ((_ monad body ...)
       ;; MONAD refers to the <monad> record that represents the monad at run
       ;; time, so use the slow method.
       #'(syntax-parameterize ((>>=    (bind-syntax
                                        (monad-bind monad)))
                               (return (identifier-syntax
                                        (monad-return monad))))
           body ...)))))

(define-syntax mlet*
  (syntax-rules (->)
    "Bind the given monadic values MVAL to the given variables VAR.  When the
form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
'let'."
    ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
    ((_ monad () body ...)
     (with-monad monad body ...))
    ((_ monad ((var mval) rest ...) body ...)
     (with-monad monad
       (>>= mval
            (lambda (var)
              (mlet* monad (rest ...)
                body ...)))))
    ((_ monad ((var -> val) rest ...) body ...)
     (let ((var val))
       (mlet* monad (rest ...)
         body ...)))))

(define-syntax mlet
  (lambda (s)
    (syntax-case s ()
      ((_ monad ((var mval ...) ...) body ...)
       (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
         #'(mlet* monad ((temp mval ...) ...)
             (let ((var temp) ...)
               body ...)))))))

(define-syntax mbegin
  (syntax-rules (%current-monad)
    "Bind MEXP and the following monadic expressions in sequence, returning
the result of the last expression.  Every expression in the sequence must be a
monadic expression."
    ((_ %current-monad mexp)
     mexp)
    ((_ %current-monad mexp rest ...)
     (>>= mexp
          (lambda (unused-value)
            (mbegin %current-monad rest ...))))
    ((_ monad mexp)
     (with-monad monad
       mexp))
    ((_ monad mexp rest ...)
     (with-monad monad
       (>>= mexp
            (lambda (unused-value)
              (mbegin monad rest ...)))))))

(define-syntax mwhen
  (syntax-rules ()
    "When CONDITION is true, evaluate the sequence of monadic expressions
MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is false, return *unspecified*
in the current monad.  Every expression in the sequence must be a monadic
expression."
    ((_ condition mexp0 mexp* ...)
     (if condition
         (mbegin %current-monad
           mexp0 mexp* ...)
         (return *unspecified*)))))

(define-syntax munless
  (syntax-rules ()
    "When CONDITION is false, evaluate the sequence of monadic expressions
MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is true, return *unspecified*
in the current monad.  Every expression in the sequence must be a monadic
expression."
    ((_ condition mexp0 mexp* ...)
     (if condition
         (return *unspecified*)
         (mbegin %current-monad
           mexp0 mexp* ...)))))

(define-syntax define-lift
  (syntax-rules ()
    ((_ liftn (args ...))
     (define-syntax liftn
       (lambda (s)
         "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
         (syntax-case s ()
           ((liftn proc monad)
            ;; Inline the result of lifting PROC, such that 'return' can in
            ;; turn be open-coded.
            #'(lambda (args ...)
                (with-monad monad
                  (return (proc args ...)))))
           (id
            (identifier? #'id)
            ;; Slow path: Return a closure-returning procedure (we don't
            ;; guarantee (eq? LIFTN LIFTN), but that's fine.)
            #'(lambda (proc monad)
                (lambda (args ...)
                  (with-monad monad
                    (return (proc args ...))))))))))))

(define-lift lift0 ())
(define-lift lift1 (a))
(define-lift lift2 (a b))
(define-lift lift3 (a b c))
(define-lift lift4 (a b c d))
(define-lift lift5 (a b c d e))
(define-lift lift6 (a b c d e f))
(define-lift lift7 (a b c d e f g))

(define (lift proc monad)
  "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
MONAD---i.e., return a monadic function in MONAD."
  (lambda args
    (with-monad monad
      (return (apply proc args)))))

(define-template (foldm monad mproc init lst)
  "Fold MPROC over LST and return a monadic value seeded by INIT.

  (foldm %state-monad (lift2 cons %state-monad) '() '(a b c))
  => '(c b a)  ;monadic
"
  (with-monad monad
    (let loop ((lst    lst)
               (result init))
      (match lst
        (()
         (return result))
        ((head . tail)
         (>>= (mproc head result)
              (lambda (result)
                (loop tail result))))))))

(define-template (mapm monad mproc lst)
  "Map MPROC over LST and return a monadic list.

  (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2))
  => (1 2 3)  ;monadic
"
  ;; XXX: We don't use 'foldm' because template specialization wouldn't work
  ;; in this context.
  (with-monad monad
    (let mapm ((lst    lst)
               (result '()))
      (match lst
        (()
         (return (reverse result)))
        ((head . tail)
         (>>= (mproc head)
              (lambda (head)
                (mapm tail (cons head result)))))))))

(define-template (sequence monad lst)
  "Turn the list of monadic values LST into a monadic list of values, by
evaluating each item of LST in sequence."
  (with-monad monad
    (let seq ((lstx   lst)
              (result '()))
      (match lstx
        (()
         (return (reverse result)))
        ((head . tail)
         (>>= head
              (lambda (item)
                (seq tail (cons item result)))))))))

(define-template (anym monad mproc lst)
  "Apply MPROC to the list of values LST; return as a monadic value the first
value for which MPROC returns a true monadic value or #f.  For example:

  (anym %state-monad (lift1 odd? %state-monad) '(0 1 2))
  => #t   ;monadic
"
  (with-monad monad
    (let loop ((lst lst))
      (match lst
        (()
         (return #f))
        ((head . tail)
         (>>= (mproc head)
              (lambda (result)
                (if result
                    (return result)
                    (loop tail)))))))))

(define-syntax listm
  (lambda (s)
    "Return a monadic list in MONAD from the monadic values MVAL."
    (syntax-case s ()
      ((_ monad mval ...)
       (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
         #'(mlet monad ((val mval) ...)
             (return (list val ...))))))))

;;;
;;; Identity monad.
;;;

(define-inlinable (identity-return value)
  value)

(define-inlinable (identity-bind mvalue mproc)
  (mproc mvalue))

(define-monad %identity-monad
  (bind   identity-bind)
  (return identity-return))

;;;
;;; State monad.
;;;

(define-inlinable (state-return value)
  (lambda (state)
    (values value state)))

(define-inlinable (state-bind mvalue mproc)
  "Bind MVALUE, a value in the state monad, and pass it to MPROC."
  (lambda (state)
    (call-with-values
        (lambda ()
          (mvalue state))
      (lambda (value state)
        ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
        ;; of (mproc value) prevents a bit of unfolding/inlining.
        ((mproc value) state)))))

(define-monad %state-monad
  (bind state-bind)
  (return state-return))

(define* (run-with-state mval #:optional (state '()))
  "Run monadic value MVAL starting with STATE as the initial state.  Return
two values: the resulting value, and the resulting state."
  (mval state))

(define-inlinable (current-state)
  "Return the current state as a monadic value."
  (lambda (state)
    (values state state)))

(define-inlinable (set-current-state value)
  "Set the current state to VALUE and return the previous state as a monadic
value."
  (lambda (state)
    (values state value)))

(define (state-pop)
  "Pop a value from the current state and return it as a monadic value.  The
state is assumed to be a list."
  (lambda (state)
    (match state
      ((head . tail)
       (values head tail)))))

(define (state-push value)
  "Push VALUE to the current state, which is assumed to be a list, and return
the previous state as a monadic value."
  (lambda (state)
    (values state (cons value state))))

;;; monads.scm end here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.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 nar)
  #:use-module (guix serialization)
  #:use-module (guix build syscalls)
  #:use-module ((guix build utils)
                #:select (delete-file-recursively with-directory-excursion))
  #:use-module (guix store)
  #:use-module (guix store database)
  #:use-module (guix ui)                          ; for '_'
  #:use-module (gcrypt hash)
  #:use-module (guix pki)
  #:use-module (gcrypt pk-crypto)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (nar-invalid-hash-error?
            nar-invalid-hash-error-expected
            nar-invalid-hash-error-actual

            nar-signature-error?
            nar-signature-error-signature

            restore-file-set))

;;; Comment:
;;;
;;; Read and write Nix archives, aka. ‘nar’.
;;;
;;; Code:

(define-condition-type &nar-signature-error &nar-error
  nar-signature-error?
  (signature nar-signature-error-signature))      ; faulty signature or #f

(define-condition-type &nar-invalid-hash-error &nar-signature-error
  nar-invalid-hash-error?
  (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
  (actual    nar-invalid-hash-error-actual))      ; actual hash

;;;
;;; Restoring a file set into the store.
;;;

;; The code below accesses the store directly and is meant to be run from
;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
;; (1) the locks on the files to be restored as already held, and (2) the
;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
;;
;; So we're really duplicating that functionality of the daemon (well, until
;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
;; RPCs for functionality not available otherwise, like 'valid-path?'.

(define (lock-store-file file)
  "Acquire exclusive access to FILE, a store file."
  (call-with-output-file (string-append file ".lock")
    (cut fcntl-flock <> 'write-lock)))

(define (unlock-store-file file)
  "Release access to FILE."
  (call-with-input-file (string-append file ".lock")
    (cut fcntl-flock <> 'unlock)))

(define* (finalize-store-file source target
                              #:key (references '()) deriver (lock? #t))
  "Rename SOURCE to TARGET and register TARGET as a valid store item, with
REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
before attempting to register it; otherwise, assume TARGET's locks are already
held."

  ;; XXX: Currently we have to call out to the daemon to check whether TARGET
  ;; is valid.
  (with-store store
    (unless (valid-path? store target)
      (when lock?
        (lock-store-file target))

      (unless (valid-path? store target)
        ;; If FILE already exists, delete it (it's invalid anyway.)
        (when (file-exists? target)
          (delete-file-recursively target))

        ;; Install the new TARGET.
        (rename-file source target)

        ;; Register TARGET.  As a side effect, it resets the timestamps of all
        ;; its files, recursively, and runs a deduplication pass.
        (register-path target
                       #:references references
                       #:deriver deriver))

      (when lock?
        (unlock-store-file target)))))

(define (temporary-store-file)
  "Return the file name of a temporary file created in the store."
  (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
         (port     (mkstemp! template)))
    (close-port port)
    template))

(define-syntax-rule (with-temporary-store-file name body ...)
  "Evaluate BODY with NAME bound to the file name of a temporary store item
protected from GC."
  (let loop ((name (temporary-store-file)))
    (with-store store
      ;; Add NAME to the current process' roots.  (Opening this connection to
      ;; the daemon allows us to reuse its code that deals with the
      ;; per-process roots file.)
      (add-temp-root store name)

      ;; There's a window during which GC could delete NAME.  Try again when
      ;; that happens.
      (if (file-exists? name)
          (begin
            (delete-file name)
            body ...)
          (loop (temporary-store-file))))))

(define* (restore-one-item port
                           #:key acl (verify-signature? #t) (lock? #t)
                           (log-port (current-error-port)))
  "Restore one store item from PORT; return its file name on success."

  (define (assert-valid-signature signature hash file)
    ;; Bail out if SIGNATURE, which must be a string as produced by
    ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
    ;; the expected hash for FILE.
    (let ((signature (catch 'gcry-error
                       (lambda ()
                         (string->canonical-sexp signature))
                       (lambda (key proc err)
                         (raise (condition
                                 (&message
                                  (message "signature is not a valid \
s-expression"))
                                 (&nar-signature-error
                                  (file file)
                                  (signature signature) (port port))))))))
      (signature-case (signature hash (current-acl))
        (valid-signature #t)
        (invalid-signature
         (raise (condition
                 (&message (message "invalid signature"))
                 (&nar-signature-error
                  (file file) (signature signature) (port port)))))
        (hash-mismatch
         (raise (condition (&message (message "invalid hash"))
                           (&nar-invalid-hash-error
                            (port port) (file file)
                            (signature signature)
                            (expected (hash-data->bytevector
                                       (signature-signed-data signature)))
                            (actual hash)))))
        (unauthorized-key
         (raise (condition (&message (message "unauthorized public key"))
                           (&nar-signature-error
                            (signature signature) (file file) (port port)))))
        (corrupt-signature
         (raise (condition
                 (&message (message "corrupt signature data"))
                 (&nar-signature-error
                  (signature signature) (file file) (port port))))))))

  (define %export-magic
    ;; Number used to identify genuine file set archives.
    #x4558494e)

  (define port*
    ;; Keep that one around, for error conditions.
    port)

  (let-values (((port get-hash)
                (open-sha256-input-port port)))
    (with-temporary-store-file temp
      (restore-file port temp)

      (let ((magic (read-int port)))
        (unless (= magic %export-magic)
          (raise (condition
                  (&message (message "corrupt file set archive"))
                  (&nar-read-error
                   (port port*) (file #f) (token #f))))))

      (let ((file     (read-store-path port))
            (refs     (read-store-path-list port))
            (deriver  (read-string port))
            (hash     (get-hash))
            (has-sig? (= 1 (read-int port))))
        (format log-port
                (G_ "importing file or directory '~a'...~%")
                file)

        ;; The signature may contain characters that are meant to be
        ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
        (let ((sig (and has-sig? (read-latin1-string port))))
          (when verify-signature?
            (if sig
                (begin
                  (assert-valid-signature sig hash file)
                  (format log-port
                          (G_ "found valid signature for '~a'~%")
                          file)
                  (finalize-store-file temp file
                                       #:references refs
                                       #:deriver deriver
                                       #:lock? lock?))
                (raise (condition
                        (&message (message "imported file lacks \
a signature"))
                        (&nar-signature-error
                         (port port*) (file file) (signature #f))))))
          file)))))

(define* (restore-file-set port
                           #:key (verify-signature? #t) (lock? #t)
                           (log-port (current-error-port)))
  "Restore the file set read from PORT to the store.  The format of the data
on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
archives with interspersed meta-data joining them together, possibly with a
digital signature at the end.  Log progress to LOG-PORT.  Return the list of
files restored.

When LOCK? is #f, assume locks for the files to be restored are already held.
This is the case when the daemon calls a build hook.

Note that this procedure accesses the store directly, so it's only meant to be
used by the daemon's build hooks since they cannot call back to the daemon
while the locks are held."
  (define acl
    (current-acl))

  (let loop ((n     (read-long-long port))
             (files '()))
    (case n
      ((0)
       (reverse files))
      ((1)
       (let ((file
              (restore-one-item port
                                #:acl acl #:verify-signature? verify-signature?
                                #:lock? lock? #:log-port log-port)))
         (loop (read-long-long port)
               (cons file files))))
      (else
       ;; Neither 0 nor 1.
       (raise (condition
               (&message (message "invalid inter-file archive mark"))
               (&nar-read-error
                (port port) (file #f) (token #f))))))))

;;; Local Variables:
;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
;;; End:

;;; nar.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 packages)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix base32)
  #:use-module (guix grafts)
  #:use-module (guix derivations)
  #:use-module (guix memoization)
  #:use-module (guix build-system)
  #:use-module (guix search-paths)
  #:use-module (guix sets)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (web uri)
  #:re-export (%current-system
               %current-target-system
               search-path-specification)         ;for convenience
  #:export (origin
            origin?
            origin-uri
            origin-method
            origin-sha256
            origin-file-name
            origin-actual-file-name
            origin-patches
            origin-patch-flags
            origin-patch-inputs
            origin-patch-guile
            origin-snippet
            origin-modules
            base32

            package
            package?
            package-name
            package-upstream-name
            package-version
            package-full-name
            package-source
            package-build-system
            package-arguments
            package-inputs
            package-native-inputs
            package-propagated-inputs
            package-outputs
            package-native-search-paths
            package-search-paths
            package-replacement
            package-synopsis
            package-description
            package-license
            package-home-page
            package-supported-systems
            package-maintainers
            package-properties
            package-location
            hidden-package
            hidden-package?
            package-superseded
            deprecated-package
            package-field-location

            package-direct-sources
            package-transitive-sources
            package-direct-inputs
            package-transitive-inputs
            package-transitive-target-inputs
            package-transitive-native-inputs
            package-transitive-propagated-inputs
            package-transitive-native-search-paths
            package-transitive-supported-systems
            package-mapping
            package-input-rewriting
            package-source-derivation
            package-derivation
            package-cross-derivation
            package-output
            package-grafts
            package-patched-vulnerabilities
            package/inherit

            transitive-input-references

            %supported-systems
            %hurd-systems
            %hydra-supported-systems
            supported-package?

            &package-error
            package-error?
            package-error-package
            &package-input-error
            package-input-error?
            package-error-invalid-input
            &package-cross-build-system-error
            package-cross-build-system-error?

            package->bag
            bag->derivation
            bag-direct-inputs
            bag-transitive-inputs
            bag-transitive-host-inputs
            bag-transitive-build-inputs
            bag-transitive-target-inputs

            default-guile
            default-guile-derivation
            set-guile-for-build
            package-file
            package->derivation
            package->cross-derivation
            origin->derivation))

;;; Commentary:
;;;
;;; This module provides a high-level mechanism to define packages in a
;;; Guix-based distribution.
;;;
;;; Code:

;; The source of a package, such as a tarball URL and fetcher---called
;; "origin" to avoid name clash with `package-source', `source', etc.
(define-record-type* <origin>
  origin make-origin
  origin?
  (uri       origin-uri)                          ; string
  (method    origin-method)                       ; procedure
  (sha256    origin-sha256)                       ; bytevector
  (file-name origin-file-name (default #f))       ; optional file name

  ;; Patches are delayed so that the 'search-patch' calls are made lazily,
  ;; which reduces I/O on startup and allows patch-not-found errors to be
  ;; gracefully handled at run time.
  (patches   origin-patches                       ; list of file names
             (default '()) (delayed))

  (snippet   origin-snippet (default #f))         ; sexp or #f
  (patch-flags  origin-patch-flags                ; list of strings
                (default '("-p1")))

  ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
  ;; used to specify these dependencies when needed.
  (patch-inputs origin-patch-inputs               ; input list or #f
                (default #f))
  (modules      origin-modules                    ; list of module names
                (default '()))

  (patch-guile origin-patch-guile                 ; package or #f
               (default #f)))

(define (print-origin origin port)
  "Write a concise representation of ORIGIN to PORT."
  (match origin
    (($ <origin> uri method sha256 file-name patches)
     (simple-format port "#<origin ~s ~a ~s ~a>"
                    uri (bytevector->base32-string sha256)
                    (force patches)
                    (number->string (object-address origin) 16)))))

(set-record-type-printer! <origin> print-origin)

(define-syntax base32
  (lambda (s)
    "Return the bytevector corresponding to the given Nix-base32
representation."
    (syntax-case s ()
      ((_ str)
       (string? (syntax->datum #'str))
       ;; A literal string: do the conversion at expansion time.
       (with-syntax ((bv (nix-base32-string->bytevector
                          (syntax->datum #'str))))
         #''bv))
      ((_ str)
       #'(nix-base32-string->bytevector str)))))

(define (origin-actual-file-name origin)
  "Return the file name of ORIGIN, either its 'file-name' field or the file
name of its URI."
  (define (uri->file-name uri)
    ;; Return the 'base name' of URI or URI itself, where URI is a string.
    (let ((path (and=> (string->uri uri) uri-path)))
      (if path
          (basename path)
          uri)))

  (or (origin-file-name origin)
      (match (origin-uri origin)
        ((head . tail)
         (uri->file-name head))
        ((? string? uri)
         (uri->file-name uri))
        (else
         ;; git, svn, cvs, etc. reference
         #f))))

(define %supported-systems
  ;; This is the list of system types that are supported.  By default, we
  ;; expect all packages to build successfully here.
  '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))

(define %hurd-systems
  ;; The GNU/Hurd systems for which support is being developed.
  '("i585-gnu" "i686-gnu"))

(define %hydra-supported-systems
  ;; This is the list of system types for which build machines are available.
  ;;
  ;; XXX: MIPS is temporarily unavailable on Hydra:
  ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
  (fold delete %supported-systems '("aarch64-linux" "mips64el-linux")))

;; A package.
(define-record-type* <package>
  package make-package
  package?
  (name   package-name)                   ; string
  (version package-version)               ; string
  (source package-source)                 ; <origin> instance
  (build-system package-build-system)     ; build system
  (arguments package-arguments            ; arguments for the build method
             (default '()) (thunked))

  (inputs package-inputs                  ; input packages or derivations
          (default '()) (thunked))
  (propagated-inputs package-propagated-inputs    ; same, but propagated
                     (default '()) (thunked))
  (native-inputs package-native-inputs    ; native input packages/derivations
                 (default '()) (thunked))
  (self-native-input? package-self-native-input?  ; whether to use itself as
                                                  ; a native input when cross-
                      (default #f))               ; compiling

  (outputs package-outputs                ; list of strings
           (default '("out")))

                                                  ; lists of
                                                  ; <search-path-specification>,
                                                  ; for native and cross
                                                  ; inputs
  (native-search-paths package-native-search-paths (default '()))
  (search-paths package-search-paths (default '()))

  ;; The 'replacement' field is marked as "innate" because it never makes
  ;; sense to inherit a replacement as is.  See the 'package/inherit' macro.
  (replacement package-replacement                ; package | #f
               (default #f) (thunked) (innate))

  (synopsis package-synopsis)                    ; one-line description
  (description package-description)              ; one or two paragraphs
  (license package-license)
  (home-page package-home-page)
  (supported-systems package-supported-systems    ; list of strings
                     (default %supported-systems))
  (maintainers package-maintainers (default '()))

  (properties package-properties (default '()))   ; alist for anything else

  (location package-location
            (default (and=> (current-source-location)
                            source-properties->location))
            (innate)))

(set-record-type-printer! <package>
                          (lambda (package port)
                            (let ((loc    (package-location package))
                                  (format simple-format))
                              (format port "#<package ~a@~a ~a~a>"
                                      (package-name package)
                                      (package-version package)
                                      (if loc
                                          (format #f "~a:~a "
                                                  (location-file loc)
                                                  (location-line loc))
                                          "")
                                      (number->string (object-address
                                                       package)
                                                      16)))))

(define (package-upstream-name package)
  "Return the upstream name of PACKAGE, which could be different from the name
it has in Guix."
  (or (assq-ref (package-properties package) 'upstream-name)
      (package-name package)))

(define (hidden-package p)
  "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
user interfaces, ignores."
  (package
    (inherit p)
    (properties `((hidden? . #t)
                  ,@(package-properties p)))))

(define (hidden-package? p)
  "Return true if P is \"hidden\"--i.e., must not be visible to user
interfaces."
  (assoc-ref (package-properties p) 'hidden?))

(define (package-superseded p)
  "Return the package the supersedes P, or #f if P is still current."
  (assoc-ref (package-properties p) 'superseded))

(define (deprecated-package old-name p)
  "Return a package called OLD-NAME and marked as superseded by P, a package
object."
  (package
    (inherit p)
    (name old-name)
    (properties `((superseded . ,p)))))

(define (package-field-location package field)
  "Return the source code location of the definition of FIELD for PACKAGE, or
#f if it could not be determined."
  (define (goto port line column)
    (unless (and (= (port-column port) (- column 1))
                 (= (port-line port) (- line 1)))
      (unless (eof-object? (read-char port))
        (goto port line column))))

  (match (package-location package)
    (($ <location> file line column)
     (catch 'system
       (lambda ()
         ;; In general we want to keep relative file names for modules.
         (with-fluids ((%file-port-name-canonicalization 'relative))
           (call-with-input-file (search-path %load-path file)
             (lambda (port)
               (goto port line column)
               (match (read port)
                 (('package inits ...)
                  (let ((field (assoc field inits)))
                    (match field
                      ((_ value)
                       ;; Put the `or' here, and not in the first argument of
                       ;; `and=>', to work around a compiler bug in 2.0.5.
                       (or (and=> (source-properties value)
                                  source-properties->location)
                           (and=> (source-properties field)
                                  source-properties->location)))
                      (_
                       #f))))
                 (_
                  #f))))))
       (lambda _
         #f)))
    (_ #f)))

;; Error conditions.

(define-condition-type &package-error &error
  package-error?
  (package package-error-package))

(define-condition-type &package-input-error &package-error
  package-input-error?
  (input package-error-invalid-input))

(define-condition-type &package-cross-build-system-error &package-error
  package-cross-build-system-error?)

(define* (package-full-name package #:optional (delimiter "@"))
  "Return the full name of PACKAGE--i.e., `NAME@VERSION'.  By specifying
DELIMITER (a string), you can customize what will appear between the name and
the version.  By default, DELIMITER is \"@\"."
  (string-append (package-name package) delimiter (package-version package)))

(define (patch-file-name patch)
  "Return the basename of PATCH's file name, or #f if the file name could not
be determined."
  (match patch
    ((? string?)
     (basename patch))
    ((? origin?)
     (and=> (origin-actual-file-name patch) basename))))

(define %vulnerability-regexp
  ;; Regexp matching a CVE identifier in patch file names.
  (make-regexp "CVE-[0-9]{4}-[0-9]+"))

(define (package-patched-vulnerabilities package)
  "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
identifiers.  The result is inferred from the file names of patches."
  (define (patch-vulnerabilities patch)
    (map (cut match:substring <> 0)
         (list-matches %vulnerability-regexp patch)))

  (let ((patches (filter-map patch-file-name
                             (or (and=> (package-source package)
                                        origin-patches)
                                 '()))))
    (append-map patch-vulnerabilities patches)))

(define (%standard-patch-inputs)
  (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
                                'canonical-package))
         (ref       (lambda (module var)
                      (canonical
                       (module-ref (resolve-interface module) var)))))
    `(("tar"   ,(ref '(gnu packages base) 'tar))
      ("xz"    ,(ref '(gnu packages compression) 'xz))
      ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
      ("gzip"  ,(ref '(gnu packages compression) 'gzip))
      ("lzip"  ,(ref '(gnu packages compression) 'lzip))
      ("unzip" ,(ref '(gnu packages compression) 'unzip))
      ("patch" ,(ref '(gnu packages base) 'patch))
      ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))

(define (default-guile)
  "Return the default Guile package used to run the build code of
derivations."
  (let ((distro (resolve-interface '(gnu packages commencement))))
    (module-ref distro 'guile-final)))

(define (guile-2.0)
  "Return Guile 2.0."
  ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
  ;; grafting packages.
  (let ((distro (resolve-interface '(gnu packages guile))))
    (module-ref distro 'guile-2.0)))

(define* (default-guile-derivation #:optional (system (%current-system)))
  "Return the derivation for SYSTEM of the default Guile package used to run
the build code of derivation."
  (package->derivation (default-guile) system
                       #:graft? #f))

(define* (patch-and-repack source patches
                           #:key
                           inputs
                           (snippet #f)
                           (flags '("-p1"))
                           (modules '())
                           (guile-for-build (%guile-for-build))
                           (system (%current-system)))
  "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
it must be an s-expression that will run from within the directory where
SOURCE was unpacked, after all of PATCHES have been applied.  MODULES
specifies modules in scope when evaluating SNIPPET."
  (define source-file-name
    ;; SOURCE is usually a derivation, but it could be a store file.
    (if (derivation? source)
        (derivation->output-path source)
        source))

  (define lookup-input
    ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
    ;; so deal with that.
    (let ((inputs (or inputs (%standard-patch-inputs))))
      (lambda (name)
        (match (assoc-ref inputs name)
          ((package) package)
          (#f        #f)))))

  (define decompression-type
    (cond ((string-suffix? "gz" source-file-name)  "gzip")
          ((string-suffix? "Z" source-file-name)  "gzip")
          ((string-suffix? "bz2" source-file-name) "bzip2")
          ((string-suffix? "lz" source-file-name)  "lzip")
          ((string-suffix? "zip" source-file-name) "unzip")
          (else "xz")))

  (define original-file-name
    ;; Remove the store prefix plus the slash, hash, and hyphen.
    (let* ((sans (string-drop source-file-name
                              (+ (string-length (%store-prefix)) 1)))
           (dash (string-index sans #\-)))
      (string-drop sans (+ 1 dash))))

  (define (numeric-extension? file-name)
    ;; Return true if FILE-NAME ends with digits.
    (and=> (file-extension file-name)
           (cut string-every char-set:hex-digit <>)))

  (define (tarxz-name file-name)
    ;; Return a '.tar.xz' file name based on FILE-NAME.
    (let ((base (if (numeric-extension? file-name)
                    original-file-name
                    (file-sans-extension file-name))))
      (string-append base
                     (if (equal? (file-extension base) "tar")
                         ".xz"
                         ".tar.xz"))))

  (define instantiate-patch
    (match-lambda
      ((? string? patch)                          ;deprecated
       (interned-file patch #:recursive? #t))
      ((? struct? patch)                          ;origin, local-file, etc.
       (lower-object patch system))))

  (mlet %store-monad ((tar ->     (lookup-input "tar"))
                      (xz ->      (lookup-input "xz"))
                      (patch ->   (lookup-input "patch"))
                      (locales -> (lookup-input "locales"))
                      (decomp ->  (lookup-input decompression-type))
                      (patches    (sequence %store-monad
                                            (map instantiate-patch patches))))
    (define build
      (with-imported-modules '((guix build utils))
        #~(begin
            (use-modules (ice-9 ftw)
                         (srfi srfi-1)
                         (guix build utils))

            ;; The --sort option was added to GNU tar in version 1.28, released
            ;; 2014-07-28.  During bootstrap we must cope with older versions.
            (define tar-supports-sort?
              (zero? (system* (string-append #+tar "/bin/tar")
                              "cf" "/dev/null" "--files-from=/dev/null"
                              "--sort=name")))

            (define (apply-patch patch)
              (format (current-error-port) "applying '~a'...~%" patch)

              ;; Use '--force' so that patches that do not apply perfectly are
              ;; rejected.  Use '--no-backup-if-mismatch' to prevent making
              ;; "*.orig" file if a patch is applied with offset.
              (invoke (string-append #+patch "/bin/patch")
                      "--force" "--no-backup-if-mismatch"
                      #+@flags "--input" patch))

            (define (first-file directory)
              ;; Return the name of the first file in DIRECTORY.
              (car (scandir directory
                            (lambda (name)
                              (not (member name '("." "..")))))))

            ;; Encoding/decoding errors shouldn't be silent.
            (fluid-set! %default-port-conversion-strategy 'error)

            (when #+locales
              ;; First of all, install a UTF-8 locale so that UTF-8 file names
              ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
              (setenv "LOCPATH"
                      (string-append #+locales "/lib/locale/"
                                     #+(and locales
                                            (version-major+minor
                                             (package-version locales)))))
              (setlocale LC_ALL "en_US.utf8"))

            (setenv "PATH" (string-append #+xz "/bin" ":"
                                          #+decomp "/bin"))

            ;; SOURCE may be either a directory or a tarball.
            (if (file-is-directory? #+source)
                (let* ((store     (%store-directory))
                       (len       (+ 1 (string-length store)))
                       (base      (string-drop #+source len))
                       (dash      (string-index base #\-))
                       (directory (string-drop base (+ 1 dash))))
                  (mkdir directory)
                  (copy-recursively #+source directory))
                #+(if (string=? decompression-type "unzip")
                      #~(invoke "unzip" #+source)
                      #~(invoke (string-append #+tar "/bin/tar")
                                "xvf" #+source)))

            (let ((directory (first-file ".")))
              (format (current-error-port)
                      "source is under '~a'~%" directory)
              (chdir directory)

              (for-each apply-patch '#+patches)

              (let ((result #+(if snippet
                                  #~(let ((module (make-fresh-user-module)))
                                      (module-use-interfaces!
                                       module
                                       (map resolve-interface '#+modules))
                                      ((@ (system base compile) compile)
                                       '#+snippet
                                       #:to 'value
                                       #:opts %auto-compilation-options
                                       #:env module))
                                  #~#t)))
                ;; Issue a warning unless the result is #t.
                (unless (eqv? result #t)
                  (format (current-error-port) "\
## WARNING: the snippet returned `~s'.  Return values other than #t
## are deprecated.  Please migrate this package so that its snippet
## reports errors by raising an exception, and otherwise returns #t.~%"
                          result))
                (unless result
                  (error "snippet returned false")))

              (chdir "..")

              (unless tar-supports-sort?
                (call-with-output-file ".file_list"
                  (lambda (port)
                    (for-each (lambda (name)
                                (format port "~a~%" name))
                              (find-files directory
                                          #:directories? #t
                                          #:fail-on-error? #t)))))
              (apply invoke
                     (string-append #+tar "/bin/tar")
                     "cvf" #$output
                     ;; The bootstrap xz does not support
                     ;; threaded compression (introduced in
                     ;; 5.2.0), but it ignores the extra flag.
                     (string-append "--use-compress-program="
                                    #+xz "/bin/xz --threads=0")
                     ;; avoid non-determinism in the archive
                     "--mtime=@0"
                     "--owner=root:0"
                     "--group=root:0"
                     (if tar-supports-sort?
                         `("--sort=name"
                           ,directory)
                         '("--no-recursion"
                           "--files-from=.file_list")))))))

    (let ((name (tarxz-name original-file-name)))
      (gexp->derivation name build
                        ;; TODO: Remove this on the next rebuild cycle.
                        #:import-creates-derivation? #t

                        #:graft? #f
                        #:system system
                        #:deprecation-warnings #t ;to avoid a rebuild
                        #:guile-for-build guile-for-build))))

(define (transitive-inputs inputs)
  "Return the closure of INPUTS when considering the 'propagated-inputs'
edges.  Omit duplicate inputs, except for those already present in INPUTS
itself.

This is implemented as a breadth-first traversal such that INPUTS is
preserved, and only duplicate propagated inputs are removed."
  (define (seen? seen item outputs)
    ;; FIXME: We're using pointer identity here, which is extremely sensitive
    ;; to memoization in package-producing procedures; see
    ;; <https://bugs.gnu.org/30155>.
    (match (vhash-assq item seen)
      ((_ . o) (equal? o outputs))
      (_       #f)))

  (let loop ((inputs     inputs)
             (result     '())
             (propagated '())
             (first?     #t)
             (seen       vlist-null))
    (match inputs
      (()
       (if (null? propagated)
           (reverse result)
           (loop (reverse (concatenate propagated)) result '() #f seen)))
      (((and input (label (? package? package) outputs ...)) rest ...)
       (if (and (not first?) (seen? seen package outputs))
           (loop rest result propagated first? seen)
           (loop rest
                 (cons input result)
                 (cons (package-propagated-inputs package) propagated)
                 first?
                 (vhash-consq package outputs seen))))
      ((input rest ...)
       (loop rest (cons input result) propagated first? seen)))))

(define (package-direct-sources package)
  "Return all source origins associated with PACKAGE; including origins in
PACKAGE's inputs."
  `(,@(or (and=> (package-source package) list) '())
    ,@(filter-map (match-lambda
                   ((_ (? origin? orig) _ ...)
                    orig)
                   (_ #f))
                  (package-direct-inputs package))))

(define (package-transitive-sources package)
  "Return PACKAGE's direct sources, and their direct sources, recursively."
  (delete-duplicates
   (concatenate (filter-map (match-lambda
                             ((_ (? origin? orig) _ ...)
                              (list orig))
                             ((_ (? package? p) _ ...)
                              (package-direct-sources p))
                             (_ #f))
                            (bag-transitive-inputs
                             (package->bag package))))))

(define (package-direct-inputs package)
  "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
with their propagated inputs."
  (append (package-native-inputs package)
          (package-inputs package)
          (package-propagated-inputs package)))

(define (package-transitive-inputs package)
  "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
with their propagated inputs, recursively."
  (transitive-inputs (package-direct-inputs package)))

(define (package-transitive-target-inputs package)
  "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
along with their propagated inputs, recursively.  This only includes inputs
for the target system, and not native inputs."
  (transitive-inputs (append (package-inputs package)
                             (package-propagated-inputs package))))

(define (package-transitive-native-inputs package)
  "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
along with their propagated inputs, recursively.  This only includes inputs
for the host system (\"native inputs\"), and not target inputs."
  (transitive-inputs (package-native-inputs package)))

(define (package-transitive-propagated-inputs package)
  "Return the propagated inputs of PACKAGE, and their propagated inputs,
recursively."
  (transitive-inputs (package-propagated-inputs package)))

(define (package-transitive-native-search-paths package)
  "Return the list of search paths for PACKAGE and its propagated inputs,
recursively."
  (append (package-native-search-paths package)
          (append-map (match-lambda
                        ((label (? package? p) _ ...)
                         (package-native-search-paths p))
                        (_
                         '()))
                      (package-transitive-propagated-inputs package))))

(define (transitive-input-references alist inputs)
  "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
in INPUTS and their transitive propagated inputs."
  (define label
    (match-lambda
      ((label . _)
       label)))

  (map (lambda (input)
         `(assoc-ref ,alist ,(label input)))
       (transitive-inputs inputs)))

(define package-transitive-supported-systems
  (mlambdaq (package)
    "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
    (fold (lambda (input systems)
            (match input
              ((label (? package? p) . _)
               (lset-intersection
                string=? systems (package-transitive-supported-systems p)))
              (_
               systems)))
          (package-supported-systems package)
          (bag-direct-inputs (package->bag package)))))

(define* (supported-package? package #:optional (system (%current-system)))
  "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
dependencies are known to build on SYSTEM."
  (member system (package-transitive-supported-systems package)))

(define (bag-direct-inputs bag)
  "Same as 'package-direct-inputs', but applied to a bag."
  (append (bag-build-inputs bag)
          (bag-host-inputs bag)
          (bag-target-inputs bag)))

(define (bag-transitive-inputs bag)
  "Same as 'package-transitive-inputs', but applied to a bag."
  (transitive-inputs (bag-direct-inputs bag)))

(define (bag-transitive-build-inputs bag)
  "Same as 'package-transitive-native-inputs', but applied to a bag."
  (transitive-inputs (bag-build-inputs bag)))

(define (bag-transitive-host-inputs bag)
  "Same as 'package-transitive-target-inputs', but applied to a bag."
  (transitive-inputs (bag-host-inputs bag)))

(define (bag-transitive-target-inputs bag)
  "Return the \"target inputs\" of BAG, recursively."
  (transitive-inputs (bag-target-inputs bag)))

(define* (package-mapping proc #:optional (cut? (const #f)))
  "Return a procedure that, given a package, applies PROC to all the packages
depended on and returns the resulting package.  The procedure stops recursion
when CUT? returns true for a given package."
  (define (rewrite input)
    (match input
      ((label (? package? package) outputs ...)
       (let ((proc (if (cut? package) proc replace)))
         (cons* label (proc package) outputs)))
      (_
       input)))

  (define replace
    (mlambdaq (p)
      ;; Return a variant of P with PROC applied to P and its explicit
      ;; dependencies, recursively.  Memoize the transformations.  Failing to
      ;; do that, we would build a huge object graph with lots of duplicates,
      ;; which in turns prevents us from benefiting from memoization in
      ;; 'package-derivation'.
      (let ((p (proc p)))
        (package
          (inherit p)
          (location (package-location p))
          (inputs (map rewrite (package-inputs p)))
          (native-inputs (map rewrite (package-native-inputs p)))
          (propagated-inputs (map rewrite (package-propagated-inputs p)))
          (replacement (and=> (package-replacement p) proc))))))

  replace)

(define* (package-input-rewriting replacements
                                  #:optional (rewrite-name identity))
  "Return a procedure that, when passed a package, replaces its direct and
indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
REPLACEMENTS is a list of package pairs; the first element of each pair is the
package to replace, and the second one is the replacement.

Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
package and returns its new name after rewrite."
  (define (rewrite p)
    (match (assq-ref replacements p)
      (#f  (package
             (inherit p)
             (name (rewrite-name (package-name p)))))
      (new new)))

  (package-mapping rewrite (cut assq <> replacements)))

(define-syntax-rule (package/inherit p overrides ...)
  "Like (package (inherit P) OVERRIDES ...), except that the same
transformation is done to the package replacement, if any.  P must be a bare
identifier, and will be bound to either P or its replacement when evaluating
OVERRIDES."
  (let loop ((p p))
    (package (inherit p)
      overrides ...
      (replacement (and=> (package-replacement p) loop)))))

;;;
;;; Package derivations.
;;;

(define %derivation-cache
  ;; Package to derivation-path mapping.
  (make-weak-key-hash-table 100))

(define (cache! cache package system thunk)
  "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
SYSTEM."
  ;; FIXME: This memoization should be associated with the open store, because
  ;; otherwise it breaks when switching to a different store.
  (let ((vals (call-with-values thunk list)))
    ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
    ;; same value for all structs (as of Guile 2.0.6), and because pointer
    ;; equality is sufficient in practice.
    (hashq-set! cache package
                `((,system ,@vals)
                  ,@(or (hashq-ref cache package) '())))
    (apply values vals)))

(define-syntax cached
  (syntax-rules (=>)
    "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
Return the cached result when available."
    ((_ (=> cache) package system body ...)
     (let ((thunk (lambda () body ...))
           (key   system))
       (match (hashq-ref cache package)
         ((alist (... ...))
          (match (assoc-ref alist key)
            ((vals (... ...))
             (apply values vals))
            (#f
             (cache! cache package key thunk))))
         (#f
          (cache! cache package key thunk)))))
    ((_ package system body ...)
     (cached (=> %derivation-cache) package system body ...))))

(define* (expand-input store package input system #:optional cross-system)
  "Expand INPUT, an input tuple, such that it contains only references to
derivation paths or store paths.  PACKAGE is only used to provide contextual
information in exceptions."
  (define (intern file)
    ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
    ;; file permissions are preserved.
    (add-to-store store (basename file) #t "sha256" file))

  (define derivation
    (if cross-system
        (cut package-cross-derivation store <> cross-system system
             #:graft? #f)
        (cut package-derivation store <> system #:graft? #f)))

  (match input
    (((? string? name) (? package? package))
     (list name (derivation package)))
    (((? string? name) (? package? package)
      (? string? sub-drv))
     (list name (derivation package)
           sub-drv))
    (((? string? name)
      (and (? string?) (? derivation-path?) drv))
     (list name drv))
    (((? string? name)
      (and (? string?) (? file-exists? file)))
     ;; Add FILE to the store.  When FILE is in the sub-directory of a
     ;; store path, it needs to be added anyway, so it can be used as a
     ;; source.
     (list name (intern file)))
    (((? string? name) (? struct? source))
     ;; 'package-source-derivation' calls 'lower-object', which can throw
     ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
     ;; location info, so we catch and rethrow here (XXX: not optimal
     ;; performance-wise).
     (guard (c ((gexp-input-error? c)
                (raise (condition
                        (&package-input-error
                         (package package)
                         (input   (gexp-error-invalid-input c)))))))
       (list name (package-source-derivation store source system))))
    (x
     (raise (condition (&package-input-error
                        (package package)
                        (input   x)))))))

(define %bag-cache
  ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
  ;; It significantly speeds things up when doing repeated calls to
  ;; 'package->bag' as is the case when building a profile.
  (make-weak-key-hash-table 200))

(define* (package->bag package #:optional
                       (system (%current-system))
                       (target (%current-target-system))
                       #:key (graft? (%graft?)))
  "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it."
  (cached (=> %bag-cache)
          package (list system target graft?)
          ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
          ;; field values can refer to it.
          (parameterize ((%current-system system)
                         (%current-target-system target))
            (match (if graft?
                       (or (package-replacement package) package)
                       package)
              (($ <package> name version source build-system
                            args inputs propagated-inputs native-inputs
                            self-native-input? outputs)
               ;; Even though we prefer to use "@" to separate the package
               ;; name from the package version in various user-facing parts
               ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
               ;; prohibits the use of "@", so use "-" instead.
               (or (make-bag build-system (string-append name "-" version)
                             #:system system
                             #:target target
                             #:source source
                             #:inputs (append (inputs)
                                              (propagated-inputs))
                             #:outputs outputs
                             #:native-inputs `(,@(if (and target
                                                          self-native-input?)
                                                     `(("self" ,package))
                                                     '())
                                               ,@(native-inputs))
                             #:arguments (args))
                   (raise (if target
                              (condition
                               (&package-cross-build-system-error
                                (package package)))
                              (condition
                               (&package-error
                                (package package)))))))))))

(define %graft-cache
  ;; 'eq?' cache mapping package objects to a graft corresponding to their
  ;; replacement package.
  (make-weak-key-hash-table 200))

(define (input-graft store system)
  "Return a procedure that, given a package with a graft, returns a graft, and
#f otherwise."
  (match-lambda
    ((? package? package)
     (let ((replacement (package-replacement package)))
       (and replacement
            (cached (=> %graft-cache) package system
                    (let ((orig (package-derivation store package system
                                                    #:graft? #f))
                          (new  (package-derivation store replacement system
                                                    #:graft? #t)))
                      (graft
                        (origin orig)
                        (replacement new)))))))
    (x
     #f)))

(define (input-cross-graft store target system)
  "Same as 'input-graft', but for cross-compilation inputs."
  (match-lambda
    ((? package? package)
    (let ((replacement (package-replacement package)))
      (and replacement
           (let ((orig (package-cross-derivation store package target system
                                                 #:graft? #f))
                 (new  (package-cross-derivation store replacement
                                                 target system
                                                 #:graft? #t)))
             (graft
               (origin orig)
               (replacement new))))))
   (_
    #f)))

(define* (fold-bag-dependencies proc seed bag
                                #:key (native? #t))
  "Fold PROC over the packages BAG depends on.  Each package is visited only
once, in depth-first order.  If NATIVE? is true, restrict to native
dependencies; otherwise, restrict to target dependencies."
  (define bag-direct-inputs*
    (if native?
        (lambda (bag)
          (append (bag-build-inputs bag)
                  (bag-target-inputs bag)
                  (if (bag-target bag)
                      '()
                      (bag-host-inputs bag))))
        bag-host-inputs))

  (define nodes
    (match (bag-direct-inputs* bag)
      (((labels things _ ...) ...)
       things)))

  (let loop ((nodes nodes)
             (result seed)
             (visited (setq)))
    (match nodes
      (()
       result)
      (((? package? head) . tail)
       (if (set-contains? visited head)
           (loop tail result visited)
           (let ((inputs (bag-direct-inputs* (package->bag head))))
             (loop (match inputs
                     (((labels things _ ...) ...)
                      (append things tail)))
                   (proc head result)
                   (set-insert head visited)))))
      ((head . tail)
       (loop tail result visited)))))

(define* (bag-grafts store bag)
  "Return the list of grafts potentially applicable to BAG.  Potentially
applicable grafts are collected by looking at direct or indirect dependencies
of BAG that have a 'replacement'.  Whether a graft is actually applicable
depends on whether the outputs of BAG depend on the items the grafts refer
to (see 'graft-derivation'.)"
  (define system (bag-system bag))
  (define target (bag-target bag))

  (define native-grafts
    (let ((->graft (input-graft store system)))
      (fold-bag-dependencies (lambda (package grafts)
                               (match (->graft package)
                                 (#f    grafts)
                                 (graft (cons graft grafts))))
                             '()
                             bag)))

  (define target-grafts
    (if target
        (let ((->graft (input-cross-graft store target system)))
          (fold-bag-dependencies (lambda (package grafts)
                                   (match (->graft package)
                                     (#f    grafts)
                                     (graft (cons graft grafts))))
                                 '()
                                 bag
                                 #:native? #f))
        '()))

  ;; We can end up with several identical grafts if we stumble upon packages
  ;; that are not 'eq?' but map to the same derivation (this can happen when
  ;; using things like 'package-with-explicit-inputs'.)  Hence the
  ;; 'delete-duplicates' call.
  (delete-duplicates
   (append native-grafts target-grafts)))

(define* (package-grafts store package
                         #:optional (system (%current-system))
                         #:key target)
  "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
TARGET."
  (let* ((package (or (package-replacement package) package))
         (bag     (package->bag package system target)))
    (bag-grafts store bag)))

(define* (bag->derivation store bag
                          #:optional context)
  "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
a package object describing the context in which the call occurs, for improved
error reporting."
  (if (bag-target bag)
      (bag->cross-derivation store bag)
      (let* ((system     (bag-system bag))
             (inputs     (bag-transitive-inputs bag))
             (input-drvs (map (cut expand-input store context <> system)
                              inputs))
             (paths      (delete-duplicates
                          (append-map (match-lambda
                                       ((_ (? package? p) _ ...)
                                        (package-native-search-paths
                                         p))
                                       (_ '()))
                                      inputs))))

        (apply (bag-build bag)
               store (bag-name bag) input-drvs
               #:search-paths paths
               #:outputs (bag-outputs bag) #:system system
               (bag-arguments bag)))))

(define* (bag->cross-derivation store bag
                                #:optional context)
  "Return the derivation to build BAG, which is actually a cross build.
Optionally, CONTEXT can be a package object denoting the context of the call.
This is an internal procedure."
  (let* ((system      (bag-system bag))
         (target      (bag-target bag))
         (host        (bag-transitive-host-inputs bag))
         (host-drvs   (map (cut expand-input store context <> system target)
                           host))
         (target*     (bag-transitive-target-inputs bag))
         (target-drvs (map (cut expand-input store context <> system)
                           target*))
         (build       (bag-transitive-build-inputs bag))
         (build-drvs  (map (cut expand-input store context <> system)
                           build))
         (all         (append build target* host))
         (paths       (delete-duplicates
                       (append-map (match-lambda
                                    ((_ (? package? p) _ ...)
                                     (package-search-paths p))
                                    (_ '()))
                                   all)))
         (npaths      (delete-duplicates
                       (append-map (match-lambda
                                    ((_ (? package? p) _ ...)
                                     (package-native-search-paths
                                      p))
                                    (_ '()))
                                   all))))

    (apply (bag-build bag)
           store (bag-name bag)
           #:native-drvs build-drvs
           #:target-drvs (append host-drvs target-drvs)
           #:search-paths paths
           #:native-search-paths npaths
           #:outputs (bag-outputs bag)
           #:system system #:target target
           (bag-arguments bag))))

(define* (package-derivation store package
                             #:optional (system (%current-system))
                             #:key (graft? (%graft?)))
  "Return the <derivation> object of PACKAGE for SYSTEM."

  ;; Compute the derivation and cache the result.  Caching is important
  ;; because some derivations, such as the implicit inputs of the GNU build
  ;; system, will be queried many, many times in a row.
  (cached package (cons system graft?)
          (let* ((bag (package->bag package system #f #:graft? graft?))
                 (drv (bag->derivation store bag package)))
            (if graft?
                (match (bag-grafts store bag)
                  (()
                   drv)
                  (grafts
                   (let ((guile (package-derivation store (guile-2.0)
                                                    system #:graft? #f)))
                     ;; TODO: As an optimization, we can simply graft the tip
                     ;; of the derivation graph since 'graft-derivation'
                     ;; recurses anyway.
                     (graft-derivation store drv grafts
                                       #:system system
                                       #:guile guile))))
                drv))))

(define* (package-cross-derivation store package target
                                   #:optional (system (%current-system))
                                   #:key (graft? (%graft?)))
  "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
  (cached package (list system target graft?)
          (let* ((bag (package->bag package system target #:graft? graft?))
                 (drv (bag->derivation store bag package)))
            (if graft?
                (match (bag-grafts store bag)
                  (()
                   drv)
                  (grafts
                   (graft-derivation store drv grafts
                                     #:system system
                                     #:guile
                                     (package-derivation store (guile-2.0)
                                                         system #:graft? #f))))
                drv))))

(define* (package-output store package
                         #:optional (output "out") (system (%current-system)))
  "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
symbolic output name, such as \"out\".  Note that this procedure calls
`package-derivation', which is costly."
  (let ((drv (package-derivation store package system)))
    (derivation->output-path drv output)))

;;;
;;; Monadic interface.
;;;

(define (set-guile-for-build guile)
  "This monadic procedure changes the Guile currently used to run the build
code of derivations to GUILE, a package object."
  (lambda (store)
    (let ((guile (package-derivation store guile)))
      (values (%guile-for-build guile) store))))

(define* (package-file package
                       #:optional file
                       #:key
                       system (output "out") target)
  "Return as a monadic value the absolute file name of FILE within the
OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
cross-compilation target triplet."
  (lambda (store)
    (define compute-derivation
      (if target
          (cut package-cross-derivation <> <> target <>)
          package-derivation))

    (let* ((system (or system (%current-system)))
           (drv    (compute-derivation store package system))
           (out    (derivation->output-path drv output)))
      (values (if file
                  (string-append out "/" file)
                  out)
              store))))

(define package->derivation
  (store-lift package-derivation))

(define package->cross-derivation
  (store-lift package-cross-derivation))

(define-gexp-compiler (package-compiler (package <package>) system target)
  ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
  ;; TARGET.  This is used when referring to a package from within a gexp.
  (if target
      (package->cross-derivation package target system)
      (package->derivation package system)))

(define* (origin->derivation origin
                             #:optional (system (%current-system)))
  "Return the derivation corresponding to ORIGIN."
  (match origin
    (($ <origin> uri method sha256 name (= force ()) #f)
     ;; No patches, no snippet: this is a fixed-output derivation.
     (method uri 'sha256 sha256 name #:system system))
    (($ <origin> uri method sha256 name (= force (patches ...)) snippet
        (flags ...) inputs (modules ...) guile-for-build)
     ;; Patches and/or a snippet.
     (mlet %store-monad ((source (method uri 'sha256 sha256 name
                                         #:system system))
                         (guile  (package->derivation (or guile-for-build
                                                          (default-guile))
                                                      system
                                                      #:graft? #f)))
       (patch-and-repack source patches
                         #:inputs inputs
                         #:snippet snippet
                         #:flags flags
                         #:system system
                         #:modules modules
                         #:guile-for-build guile)))))

(define-gexp-compiler (origin-compiler (origin <origin>) system target)
  ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
  ;; to an origin from within a gexp.
  (origin->derivation origin system))

(define package-source-derivation                 ;somewhat deprecated
  (let ((lower (store-lower lower-object)))
    (lambda* (store source #:optional (system (%current-system)))
      "Return the derivation or file corresponding to SOURCE, which can be an
a file name or any object handled by 'lower-object', such as an <origin>.
When SOURCE is a file name, return either the interned file name (if SOURCE is
outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
      (match source
        ((and (? string?) (? direct-store-path?) file)
         file)
        ((? string? file)
         (add-to-store store (basename file) #t "sha256" file))
        (_
         (lower store source system))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@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 pki)
  #:use-module (guix config)
  #:use-module (gcrypt pk-crypto)
  #:use-module ((guix utils) #:select (with-atomic-file-output))
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 binary-ports)
  #:export (%public-key-file
            %private-key-file
            %acl-file
            current-acl
            public-keys->acl
            acl->public-keys
            authorized-key?
            write-acl

            signature-sexp
            signature-subject
            signature-signed-data
            valid-signature?
            signature-case))

;;; Commentary:
;;;
;;; Public key infrastructure for the authentication and authorization of
;;; archive imports.  This is essentially a subset of SPKI for our own
;;; purposes (see <http://theworld.com/~cme/spki.txt> and
;;; <http://www.ietf.org/rfc/rfc2693.txt>.)
;;;
;;; Code:

(define (public-keys->acl keys)
  "Return an ACL that lists all of KEYS with a '(guix import)'
tag---meaning that all of KEYS are authorized for archive imports.  Each
element in KEYS must be a canonical sexp with type 'public-key'."

  ;; Use SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
  ;; signed by the corresponding secret key (see the IETF draft at
  ;; <http://theworld.com/~cme/spki.txt> for the ACL format.)
  ;;
  ;; Note: We always use PUBLIC-KEY to designate the subject.  Someday we may
  ;; want to have name certificates and to use subject names instead of
  ;; complete keys.
  `(acl ,@(map (lambda (key)
                 `(entry ,(canonical-sexp->sexp key)
                         (tag (guix import))))
               keys)))

(define %acl-file
  (string-append %config-directory "/acl"))

(define %public-key-file
  (string-append %config-directory "/signing-key.pub"))

(define %private-key-file
  (string-append %config-directory "/signing-key.sec"))

(define (ensure-acl)
  "Make sure the ACL file exists, and create an initialized one if needed."
  (unless (file-exists? %acl-file)
    ;; If there's no public key file, don't attempt to create the ACL.
    (when (file-exists? %public-key-file)
      (let ((public-key (call-with-input-file %public-key-file
                          (compose string->canonical-sexp
                                   read-string))))
        (mkdir-p (dirname %acl-file))
        (with-atomic-file-output %acl-file
          (lambda (port)
            (write-acl (public-keys->acl (list public-key))
                       port)))))))

(define (write-acl acl port)
  "Write ACL to PORT in canonical-sexp format."
  (let ((sexp (sexp->canonical-sexp acl)))
    (display (canonical-sexp->string sexp) port)))

(define (current-acl)
  "Return the current ACL."
  (ensure-acl)
  (if (file-exists? %acl-file)
      (call-with-input-file %acl-file
        (compose canonical-sexp->sexp
                 string->canonical-sexp
                 read-string))
      (public-keys->acl '())))                    ; the empty ACL

(define (acl->public-keys acl)
  "Return the public keys (as canonical sexps) listed in ACL with the '(guix
import)' tag."
  (match acl
    (('acl
      ('entry subject-keys
              ('tag ('guix 'import)))
      ...)
     (map sexp->canonical-sexp subject-keys))
    (_
     (error "invalid access-control list" acl))))

(define* (authorized-key? key #:optional (acl (current-acl)))
  "Return #t if KEY (a canonical sexp) is an authorized public key for archive
imports according to ACL."
  ;; Note: ACL is kept in native sexp form to make 'authorized-key?' faster,
  ;; by not having to convert it with 'canonical-sexp->sexp' on each call.
  ;; TODO: We could use a better data type for ACLs.
  (let ((key (canonical-sexp->sexp key)))
    (match acl
      (('acl
        ('entry subject-keys
                ('tag ('guix 'import)))
        ...)
       (not (not (member key subject-keys))))
      (_
       (error "invalid access-control list" acl)))))

(define (signature-sexp data secret-key public-key)
  "Return a SPKI-style sexp for the signature of DATA with SECRET-KEY that
includes DATA, the actual signature value (with a 'sig-val' tag), and
PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
  (string->canonical-sexp
   (format #f
           "(signature ~a ~a ~a)"
           (canonical-sexp->string data)
           (canonical-sexp->string (sign data secret-key))
           (canonical-sexp->string public-key))))

(define (signature-subject sig)
  "Return the signer's public key for SIG."
  (find-sexp-token sig 'public-key))

(define (signature-signed-data sig)
  "Return the signed data from SIG, typically an sexp such as
  (hash \"sha256\" #...#)."
  (find-sexp-token sig 'data))

(define (valid-signature? sig)
  "Return #t if SIG is valid."
  (let* ((data       (signature-signed-data sig))
         (signature  (find-sexp-token sig 'sig-val))
         (public-key (signature-subject sig)))
    (and data signature
         (verify signature data public-key))))

(define* (%signature-status signature hash
                            #:optional (acl (current-acl)))
  "Return a symbol denoting the status of SIGNATURE vs. HASH vs. ACL.

This procedure must only be used internally, because it would be easy to
forget some of the cases."
  (let ((subject (signature-subject signature))
        (data    (signature-signed-data signature)))
    (if (and data subject)
        (if (authorized-key? subject acl)
            (if (equal? (hash-data->bytevector data) hash)
                (if (valid-signature? signature)
                    'valid-signature
                    'invalid-signature)
                'hash-mismatch)
            'unauthorized-key)
        'corrupt-signature)))

(define-syntax signature-case
  (syntax-rules (valid-signature invalid-signature
                 hash-mismatch unauthorized-key corrupt-signature
                 else)
    "\
Match the cases of the verification of SIGNATURE against HASH and ACL:

  - the 'valid-signature' case if SIGNATURE is indeed a signature of HASH with
    a key present in ACL;
  - 'invalid-signature' if SIGNATURE is incorrect;
  - 'hash-mismatch' if the hash in SIGNATURE does not match HASH;
  - 'unauthorized-key' if the public key in SIGNATURE is not listed in ACL;
  - 'corrupt-signature' if SIGNATURE is not a valid signature sexp.

This macro guarantees at compile-time that all these cases are handled.

SIGNATURE, and ACL must be canonical sexps; HASH must be a bytevector."

    ;; Simple case: we only care about valid signatures.
    ((_ (signature hash acl)
        (valid-signature valid-exp ...)
        (else else-exp ...))
     (case (%signature-status signature hash acl)
       ((valid-signature) valid-exp ...)
       (else else-exp ...)))

    ;; Full case.
    ((_ (signature hash acl)
        (valid-signature valid-exp ...)
        (invalid-signature invalid-exp ...)
        (hash-mismatch mismatch-exp ...)
        (unauthorized-key unauthorized-exp ...)
        (corrupt-signature corrupt-exp ...))
     (case (%signature-status signature hash acl)
       ((valid-signature) valid-exp ...)
       ((invalid-signature) invalid-exp ...)
       ((hash-mismatch) mismatch-exp ...)
       ((unauthorized-key) unauthorized-exp ...)
       ((corrupt-signature) corrupt-exp ...)
       (else (error "bogus signature status"))))))

;;; pki.scm ends here