code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 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 man-db)
  #:use-module (zlib)
  #:use-module ((guix build utils) #:select (find-files))
  #:use-module (gdbm)                             ;gdbm-ffi
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:export (mandb-entry?
            mandb-entry-file-name
            mandb-entry-name
            mandb-entry-section
            mandb-entry-synopsis
            mandb-entry-kind

            mandb-entries
            write-mandb-database))

;;; Comment:
;;;
;;; Scan gzipped man pages and create a man-db database.  The database is
;;; meant to be used by 'man -k KEYWORD'.
;;;
;;; The implementation here aims to be simpler than that of 'man-db', and to
;;; produce deterministic output.  See <https://bugs.gnu.org/29654>.
;;;
;;; Code:

(define-record-type <mandb-entry>
  (mandb-entry file-name name section synopsis kind)
  mandb-entry?
  (file-name mandb-entry-file-name)               ;e.g., "../abiword.1.gz"
  (name      mandb-entry-name)                    ;e.g., "ABIWORD"
  (section   mandb-entry-section)                 ;number
  (synopsis  mandb-entry-synopsis)                ;string
  (kind      mandb-entry-kind))                   ;'ultimate | 'link

(define (mandb-entry<? entry1 entry2)
  (match entry1
    (($ <mandb-entry> file1 name1 section1)
     (match entry2
       (($ <mandb-entry> file2 name2 section2)
        (or (< section1 section2)
            (string<? (basename file1) (basename file2))))))))

(define abbreviate-file-name
  (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$")))
    (lambda (file)
      (match (regexp-exec man-file-rx (basename file))
        (#f
         (basename file))
        (matches
         (match:substring matches 1))))))

(define (entry->string entry)
  "Return the wire format for ENTRY as a string."
  (match entry
    (($ <mandb-entry> file name section synopsis kind)
     ;; See db_store.c:make_content in man-db for the format.
     (string-append (abbreviate-file-name file) "\t"
                    (number->string section) "\t"
                    (number->string section)

                    ;; Timestamp that we always set to the epoch.
                    "\t0\t0"

                    ;; See "db_storage.h" in man-db for the different kinds.
                    "\t"
                    (case kind
                      ((ultimate) "A")     ;ultimate man page
                      ((link)     "B")     ;".so" link to other man page
                      (else       "A"))    ;something that doesn't matter much

                    "\t-\t-\t"

                    (if (string-suffix? ".gz" file) "gz" "")
                    "\t"

                    synopsis "\x00"))))

;; The man-db schema version we're compatible with.
(define %version-key "$version$\x00")
(define %version-value "2.5.0\x00")

(define (write-mandb-database file entries)
  "Write ENTRIES to FILE as a man-db database.  FILE is usually
\".../index.db\", and is a GDBM database."
  (let ((db (gdbm-open file GDBM_WRCREAT)))
    (gdbm-set! db %version-key %version-value)

    ;; Write ENTRIES in sorted order so we get deterministic output.
    (for-each (lambda (entry)
                (gdbm-set! db
                           (string-append (mandb-entry-file-name entry)
                                          "\x00")
                           (entry->string entry)))
              (sort entries mandb-entry<?))
    (gdbm-close db)))

(define (read-synopsis port)
  "Read from PORT a man page synopsis."
  (define (section? line)
    ;; True if LINE starts with ".SH", ".PP", or so.
    (string-prefix? "." (string-trim line)))

  (define (extract-synopsis str)
    (match (string-contains str "\\-")
      (#f "")
      (index
       (string-map (match-lambda
                     (#\newline #\space)
                     (chr chr))
                   (string-trim-both (string-drop str (+ 2 index)))))))

  ;; Synopses look like "Command \- Do something.", possibly spanning several
  ;; lines.
  (let loop ((lines '()))
    (match (read-line port 'concat)
      ((? eof-object?)
       (extract-synopsis (string-concatenate-reverse lines)))
      ((? section?)
       (extract-synopsis (string-concatenate-reverse lines)))
      (line
       (loop (cons line lines))))))

(define* (man-page->entry file #:optional (resolve identity))
  "Parse FILE, a gzipped man page, and return a <mandb-entry> for it."
  (define (string->number* str)
    (if (and (string-prefix? "\"" str)
             (> (string-length str) 1)
             (string-suffix? "\"" str))
        (string->number (string-drop (string-drop-right str 1) 1))
        (string->number str)))

  ;; Note: This works for both gzipped and uncompressed files.
  (call-with-gzip-input-port (open-file file "r0")
    (lambda (port)
      (let loop ((name     #f)
                 (section  #f)
                 (synopsis #f)
                 (kind     'ultimate))
        (if (and name section synopsis)
            (mandb-entry file name section synopsis kind)
            (let ((line (read-line port)))
              (if (eof-object? line)
                  (mandb-entry file name (or section 0) (or synopsis "")
                               kind)
                  (match (string-tokenize line)
                    ((".TH" name (= string->number* section) _ ...)
                     (loop name section synopsis kind))
                    ((".SH" (or "NAME" "\"NAME\""))
                     (loop name section (read-synopsis port) kind))
                    ((".so" link)
                     (match (and=> (resolve link)
                                   (cut man-page->entry <> resolve))
                       (#f
                        (loop name section synopsis 'link))
                       (alias
                        (mandb-entry file
                                     (mandb-entry-name alias)
                                     (mandb-entry-section alias)
                                     (mandb-entry-synopsis alias)
                                     'link))))
                    (_
                     (loop name section synopsis kind))))))))))

(define (man-files directory)
  "Return the list of man pages found under DIRECTORY, recursively."
  ;; Filter the list to ensure that broken symlinks are excluded.
  (filter file-exists? (find-files directory "\\.[0-9][a-z]?(\\.gz)?$")))

(define (mandb-entries directory)
  "Return mandb entries for the man pages found under DIRECTORY, recursively."
  (map (lambda (file)
         (man-page->entry file
                          (lambda (link)
                            (let ((file (string-append directory "/" link
                                                       ".gz")))
                              (and (file-exists? file) file)))))
       (man-files directory)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 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 memoization)
  #:use-module (guix profiling)
  #:use-module (ice-9 match)
  #:autoload   (srfi srfi-1) (count)
  #:use-module (srfi srfi-9)
  #:export (invalidate-memoization!
            memoize
            mlambda
            mlambdaq))

;; Data type representation a memoization cache when profiling is on.
(define-record-type <cache>
  (make-cache table lookups hits)
  cache?
  (table   cache-table)
  (lookups cache-lookups set-cache-lookups!)
  (hits    cache-hits    set-cache-hits!))

(define-syntax-rule (define-lookup-procedure proc get)
  "Define a lookup procedure PROC.  When profiling is turned off, PROC is set
to GET; when profiling is on, PROC is a wrapper around GET that keeps tracks
of lookups and cache hits."
  (define proc
    (if (profiled? "memoization")
        (lambda (cache key default)
          (let ((result (get (cache-table cache) key default)))
            (set-cache-lookups! cache (+ 1 (cache-lookups cache)))
            (unless (eq? result default)
              (set-cache-hits! cache (+ 1 (cache-hits cache))))
            result))
        get)))

(define-syntax-rule (define-update-procedure proc put!)
  "Define an update procedure PROC.  When profiling is turned off, PROC is
equal to PUT!; when profiling is on, PROC is a wrapper around PUT and unboxes
the underlying hash table."
  (define proc
    (if (profiled? "memoization")
        (lambda (cache key value)
          (put! (cache-table cache) key value))
        put!)))

(define-lookup-procedure cache-ref hash-ref)
(define-lookup-procedure cacheq-ref hashq-ref)
(define-update-procedure cache-set! hash-set!)
(define-update-procedure cacheq-set! hashq-set!)

(define-syntax-rule (call/mv thunk)
  (call-with-values thunk list))
(define-syntax-rule (return/mv lst)
  (apply values lst))

(define-syntax-rule (call/1 thunk)
  (thunk))
(define-syntax-rule (return/1 value)
  value)

(define-syntax define-cache-procedure
  (syntax-rules ()
    "Define a procedure NAME that implements a cache using HASH-REF and
HASH-SET!.  Use CALL to invoke the thunk and RETURN to return its value; CALL
and RETURN are used to distinguish between multiple-value and single-value
returns."
    ((_ name hash-ref hash-set! call return)
     (define name
       (let ((%nothing '(this is nothing)))
         (lambda (cache key thunk)
           "Cache the result of THUNK under KEY in CACHE, or return the
already-cached result."
           (let ((results (hash-ref cache key %nothing)))
             (if (eq? results %nothing)
                 (let ((results (call thunk)))
                   (hash-set! cache key results)
                   (return results))
                 (return results)))))))
    ((_ name hash-ref hash-set!)
     (define-cache-procedure name hash-ref hash-set!
       call/mv return/mv))))

(define-cache-procedure cached/mv  cache-ref cache-set!)
(define-cache-procedure cachedq/mv cacheq-ref cacheq-set!)
(define-cache-procedure cached  cache-ref cache-set! call/1 return/1)
(define-cache-procedure cachedq cacheq-ref cacheq-set! call/1 return/1)

(define %memoization-tables
  ;; Map procedures to the underlying hash table.
  (make-weak-key-hash-table))

(define %make-hash-table*
  ;; When profiling is off, this is equivalent to 'make-hash-table'.  When
  ;; profiling is on, return a hash table wrapped in a <cache> object.
  (if (profiled? "memoization")
      (lambda (proc location)
        (let ((cache (make-cache (make-hash-table) 0 0)))
          (hashq-set! %memoization-tables proc
                      (cons cache location))
          cache))
      (lambda (proc location)
        (let ((table (make-hash-table)))
          (hashq-set! %memoization-tables proc table)
          table))))

(define-syntax-rule (make-hash-table* proc)
  (%make-hash-table* proc (current-source-location)))

(define (invalidate-memoization! proc)
  "Invalidate the memoization cache of PROC."
  (match (hashq-ref %memoization-tables proc)
    ((? hash-table? table)
     (hash-clear! table))
    (((? cache? cache) . _)
     (hash-clear! (cache-table cache)))))

(define* (show-memoization-tables #:optional (port (current-error-port)))
  "Display to PORT statistics about the memoization tables."
  (define (cache<? p1 p2)
    (match p1
      ((cache1 . _)
       (match p2
         ((cache2 . _)
          (< (hash-count (const #t) (cache-table cache1))
             (hash-count (const #t) (cache-table cache2))))))))

  (define caches
    (hash-map->list (lambda (key value)
                      value)
                    %memoization-tables))

  (match (sort caches (negate cache<?))
    (((caches . locations) ...)
     (format port "Memoization: ~a tables, ~a non-empty~%"
             (length caches)
             (count (lambda (cache)
                      (> (hash-count (const #t) (cache-table cache)) 0))
                    caches))
     (for-each (lambda (cache location)
                 (let ((size (hash-count (const #t) (cache-table cache))))
                   (unless (zero? size)
                     (format port "  ~a:~a:~a: \t~a entries, ~a lookups, ~a% hits~%"
                             (assq-ref location 'filename)
                             (and=> (assq-ref location 'line) 1+)
                             (assq-ref location 'column)
                             size
                             (cache-lookups cache)
                             (inexact->exact
                              (round
                               (* 100. (/ (cache-hits cache)
                                          (cache-lookups cache) 1.))))))))
               caches locations))))

(register-profiling-hook! "memoization" show-memoization-tables)

(define (memoize proc)
  "Return a memoizing version of PROC.

This is a generic version of 'mlambda' what works regardless of the arity of
'proc'.  It is more expensive since the argument list is always allocated, and
the result is returned via (apply values results)."
  (letrec* ((mproc (lambda args
                     (cached/mv cache args
                                (lambda ()
                                  (apply proc args)))))
            (cache (make-hash-table* mproc)))
    mproc))

(define-syntax %mlambda
  (syntax-rules ()
    "Return a memoizing lambda.  This is restricted to procedures that return
exactly one value."
    ((_ cached () body ...)
     ;; The zero-argument case is equivalent to a promise.
     (let ((result #f) (cached? #f)
           (compute (lambda () body ...)))
       (lambda ()
         (unless cached?
           (set! result (compute))
           (set! cached? #t))
         result)))

    ;; Optimize the fixed-arity case such that there's no argument list
    ;; allocated.  XXX: We can't really avoid the closure allocation since
    ;; Guile 2.0's compiler will always keep it.
    ((_ cached (arg) body ...)                    ;one argument
     (letrec* ((proc  (lambda (arg) body ...))
               (mproc (lambda (arg)
                        (cached cache arg (lambda () (proc arg)))))
               (cache (make-hash-table* mproc)))
       mproc))
    ((_ _ (args ...) body ...)                    ;two or more arguments
     (letrec* ((proc  (lambda (args ...) body ...))
               (mproc (lambda (args ...)
                        ;; XXX: Always use 'cached', which uses 'equal?', to
                        ;; compare the argument lists.
                        (cached cache (list args ...)
                                (lambda ()
                                  (proc args ...)))))
               (cache (make-hash-table* mproc)))
       mproc))))

(define-syntax-rule (mlambda formals body ...)
  "Define a memoizing lambda.  The lambda's arguments are compared with
'equal?', and BODY is expected to yield a single return value."
  (%mlambda cached formals body ...))

(define-syntax-rule (mlambdaq formals body ...)
  "Define a memoizing lambda.  If FORMALS lists a single argument, it is
compared using 'eq?'; otherwise, the argument list is compared using 'equal?'.
BODY is expected to yield a single return value."
  (%mlambda cachedq formals body ...))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2021 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 modules)
  #:use-module (guix memoization)
  #:use-module (guix sets)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (missing-dependency-error?
            missing-dependency-module
            missing-dependency-search-path

            file-name->module-name
            module-name->file-name

            source-module-dependencies
            source-module-closure
            live-module-closure
            guix-module-name?))

;;; Commentary:
;;;
;;; This module provides introspection tools for Guile modules at the source
;;; level.  Namely, it allows you to determine the closure of a module; it
;;; does so just by reading the 'define-module' clause of the module and its
;;; dependencies.  This is primarily useful as an argument to
;;; 'with-imported-modules'.
;;;
;;; Code:

;; The error corresponding to a missing module.
(define-condition-type &missing-dependency-error &error
  missing-dependency-error?
  (module      missing-dependency-module)
  (search-path missing-dependency-search-path))

(define (colon-symbol? obj)
  "Return true if OBJ is a symbol that starts with a colon."
  (and (symbol? obj)
       (string-prefix? ":" (symbol->string obj))))

(define (colon-symbol->keyword symbol)
  "Convert SYMBOL to a keyword after stripping its initial ':'."
  (symbol->keyword
   (string->symbol (string-drop (symbol->string symbol) 1))))

(define (extract-dependencies clauses)
  "Return the list of modules imported according to the given 'define-module'
CLAUSES."
  (let loop ((clauses clauses)
             (result  '()))
    (match clauses
      (()
       (reverse result))
      ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
        rest ...)
       (loop rest (cons module result)))
      ((#:use-module module rest ...)
       (loop rest (cons module result)))
      ((#:autoload module _ rest ...)
       (loop rest (cons module result)))
      (((or #:export #:re-export #:export-syntax #:re-export-syntax
            #:re-export-and-replace #:replace #:version)
        _ rest ...)
       (loop rest result))
      (((or #:pure #:no-backtrace) rest ...)
       (loop rest result))
      (((? colon-symbol? symbol) rest ...)
       (loop (cons (colon-symbol->keyword symbol) rest)
             result)))))

(define module-file-dependencies
  (mlambda (file)
    "Return the list of the names of modules that the Guile module in FILE
depends on."
    (call-with-input-file file
      (lambda (port)
        (match (read port)
          (('define-module name clauses ...)
           (extract-dependencies clauses))
          ;; XXX: R6RS 'library' form is ignored.
          (_
           '()))))))

(define file-name->module-name
  (let ((not-slash (char-set-complement (char-set #\/))))
    (lambda (file)
      "Return the module name (a list of symbols) corresponding to FILE."
      (map string->symbol
           (string-tokenize (string-drop-right file 4) not-slash)))))

(define (module-name->file-name module)
  "Return the file name for MODULE."
  (string-append (string-join (map symbol->string module) "/")
                 ".scm"))

(define (guix-module-name? name)
  "Return true if NAME (a list of symbols) denotes a Guix module."
  (match name
    (('guix _ ...) #t)
    (('gnu _ ...) #t)
    (_ #f)))

(define %source-less-modules
  ;; These are modules that have no corresponding source files or a source
  ;; file different from what you'd expect.
  '((system syntax)                             ;2.0, defined in boot-9
    (ice-9 ports internal)                      ;2.2, defined in (ice-9 ports)
    (system syntax internal)))                  ;2.2, defined in boot-9

(define* (source-module-dependencies module #:optional (load-path %load-path))
  "Return the modules used by MODULE by looking at its source code."
  (if (member module %source-less-modules)
      '()
      (match (search-path load-path (module-name->file-name module))
        ((? string? file)
         (module-file-dependencies file))
        (#f
         (raise (condition (&missing-dependency-error
                            (module module)
                            (search-path load-path))))))))

(define* (module-closure modules
                         #:key
                         (select? guix-module-name?)
                         (dependencies source-module-dependencies))
  "Return the closure of MODULES, calling DEPENDENCIES to determine the list
of modules used by a given module.  MODULES and the result are a list of Guile
module names.  Only modules that match SELECT? are considered."
  (let loop ((modules modules)
             (result  '())
             (visited  (set)))
    (match modules
      (()
       (reverse result))
      ((module rest ...)
       (cond ((set-contains? visited module)
              (loop rest result visited))
             ((select? module)
              (loop (append (dependencies module) rest)
                    (cons module result)
                    (set-insert module visited)))
             (else
              (loop rest result visited)))))))

(define* (source-module-closure modules
                                #:optional (load-path %load-path)
                                #:key (select? guix-module-name?))
  "Return the closure of MODULES by reading 'define-module' forms in their
source code.  MODULES and the result are a list of Guile module names.  Only
modules that match SELECT?  are considered."
  (module-closure modules
                  #:dependencies (cut source-module-dependencies <> load-path)
                  #:select? select?))

(define* (live-module-closure modules
                              #:key (select? guix-module-name?))
  "Return the closure of MODULES, determined by looking at live (loaded)
module information.  MODULES and the result are a list of Guile module names.
Only modules that match SELECT? are considered."
  (define (dependencies module)
    (map module-name
         (delq the-scm-module (module-uses (resolve-module module)))))

  (module-closure modules
                  #:dependencies dependencies
                  #:select? select?))

;;; modules.scm ends here


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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 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))

  ;; XXX: Eventually we should use (guix store database) exclusively, and not
  ;; (guix store) since this is "daemon-side" code.
  #:use-module (guix store)
  #:use-module (guix store database)
  #:use-module ((guix store deduplication) #:select (dump-file/deduplicate))
  #:use-module ((guix build store-copy) #:select (store-info))

  #:use-module (guix i18n)
  #: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* (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."
  ;; TODO: make this reusable
  (define (acquire-lock file)
    (let ((port (lock-file file)))
      ;; There is an inherent race condition between opening the lock file and
      ;; attempting to acquire the lock on it, and because we like deleting
      ;; these lock files when we release them, only the first successful
      ;; acquisition on a given lock file matters.  To make it easier to tell
      ;; when an acquisition is and isn't the first, the first to acquire it
      ;; writes a deletion token (arbitrary character) prior to releasing the
      ;; lock.
      (if (zero? (stat:size (stat port)))
          port
          ;; if FILE is non-empty, that's because it contains the deletion
          ;; token, so we aren't the first to acquire it.  So try again!
          (begin
            (close port)
            (acquire-lock file)))))

  (with-database %default-database-file db
    (unless (path-id db target)
      (let ((lock (and lock?
                       (acquire-lock (string-append target ".lock")))))

        (unless (path-id db 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.  The 'restore-file' call took care of
          ;; deduplication, timestamps, and permissions.
          (register-items db
                          (list (store-info target deriver references))))

        (when lock?
          (delete-file (string-append target ".lock"))
          ;; Write the deletion token to inform anyone who acquires the lock
          ;; on this particular file next that they aren't the first to
          ;; acquire it, so they should retry.
          (display "d" lock)
          (force-output lock)
          (unlock-file lock))))))

(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."
  (with-store store
    (let loop ((name (temporary-store-file)))
      ;; 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 of a nar bundle read 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
                    #:dump-file dump-file/deduplicate)

      (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 (\"nar bundle\") 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 © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix narinfo)
  #:use-module (guix pki)
  #:use-module (guix i18n)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module (guix records)
  #:use-module (guix diagnostics)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt pk-crypto)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:use-module (web uri)
  #:export (narinfo-signature->canonical-sexp

            narinfo?
            narinfo-path
            narinfo-uris
            narinfo-uri-base
            narinfo-compressions
            narinfo-file-hashes
            narinfo-file-sizes
            narinfo-hash
            narinfo-size
            narinfo-references
            narinfo-deriver
            narinfo-system
            narinfo-signature
            narinfo-contents

            narinfo-hash-algorithm+value

            narinfo-hash->sha256
            narinfo-best-uri

            valid-narinfo?

            read-narinfo
            write-narinfo

            string->narinfo
            narinfo->string

            equivalent-narinfo?))

(define-record-type <narinfo>
  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
                 nar-hash nar-size references deriver system
                 signature contents)
  narinfo?
  (path         narinfo-path)
  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
  (uris         narinfo-uris)            ;list of strings
  (compressions narinfo-compressions)    ;list of strings
  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
  (file-hashes  narinfo-file-hashes)
  (nar-hash     narinfo-hash)
  (nar-size     narinfo-size)
  (references   narinfo-references)
  (deriver      narinfo-deriver)
  (system       narinfo-system)
  (signature    narinfo-signature)      ; canonical sexp
  ;; The original contents of a narinfo file.  This field is needed because we
  ;; want to preserve the exact textual representation for verification purposes.
  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
  ;; for more information.
  (contents     narinfo-contents))

(define (narinfo-hash-algorithm+value narinfo)
  "Return two values: the hash algorithm used by NARINFO and its value as a
bytevector."
  (match (string-tokenize (narinfo-hash narinfo)
                          (char-set-complement (char-set #\:)))
    ((algorithm base32)
     (values (lookup-hash-algorithm (string->symbol algorithm))
             (nix-base32-string->bytevector base32)))
    (_
     (raise (formatted-message
             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))

(define (narinfo-hash->sha256 hash)
  "If the string HASH denotes a sha256 hash, return it as a bytevector.
Otherwise return #f."
  (and (string-prefix? "sha256:" hash)
       (nix-base32-string->bytevector (string-drop hash 7))))

(define (narinfo-signature->canonical-sexp str)
  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
  (match (string-split str #\;)
    ((version host-name sig)
     (let ((maybe-number (string->number version)))
       (cond ((not (number? maybe-number))
              (leave (G_ "signature version must be a number: ~s~%")
                     version))
             ;; Currently, there are no other versions.
             ((not (= 1 maybe-number))
              (leave (G_ "unsupported signature version: ~a~%")
                     maybe-number))
             (else
              (let ((signature (utf8->string (base64-decode sig))))
                (catch 'gcry-error
                  (lambda ()
                    (string->canonical-sexp signature))
                  (lambda (key proc err)
                    (leave (G_ "signature is not a valid \
s-expression: ~s~%")
                           signature))))))))
    (x
     (leave (G_ "invalid format of the signature field: ~a~%") x))))

(define (narinfo-maker str cache-url)
  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
must contain the original contents of a narinfo file."
  (lambda (path urls compressions file-hashes file-sizes
                nar-hash nar-size references deriver system
                signature)
    "Return a new <narinfo> object."
    (define len (length urls))
    (%make-narinfo path cache-url
                   ;; Handle the case where URL is a relative URL.
                   (map (lambda (url)
                          (or (string->uri url)
                              (string->uri
                               (string-append cache-url "/" url))))
                        urls)
                   compressions
                   (match file-sizes
                     (()        (make-list len #f))
                     ((lst ...) (map string->number lst)))
                   (match file-hashes
                     (()        (make-list len #f))
                     ((lst ...) (map string->number lst)))
                   nar-hash
                   (and=> nar-size string->number)
                   (string-tokenize references)
                   (match deriver
                     ((or #f "") #f)
                     (_ deriver))
                   system
                   (false-if-exception
                    (and=> signature narinfo-signature->canonical-sexp))
                   str)))

(define fields->alist
  ;; The narinfo format is really just like recutils.
  recutils->alist)

(define* (read-narinfo port #:optional url
                       #:key size)
  "Read a narinfo from PORT.  If URL is true, it must be a string used to
build full URIs from relative URIs found while reading PORT.  When SIZE is
true, read at most SIZE bytes from PORT; otherwise, read as much as possible.

No authentication and authorization checks are performed here!"
  (let ((str (utf8->string (if size
                               (get-bytevector-n port size)
                               (get-bytevector-all port)))))
    (alist->record (call-with-input-string str fields->alist)
                   (narinfo-maker str url)
                   '("StorePath" "URL" "Compression"
                     "FileHash" "FileSize" "NarHash" "NarSize"
                     "References" "Deriver" "System"
                     "Signature")
                   '("URL" "Compression" "FileSize" "FileHash"))))

(define (narinfo-sha256 narinfo)
  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
'Signature' field."
  (define %mandatory-fields
    ;; List of fields that must be signed.  If they are not signed, the
    ;; narinfo is considered unsigned.
    '("StorePath" "NarHash" "References"))

  (let ((contents (narinfo-contents narinfo)))
    (match (string-contains contents "Signature:")
      (#f #f)
      (index
       (let* ((above-signature (string-take contents index))
              (signed-fields (match (call-with-input-string above-signature
                                      fields->alist)
                               (((fields . values) ...) fields))))
         (and (every (cut member <> signed-fields) %mandatory-fields)
              (sha256 (string->utf8 above-signature))))))))

(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
                         #:key verbose?)
  "Return #t if NARINFO's signature is not valid."
  (let ((hash      (narinfo-sha256 narinfo))
        (signature (narinfo-signature narinfo))
        (uri       (uri->string (first (narinfo-uris narinfo)))))
    (and hash signature
         (signature-case (signature hash acl)
           (valid-signature #t)
           (invalid-signature
            (when verbose?
              (format (current-error-port)
                      "invalid signature for substitute at '~a'~%"
                      uri))
            #f)
           (hash-mismatch
            (when verbose?
              (format (current-error-port)
                      "hash mismatch for substitute at '~a'~%"
                      uri))
            #f)
           (unauthorized-key
            (when verbose?
              (format (current-error-port)
                      "substitute at '~a' is signed by an \
unauthorized party~%"
                      uri))
            #f)
           (corrupt-signature
            (when verbose?
              (format (current-error-port)
                      "corrupt signature for substitute at '~a'~%"
                      uri))
            #f)))))

(define (write-narinfo narinfo port)
  "Write NARINFO to PORT."
  (put-bytevector port (string->utf8 (narinfo-contents narinfo))))

(define (narinfo->string narinfo)
  "Return the external representation of NARINFO."
  (call-with-output-string (cut write-narinfo narinfo <>)))

(define (string->narinfo str cache-uri)
  "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
the cache STR originates form."
  (call-with-input-string str (cut read-narinfo <> cache-uri)))

(define (equivalent-narinfo? narinfo1 narinfo2)
  "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe
the same store item.  This ignores unnecessary metadata such as the Nar URL."
  (and (string=? (narinfo-hash narinfo1)
                 (narinfo-hash narinfo2))

       ;; The following is not needed if all we want is to download a valid
       ;; nar, but it's necessary if we want valid narinfo.
       (string=? (narinfo-path narinfo1)
                 (narinfo-path narinfo2))
       (equal? (narinfo-references narinfo1)
               (narinfo-references narinfo2))

       (= (narinfo-size narinfo1)
          (narinfo-size narinfo2))))

(define %compression-methods
  ;; Known compression methods and a thunk to determine whether they're
  ;; supported.  See 'decompressed-port' in (guix utils).
  `(("gzip"  . ,(const #t))
    ("lzip"  . ,(const #t))
    ("zstd"  . ,(lambda ()
                  (resolve-module '(zstd) #t #f #:ensure #f)))
    ("xz"    . ,(const #t))
    ("bzip2" . ,(const #t))
    ("none"  . ,(const #t))))

(define (supported-compression? compression)
  "Return true if COMPRESSION, a string, denotes a supported compression
method."
  (match (assoc-ref %compression-methods compression)
    (#f         #f)
    (supported? (supported?))))

(define (compresses-better? compression1 compression2)
  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
this is a rough approximation."
  (match compression1
    ("none" #f)
    ("gzip" (string=? compression2 "none"))
    ("lzip" #t)
    (_      (or (string=? compression2 "none")
                (string=? compression2 "gzip")))))

(define (decompresses-faster? compression1 compression2)
  "Return true if COMPRESSION1 generally has a higher decompression throughput
than COMPRESSION2."
  (match compression1
    ("none" #t)
    ("zstd" #t)
    ("gzip" (string=? compression2 "lzip"))
    (_      #f)))

(define* (narinfo-best-uri narinfo #:key fast-decompression?)
  "Select the \"best\" URI to download NARINFO's nar, and return three values:
the URI, its compression method (a string), and the compressed file size.
When FAST-DECOMPRESSION? is true, prefer substitutes with faster
decompression (typically zstd) rather than substitutes with a higher
compression ratio (typically lzip)."
  (define choices
    (filter (match-lambda
              ((uri compression file-size)
               (supported-compression? compression)))
            (zip (narinfo-uris narinfo)
                 (narinfo-compressions narinfo)
                 (narinfo-file-sizes narinfo))))

  (define (file-size<? c1 c2)
    (match c1
      ((uri1 compression1 (? integer? file-size1))
       (match c2
         ((uri2 compression2 (? integer? file-size2))
          (< file-size1 file-size2))
         (_ #t)))
      ((uri compression1 #f)
       (match c2
         ((uri2 compression2 _)
          (compresses-better? compression1 compression2))))
      (_ #f)))                                    ;we can't tell

  (define (speed<? c1 c2)
    (match c1
      ((uri1 compression1 . _)
       (match c2
         ((uri2 compression2 . _)
          (decompresses-faster? compression2 compression1))))))

  (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
    (((uri compression file-size) _ ...)
     (values uri compression file-size))))