code:
const config = {
  plugins: ["@tailwindcss/postcss"],
};

export default config;

license: mit


lib: dom dom.iterable esnext

module: esnext

moduleResolution: bundler

jsx: preserve


code:
// types/next-auth.d.ts
import { DefaultSession } from "next-auth";

declare module "next-auth" {
  interface User {
      username?: string;
      password?: string;
      apiKey?: string;
      role?: string;
      expiresAt?: number;
    }
    interface JWT {
      username?: string;
      password?: string;
      apiKey?: string;
      role?: string;
      expiresAt?: number;
    }
    interface Session {
      user: {
        username?: string;
        role?: string;
        apiKey?: string;
    } & DefaultSession['user']
  }
}


code:
*~
.#*
*.go
*.log
*.trs
autom4te.cache/
Makefile
Makefile.in
/configure
/env
/config.status
/config.log
/aclocal.m4
/pre-inst-env
/missing
/test-driver
/install-sh
/gcrypt/package-config.scm
/build-aux/install-sh
/build-aux/missing
/guile-gcrypt-*.tar.gz
/INSTALL
/config.cache

repo_name: aconchillo/guile

path: .gitignore


code:
Guile-Gcrypt was initially written by:

  Christopher Lemmer Webber <cwebber@dustycloud.org>
  Ludovic Courtès <ludo@gnu.org>

… but ‘git log’ may show other names.  In fact, we’d like to see yours
too, consider joining us!

path: AUTHORS


code: Please use ‘git log’.

path: ChangeLog


code:
## Copyright (C) 2015, 2017 Christopher Allan Webber <cwebber@dustycloud.org>

## parts of this automake recipe borrowed from:

## GNU Guix --- Functional package management for GNU
## Copyright © 2012, 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
## Copyright © 2013 Andreas Enge <andreas@enge.fr>
## Copyright © 2015 Alex Kost <alezost@gmail.com>

## Sly
## Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>

## This program is free software: you can redistribute it and/or
## modify it under the terms of the GNU General Public License as
## published by the Free Software Foundation, either version 3 of the
## License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
## General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program.  If not, see
## <http://www.gnu.org/licenses/>.

GOBJECTS = $(SOURCES:%.scm=%.go)
nobase_mod_DATA = $(SOURCES)
nobase_go_DATA = $(GOBJECTS)

# Make sure source files are installed first, so that the mtime of
# installed compiled files is greater than that of installed source
# files.  See
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
# for details.
guile_install_go_files = install-nobase_goDATA
$(guile_install_go_files): install-nobase_modDATA

GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
SUFFIXES = .scm .go
.scm.go:
	$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILD) \
	  compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<"

moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache

SOURCES =					\
	gcrypt/base16.scm			\
	gcrypt/base64.scm			\
	gcrypt/common.scm			\
	gcrypt/hash.scm				\
	gcrypt/hmac.scm				\
	gcrypt/internal.scm			\
	gcrypt/mac.scm				\
	gcrypt/package-config.scm		\
	gcrypt/pk-crypto.scm			\
	gcrypt/random.scm			\
	gcrypt/utils.scm

TESTS =						\
	tests/base16.scm			\
	tests/base64.scm			\
	tests/hash.scm				\
	tests/hmac.scm				\
	tests/mac.scm				\
	tests/pk-crypto.scm

TEST_EXTENSIONS = .scm

SCM_LOG_DRIVER =				\
	$(top_builddir)/pre-inst-env		\
	$(GUILE) --no-auto-compile -e main	\
	$(top_srcdir)/build-aux/test-driver.scm

# Tell 'build-aux/test-driver.scm' to display only source file names,
# not indivdual test names.
AM_SCM_LOG_DRIVER_FLAGS = --brief=yes

AM_SCM_LOG_FLAGS = --no-auto-compile -L $(top_srcdir)

CLEANFILES = 						\
	$(GOBJECTS)					\
	$(TESTS:tests/%.scm=%.log)			\
	*.log *.tar.gz

EXTRA_DIST = 						\
	$(SOURCES)					\
	$(TESTS)					\
        guix.scm					\
	build-aux/test-driver.scm			\
	pre-inst-env.in

info_TEXINFOS = guile-gcrypt.texi
guile_gcrypt_TEXINFOS = fdl-1.3.texi


code:
                                                              -*- org -*-
#+TITLE: Guile-Gcrypt NEWS – history of user-visible changes
#+STARTUP: content hidestars

Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>

  Copying and distribution of this file, with or without modification,
  are permitted in any medium without royalty provided the copyright
  notice and this notice are preserved.

Run “info guile-gcrypt” for details about the changes described below.
Please send Guix bug reports to <https://notabug.org/cwebber/guile-gcrypt>.

* Changes in 0.3.0 (since 0.2.1)
** ‘sexp->canonical-sexp->sexp’ now accepts integers
** (gcrypt common) exports ‘error/’ constants and error handling procedures
** ‘verify’ now throws upon errors other than ‘error/bad-signature’
** (gcrypt hmac) and (gcrypt hash) export bindings for their syntax literals
** New ‘hash-algorithm-name’ and ‘mac-algorithm-name’ procedures

* Changes in 0.2.1 (since 0.2.0)

** libgcrypt is now always properly initialized (https://bugs.gnu.org/37616)
** (gcrypt base64) no longer imports (rnrs)

* Changes in 0.2.0 (since 0.1.0)

** (gcrypt hash) now exposes all the algorithms supported by Libgcrypt
** (guix mac) now exposes all the MAC algorithms, not just HMAC
** (guix hmac) is deprecated in favor of (guix mac)
** Guile-Gcrypt can now be compiled with Guile 2.9 (future 3.0)
** Guile-Gcrypt can now be cross-compiled

path: NEWS


code:
Guile-Gcrypt — Guile bindings to Libgcrypt
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Guile-Gcrypt provides a Guile 3.x/2.x interface to a subset of the
GNU Libgcrypt crytographic library, which is itself used by the
GNU Privacy Guard (GPG).

Guile-Gcrypt provides modules for cryptographic hash functions,
message authentication codes (MAC), public-key cryptography, strong
randomness, and more.  It is implemented using the foreign function
interface (FFI) of Guile.

Requirements:

  • GNU Guile 3.x or 2.x >= 2.0.10, https://gnu.org/software/guile/
  • GNU Libgcrypt 1.8.x or later, https://gnupg.org/

For more information, patches, bug reports, and all that, see:

  https://notabug.org/cwebber/guile-gcrypt

path: README


code:
#!/bin/sh

autoreconf -vif


code:
;;;; test-driver.scm - Guile test driver for Automake testsuite harness

(define script-version "2017-03-22.13") ;UTC

;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;;; Commentary:
;;;
;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
;;; test suites.  SRFI-64 is distributed with Guile since version 2.0.9.
;;;
;;;; Code:

(use-modules (ice-9 getopt-long)
             (ice-9 pretty-print)
             (srfi srfi-26)
             (srfi srfi-64))

(define (show-help)
  (display "Usage:
   test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
               [--expect-failure={yes|no}] [--color-tests={yes|no}]
               [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
               TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))

(define %options
  '((test-name                 (value #t))
    (log-file                  (value #t))
    (trs-file                  (value #t))
    (color-tests               (value #t))
    (expect-failure            (value #t)) ;XXX: not implemented yet
    (enable-hard-errors        (value #t)) ;not implemented in SRFI-64
    (brief                     (value #t))
    (help    (single-char #\h) (value #f))
    (version (single-char #\V) (value #f))))

(define (option->boolean options key)
  "Return #t if the value associated with KEY in OPTIONS is \"yes\"."
  (and=> (option-ref options key #f) (cut string=? <> "yes")))

(define* (test-display field value  #:optional (port (current-output-port))
                       #:key pretty?)
  "Display \"FIELD: VALUE\\n\" on PORT."
  (if pretty?
      (begin
        (format port "~A:~%" field)
        (pretty-print value port #:per-line-prefix "+ "))
      (format port "~A: ~S~%" field value)))

(define* (result->string symbol #:key colorize?)
  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
  (let ((result (string-upcase (symbol->string symbol))))
    (if colorize?
        (string-append (case symbol
                         ((pass)       "")  ;green
                         ((xfail)      "")  ;light green
                         ((skip)       "")  ;blue
                         ((fail xpass) "")  ;red
                         ((error)      "")) ;magenta
                       result
                       "")          ;no color
        result)))

(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
  "Return an custom SRFI-64 test runner.  TEST-NAME is a string specifying the
file name of the current the test.  COLOR? specifies whether to use colors,
and BRIEF?, well, you know.  OUT-PORT and TRS-PORT must be output ports.  The
current output port is supposed to be redirected to a '.log' file."

  (define (test-on-test-begin-gnu runner)
    ;; Procedure called at the start of an individual test case, before the
    ;; test expression (and expected value) are evaluated.
    (let ((result (cute assq-ref (test-result-alist runner) <>)))
      (format #t "test-name: ~A~%" (result 'test-name))
      (format #t "location: ~A~%"
              (string-append (result 'source-file) ":"
                             (number->string (result 'source-line))))
      (test-display "source" (result 'source-form) #:pretty? #t)))

  (define (test-on-test-end-gnu runner)
    ;; Procedure called at the end of an individual test case, when the result
    ;; of the test is available.
    (let* ((results (test-result-alist runner))
           (result? (cut assq <> results))
           (result  (cut assq-ref results <>)))
      (unless brief?
        ;; Display the result of each test case on the console.
        (format out-port "~A: ~A - ~A~%"
                (result->string (test-result-kind runner) #:colorize? color?)
                test-name (test-runner-test-name runner)))
      (when (result? 'expected-value)
        (test-display "expected-value" (result 'expected-value)))
      (when (result? 'expected-error)
        (test-display "expected-error" (result 'expected-error) #:pretty? #t))
      (when (result? 'actual-value)
        (test-display "actual-value" (result 'actual-value)))
      (when (result? 'actual-error)
        (test-display "actual-error" (result 'actual-error) #:pretty? #t))
      (format #t "result: ~a~%" (result->string (result 'result-kind)))
      (newline)
      (format trs-port ":test-result: ~A ~A~%"
              (result->string (test-result-kind runner))
              (test-runner-test-name runner))))

  (define (test-on-group-end-gnu runner)
    ;; Procedure called by a 'test-end', including at the end of a test-group.
    (let ((fail (or (positive? (test-runner-fail-count runner))
                    (positive? (test-runner-xpass-count runner))))
          (skip (or (positive? (test-runner-skip-count runner))
                    (positive? (test-runner-xfail-count runner)))))
      ;; XXX: The global results need some refinements for XPASS.
      (format trs-port ":global-test-result: ~A~%"
              (if fail "FAIL" (if skip "SKIP" "PASS")))
      (format trs-port ":recheck: ~A~%"
              (if fail "yes" "no"))
      (format trs-port ":copy-in-global-log: ~A~%"
              (if (or fail skip) "yes" "no"))
      (when brief?
        ;; Display the global test group result on the console.
        (format out-port "~A: ~A~%"
                (result->string (if fail 'fail (if skip 'skip 'pass))
                                #:colorize? color?)
                test-name))
      #f))

  (let ((runner (test-runner-null)))
    (test-runner-on-test-begin! runner test-on-test-begin-gnu)
    (test-runner-on-test-end! runner test-on-test-end-gnu)
    (test-runner-on-group-end! runner test-on-group-end-gnu)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))

;;;
;;; Entry point.
;;;

(define (main . args)
  (let* ((opts   (getopt-long (command-line) %options))
         (option (cut option-ref opts <> <>)))
    (cond
     ((option 'help #f)    (show-help))
     ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
     (else
      (let ((log (open-file (option 'log-file "") "w0"))
            (trs (open-file (option 'trs-file "") "wl"))
            (out (duplicate-port (current-output-port) "wl")))
        (redirect-port log (current-output-port))
        (redirect-port log (current-warning-port))
        (redirect-port log (current-error-port))
        (test-with-runner
            (test-runner-gnu (option 'test-name #f)
                             #:color? (option->boolean opts 'color-tests)
                             #:brief? (option->boolean opts 'brief)
                             #:out-port out #:trs-port trs)
          (load-from-path (option 'test-name #f)))
        (close-port log)
        (close-port trs)
        (close-port out))))
    (exit 0)))

;;; Local Variables:
;;; eval: (add-hook 'write-file-functions 'time-stamp)
;;; time-stamp-start: "(define script-version \""
;;; time-stamp-format: "%:y-%02m-%02d.%02H"
;;; time-stamp-time-zone: "UTC"
;;; time-stamp-end: "\") ;UTC"
;;; End:

;;;; test-driver.scm ends here.


code:
AC_INIT([Guile-Gcrypt], [0.3.0], [guile-user@gnu.org],
  [guile-gcrypt], [https://notabug.org/cwebber/guile-gcrypt])

AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])

AM_INIT_AUTOMAKE([-Wall -Werror gnu])
AM_SILENT_RULES([yes])

dnl We require guile.m4, from Guile.  Make sure it's available.
m4_pattern_forbid([^GUILE_P])
m4_pattern_allow([^GUILE_PKG_ERRORS])

GUILE_PKG([3.0 2.2 2.0])
GUILE_PROGS

AC_CONFIG_FILES([Makefile gcrypt/package-config.scm])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])

dnl Prepare a version of $datadir that does not contain references to
dnl shell variables.  (Borrowed from Sly, which borrowed from Guix...)
guile_gcrypt_prefix="`eval echo $prefix | sed -e"s|NONE|/usr/local|g"`"
guile_gcrypt_datadir="`eval eval echo $datadir | sed -e "s|NONE|$guile_gcrypt_prefix|g"`"
AC_SUBST([guile_gcrypt_datadir])

LIBGCRYPT="libgcrypt"
LIBGCRYPT_LIBDIR="no"
LIBGCRYPT_PREFIX="no"

AC_ARG_WITH([libgcrypt-prefix],
  [AS_HELP_STRING([--with-libgcrypt-prefix=DIR], [search for GNU libgcrypt in DIR])],
  [case "$withval" in
    yes|no)
      ;;
    *)
      LIBGCRYPT="$withval/lib/libgcrypt"
      LIBGCRYPT_PREFIX="$withval"
      LIBGCRYPT_LIBDIR="$withval/lib"
      ;;
   esac])

AC_ARG_WITH([libgcrypt-libdir],
  [AS_HELP_STRING([--with-libgcrypt-libdir=DIR],
     [search for GNU libgcrypt's shared library in DIR])],
  [case "$withval" in
    yes|no)
      LIBGCRYPT="libgcrypt"
      LIBGCRYPT_LIBDIR="no"
      ;;
    *)
      LIBGCRYPT="$withval/libgcrypt"
      LIBGCRYPT_LIBDIR="$withval"
      ;;
   esac])

dnl If none of the --with-libgcrypt-* options was used, try to determine the
dnl absolute file name of libgcrypt.so.
case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in
  xnono)
    GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR])
    if test "x$LIBGCRYPT_LIBDIR" != x; then
      LIBGCRYPT="$LIBGCRYPT_LIBDIR/libgcrypt"
    else
      dnl 'config-daemon.ac' expects "no" in this case.
      LIBGCRYPT_LIBDIR="no"
    fi
    ;;
esac

dnl Library name suitable for `dynamic-link'.
AC_MSG_CHECKING([for libgcrypt shared library name])
AC_MSG_RESULT([$LIBGCRYPT])
AC_SUBST([LIBGCRYPT])
AC_SUBST([LIBGCRYPT_PREFIX])
AC_SUBST([LIBGCRYPT_LIBDIR])

if test "$cross_compiling" = "no"; then
   GUIX_ASSERT_LIBGCRYPT_USABLE
else
   GUILE_TARGET="--target=$host_alias"
   AC_SUBST([GUILE_TARGET])
fi

AC_OUTPUT


code:
@c The GNU Free Documentation License.
@center Version 1.3, 3 November 2008

@c This file is intended to be included within another document,
@c hence no sectioning command or @node.

@display
Copyright @copyright{} 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
@uref{http://fsf.org/}

Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@end display

@enumerate 0
@item
PREAMBLE

The purpose of this License is to make a manual, textbook, or other
functional and useful document @dfn{free} in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or noncommercially.
Secondarily, this License preserves for the author and publisher a way
to get credit for their work, while not being considered responsible
for modifications made by others.

This License is a kind of ``copyleft'', which means that derivative
works of the document must themselves be free in the same sense.  It
complements the GNU General Public License, which is a copyleft
license designed for free software.

We have designed this License in order to use it for manuals for free
software, because free software needs free documentation: a free
program should come with manuals providing the same freedoms that the
software does.  But this License is not limited to software manuals;
it can be used for any textual work, regardless of subject matter or
whether it is published as a printed book.  We recommend this License
principally for works whose purpose is instruction or reference.

@item
APPLICABILITY AND DEFINITIONS

This License applies to any manual or other work, in any medium, that
contains a notice placed by the copyright holder saying it can be
distributed under the terms of this License.  Such a notice grants a
world-wide, royalty-free license, unlimited in duration, to use that
work under the conditions stated herein.  The ``Document'', below,
refers to any such manual or work.  Any member of the public is a
licensee, and is addressed as ``you''.  You accept the license if you
copy, modify or distribute the work in a way requiring permission
under copyright law.

A ``Modified Version'' of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.

A ``Secondary Section'' is a named appendix or a front-matter section
of the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall
subject (or to related matters) and contains nothing that could fall
directly within that overall subject.  (Thus, if the Document is in
part a textbook of mathematics, a Secondary Section may not explain
any mathematics.)  The relationship could be a matter of historical
connection with the subject or with related matters, or of legal,
commercial, philosophical, ethical or political position regarding
them.

The ``Invariant Sections'' are certain Secondary Sections whose titles
are designated, as being those of Invariant Sections, in the notice
that says that the Document is released under this License.  If a
section does not fit the above definition of Secondary then it is not
allowed to be designated as Invariant.  The Document may contain zero
Invariant Sections.  If the Document does not identify any Invariant
Sections then there are none.

The ``Cover Texts'' are certain short passages of text that are listed,
as Front-Cover Texts or Back-Cover Texts, in the notice that says that
the Document is released under this License.  A Front-Cover Text may
be at most 5 words, and a Back-Cover Text may be at most 25 words.

A ``Transparent'' copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images composed of
pixels) generic paint programs or (for drawings) some widely available
drawing editor, and that is suitable for input to text formatters or
for automatic translation to a variety of formats suitable for input
to text formatters.  A copy made in an otherwise Transparent file
format whose markup, or absence of markup, has been arranged to thwart
or discourage subsequent modification by readers is not Transparent.
An image format is not Transparent if used for any substantial amount
of text.  A copy that is not ``Transparent'' is called ``Opaque''.

Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, La@TeX{} input
format, SGML or XML using a publicly available
DTD, and standard-conforming simple HTML,
PostScript or PDF designed for human modification.  Examples
of transparent image formats include PNG, XCF and
JPG.  Opaque formats include proprietary formats that can be
read and edited only by proprietary word processors, SGML or
XML for which the DTD and/or processing tools are
not generally available, and the machine-generated HTML,
PostScript or PDF produced by some word processors for
output purposes only.

The ``Title Page'' means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the material
this License requires to appear in the title page.  For works in
formats which do not have any title page as such, ``Title Page'' means
the text near the most prominent appearance of the work's title,
preceding the beginning of the body of the text.

The ``publisher'' means any person or entity that distributes copies
of the Document to the public.

A section ``Entitled XYZ'' means a named subunit of the Document whose
title either is precisely XYZ or contains XYZ in parentheses following
text that translates XYZ in another language.  (Here XYZ stands for a
specific section name mentioned below, such as ``Acknowledgements'',
``Dedications'', ``Endorsements'', or ``History''.)  To ``Preserve the Title''
of such a section when you modify the Document means that it remains a
section ``Entitled XYZ'' according to this definition.

The Document may include Warranty Disclaimers next to the notice which
states that this License applies to the Document.  These Warranty
Disclaimers are considered to be included by reference in this
License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and has
no effect on the meaning of this License.

@item
VERBATIM COPYING

You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License applies
to the Document are reproduced in all copies, and that you add no other
conditions whatsoever to those of this License.  You may not use
technical measures to obstruct or control the reading or further
copying of the copies you make or distribute.  However, you may accept
compensation in exchange for copies.  If you distribute a large enough
number of copies you must also follow the conditions in section 3.

You may also lend copies, under the same conditions stated above, and
you may publicly display copies.

@item
COPYING IN QUANTITY

If you publish printed copies (or copies in media that commonly have
printed covers) of the Document, numbering more than 100, and the
Document's license notice requires Cover Texts, you must enclose the
copies in covers that carry, clearly and legibly, all these Cover
Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
the back cover.  Both covers must also clearly and legibly identify
you as the publisher of these copies.  The front cover must present
the full title with all words of the title equally prominent and
visible.  You may add other material on the covers in addition.
Copying with changes limited to the covers, as long as they preserve
the title of the Document and satisfy these conditions, can be treated
as verbatim copying in other respects.

If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto adjacent
pages.

If you publish or distribute Opaque copies of the Document numbering
more than 100, you must either include a machine-readable Transparent
copy along with each Opaque copy, or state in or with each Opaque copy
a computer-network location from which the general network-using
public has access to download using public-standard network protocols
a complete Transparent copy of the Document, free of added material.
If you use the latter option, you must take reasonably prudent steps,
when you begin distribution of Opaque copies in quantity, to ensure
that this Transparent copy will remain thus accessible at the stated
location until at least one year after the last time you distribute an
Opaque copy (directly or through your agents or retailers) of that
edition to the public.

It is requested, but not required, that you contact the authors of the
Document well before redistributing any large number of copies, to give
them a chance to provide you with an updated version of the Document.

@item
MODIFICATIONS

You may copy and distribute a Modified Version of the Document under
the conditions of sections 2 and 3 above, provided that you release
the Modified Version under precisely this License, with the Modified
Version filling the role of the Document, thus licensing distribution
and modification of the Modified Version to whoever possesses a copy
of it.  In addition, you must do these things in the Modified Version:

@enumerate A
@item
Use in the Title Page (and on the covers, if any) a title distinct
from that of the Document, and from those of previous versions
(which should, if there were any, be listed in the History section
of the Document).  You may use the same title as a previous version
if the original publisher of that version gives permission.

@item
List on the Title Page, as authors, one or more persons or entities
responsible for authorship of the modifications in the Modified
Version, together with at least five of the principal authors of the
Document (all of its principal authors, if it has fewer than five),
unless they release you from this requirement.

@item
State on the Title page the name of the publisher of the
Modified Version, as the publisher.

@item
Preserve all the copyright notices of the Document.

@item
Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.

@item
Include, immediately after the copyright notices, a license notice
giving the public permission to use the Modified Version under the
terms of this License, in the form shown in the Addendum below.

@item
Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.

@item
Include an unaltered copy of this License.

@item
Preserve the section Entitled ``History'', Preserve its Title, and add
to it an item stating at least the title, year, new authors, and
publisher of the Modified Version as given on the Title Page.  If
there is no section Entitled ``History'' in the Document, create one
stating the title, year, authors, and publisher of the Document as
given on its Title Page, then add an item describing the Modified
Version as stated in the previous sentence.

@item
Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise
the network locations given in the Document for previous versions
it was based on.  These may be placed in the ``History'' section.
You may omit a network location for a work that was published at
least four years before the Document itself, or if the original
publisher of the version it refers to gives permission.

@item
For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
the Title of the section, and preserve in the section all the
substance and tone of each of the contributor acknowledgements and/or
dedications given therein.

@item
Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles.  Section numbers
or the equivalent are not considered part of the section titles.

@item
Delete any section Entitled ``Endorsements''.  Such a section
may not be included in the Modified Version.

@item
Do not retitle any existing section to be Entitled ``Endorsements'' or
to conflict in title with any Invariant Section.

@item
Preserve any Warranty Disclaimers.
@end enumerate

If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no material
copied from the Document, you may at your option designate some or all
of these sections as invariant.  To do this, add their titles to the
list of Invariant Sections in the Modified Version's license notice.
These titles must be distinct from any other section titles.

You may add a section Entitled ``Endorsements'', provided it contains
nothing but endorsements of your Modified Version by various
parties---for example, statements of peer review or that the text has
been approved by an organization as the authoritative definition of a
standard.

You may add a passage of up to five words as a Front-Cover Text, and a
passage of up to 25 words as a Back-Cover Text, to the end of the list
of Cover Texts in the Modified Version.  Only one passage of
Front-Cover Text and one of Back-Cover Text may be added by (or
through arrangements made by) any one entity.  If the Document already
includes a cover text for the same cover, previously added by you or
by arrangement made by the same entity you are acting on behalf of,
you may not add another; but you may replace the old one, on explicit
permission from the previous publisher that added the old one.

The author(s) and publisher(s) of the Document do not by this License
give permission to use their names for publicity for or to assert or
imply endorsement of any Modified Version.

@item
COMBINING DOCUMENTS

You may combine the Document with other documents released under this
License, under the terms defined in section 4 above for modified
versions, provided that you include in the combination all of the
Invariant Sections of all of the original documents, unmodified, and
list them all as Invariant Sections of your combined work in its
license notice, and that you preserve all their Warranty Disclaimers.

The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy.  If there are multiple Invariant Sections with the same name but
different contents, make the title of each such section unique by
adding at the end of it, in parentheses, the name of the original
author or publisher of that section if known, or else a unique number.
Make the same adjustment to the section titles in the list of
Invariant Sections in the license notice of the combined work.

In the combination, you must combine any sections Entitled ``History''
in the various original documents, forming one section Entitled
``History''; likewise combine any sections Entitled ``Acknowledgements'',
and any sections Entitled ``Dedications''.  You must delete all
sections Entitled ``Endorsements.''

@item
COLLECTIONS OF DOCUMENTS

You may make a collection consisting of the Document and other documents
released under this License, and replace the individual copies of this
License in the various documents with a single copy that is included in
the collection, provided that you follow the rules of this License for
verbatim copying of each of the documents in all other respects.

You may extract a single document from such a collection, and distribute
it individually under this License, provided you insert a copy of this
License into the extracted document, and follow this License in all
other respects regarding verbatim copying of that document.

@item
AGGREGATION WITH INDEPENDENT WORKS

A compilation of the Document or its derivatives with other separate
and independent documents or works, in or on a volume of a storage or
distribution medium, is called an ``aggregate'' if the copyright
resulting from the compilation is not used to limit the legal rights
of the compilation's users beyond what the individual works permit.
When the Document is included in an aggregate, this License does not
apply to the other works in the aggregate which are not themselves
derivative works of the Document.

If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half of
the entire aggregate, the Document's Cover Texts may be placed on
covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic form.
Otherwise they must appear on printed covers that bracket the whole
aggregate.

@item
TRANSLATION

Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section 4.
Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections.  You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also include
the original English version of this License and the original versions
of those notices and disclaimers.  In case of a disagreement between
the translation and the original version of this License or a notice
or disclaimer, the original version will prevail.

If a section in the Document is Entitled ``Acknowledgements'',
``Dedications'', or ``History'', the requirement (section 4) to Preserve
its Title (section 1) will typically require changing the actual
title.

@item
TERMINATION

You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense, or distribute it is void, and
will automatically terminate your rights under this License.

However, if you cease all violation of this License, then your license
from a particular copyright holder is reinstated (a) provisionally,
unless and until the copyright holder explicitly and finally
terminates your license, and (b) permanently, if the copyright holder
fails to notify you of the violation by some reasonable means prior to
60 days after the cessation.

Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.

Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License.  If your rights have been terminated and not permanently
reinstated, receipt of a copy of some or all of the same material does
not give you any rights to use it.

@item
FUTURE REVISIONS OF THIS LICENSE

The Free Software Foundation may publish new, revised versions
of the GNU Free Documentation License from time to time.  Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.  See
@uref{http://www.gnu.org/copyleft/}.

Each version of the License is given a distinguishing version number.
If the Document specifies that a particular numbered version of this
License ``or any later version'' applies to it, you have the option of
following the terms and conditions either of that specified version or
of any later version that has been published (not as a draft) by the
Free Software Foundation.  If the Document does not specify a version
number of this License, you may choose any version ever published (not
as a draft) by the Free Software Foundation.  If the Document
specifies that a proxy can decide which future versions of this
License can be used, that proxy's public statement of acceptance of a
version permanently authorizes you to choose that version for the
Document.

@item
RELICENSING

``Massive Multiauthor Collaboration Site'' (or ``MMC Site'') means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works.  A
public wiki that anybody can edit is an example of such a server.  A
``Massive Multiauthor Collaboration'' (or ``MMC'') contained in the
site means any set of copyrightable works thus published on the MMC
site.

``CC-BY-SA'' means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.

``Incorporate'' means to publish or republish a Document, in whole or
in part, as part of another Document.

An MMC is ``eligible for relicensing'' if it is licensed under this
License, and if all works that were first published under this License
somewhere other than this MMC, and subsequently incorporated in whole
or in part into the MMC, (1) had no cover texts or invariant sections,
and (2) were thus incorporated prior to November 1, 2008.

The operator of an MMC Site may republish an MMC contained in the site
under CC-BY-SA on the same site at any time before August 1, 2009,
provided the MMC is eligible for relicensing.

@end enumerate

@page
@heading ADDENDUM: How to use this License for your documents

To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and
license notices just after the title page:

@smallexample
@group
  Copyright (C)  @var{year}  @var{your name}.
  Permission is granted to copy, distribute and/or modify this document
  under the terms of the GNU Free Documentation License, Version 1.3
  or any later version published by the Free Software Foundation;
  with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
  Texts.  A copy of the license is included in the section entitled ``GNU
  Free Documentation License''.
@end group
@end smallexample

If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
replace the ``with@dots{}Texts.''@: line with this:

@smallexample
@group
    with the Invariant Sections being @var{list their titles}, with
    the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
    being @var{list}.
@end group
@end smallexample

If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.

If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License,
to permit their use in free software.

@c Local Variables:
@c ispell-local-pdict: "ispell-dict"
@c End:


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2012, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt base16)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 format)
  #:export (bytevector->base16-string
            base16-string->bytevector))

;;;
;;; Base 16.
;;;

(define (bytevector->base16-string bv)
  "Return the hexadecimal representation of BV's contents."
  (define len
    (bytevector-length bv))

  (let-syntax ((base16-chars (lambda (s)
                               (syntax-case s ()
                                 (_
                                  (let ((v (list->vector
                                            (unfold (cut > <> 255)
                                                    (lambda (n)
                                                      (format #f "~2,'0x" n))
                                                    1+
                                                    0))))
                                    v))))))
    (define chars base16-chars)
    (let loop ((i len)
               (r '()))
      (if (zero? i)
          (string-concatenate r)
          (let ((i (- i 1)))
            (loop i
                  (cons (vector-ref chars (bytevector-u8-ref bv i)) r)))))))

(define base16-string->bytevector
  (let ((chars->value (fold (lambda (i r)
                              (vhash-consv (string-ref (number->string i 16)
                                                       0)
                                           i r))
                            vlist-null
                            (iota 16))))
    (lambda (s)
      "Return the bytevector whose hexadecimal representation is string S."
      (define bv
        (make-bytevector (quotient (string-length s) 2) 0))

      (string-fold (lambda (chr i)
                     (let ((j (quotient i 2))
                           (v (and=> (vhash-assv chr chars->value) cdr)))
                       (if v
                           (if (zero? (logand i 1))
                               (bytevector-u8-set! bv j
                                                   (arithmetic-shift v 4))
                               (let ((w (bytevector-u8-ref bv j)))
                                 (bytevector-u8-set! bv j (logior v w))))
                           (error "invalid hexadecimal character" chr)))
                     (+ i 1))
                   0
                   s)
      bv)))


code:
;; -*- mode: scheme; coding: utf-8 -*-
;;
;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
;; February 12, 2014.  It was later renamed to (gcrypt base64) by
;; Christopher Allan Webber <cwebber@dustycloud.org> on May 20, 2017.
;;
;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
;; Turned into a Guile module (instead of R6RS).
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; This file incorporates work covered by the following copyright and
;; permission notice:
;;
;;   Copyright © 2009, 2010, 2012, 2013, 2018 Göran Weinholt <goran@weinholt.se>
;;
;;   Permission is hereby granted, free of charge, to any person obtaining a
;;   copy of this software and associated documentation files (the "Software"),
;;   to deal in the Software without restriction, including without limitation
;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;   and/or sell copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following conditions:
;;
;;   The above copyright notice and this permission notice shall be included in
;;   all copies or substantial portions of the Software.
;;
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;   DEALINGS IN THE SOFTWARE.

;; RFC 4648 Base-N Encodings

(define-module (gcrypt base64)
  #:export (base64-encode
            base64-decode
            base64-alphabet
            base64url-alphabet
            get-delimited-base64
            put-delimited-base64)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

(define-syntax define-alias
  (syntax-rules ()
    ((_ new old)
     (define-syntax new (identifier-syntax old)))))

;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
;; procedures.

(define-alias fxbit-field bit-field)
(define-alias fxarithmetic-shift ash)
(define-alias fxarithmetic-shift-left ash)
(define-alias fxand logand)
(define-alias fxior logior)
(define-alias fxxor logxor)
(define-alias fx=? =)
(define-alias fx<=? <=)
(define-alias fxzero? zero?)
(define-alias fx+ +)
(define-alias fx- -)
(define-alias fxmod modulo)
(define-alias mod modulo)

(define-syntax-rule (assert exp)
  (unless exp
    (throw 'assertion-failure 'exp)))

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

(define base64url-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define base64-encode
  (case-lambda
    ;; Simple interface. Returns a string containing the canonical
    ;; base64 representation of the given bytevector.
    ((bv)
     (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start)
     (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start end)
     (base64-encode bv start end #f #f base64-alphabet #f))
    ((bv start end line-length)
     (base64-encode bv start end line-length #f base64-alphabet #f))
    ((bv start end line-length no-padding)
     (base64-encode bv start end line-length no-padding base64-alphabet #f))
    ((bv start end line-length no-padding alphabet)
     (base64-encode bv start end line-length no-padding alphabet #f))
    ;; Base64 encodes the bytes [start,end[ in the given bytevector.
    ;; Lines are limited to line-length characters (unless #f),
    ;; which must be a multiple of four. To omit the padding
    ;; characters (#\=) set no-padding to a true value. If port is
    ;; #f, returns a string.
    ((bv start end line-length no-padding alphabet port)
     (assert (or (not line-length) (zero? (mod line-length 4))))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-string-output-port))))
       (letrec ((put (if line-length
                         (let ((chars 0))
                           (lambda (p c)
                             (when (fx=? chars line-length)
                               (set! chars 0)
                               (put-char p #\linefeed))
                             (set! chars (fx+ chars 1))
                             (put-char p c)))
                         put-char)))
         (let lp ((i start))
           (cond ((= i end))
                 ((<= (+ i 3) end)
                  (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (put p (string-ref alphabet (fxbit-field x 0 6)))
                    (lp (+ i 3))))
                 ((<= (+ i 2) end)
                  (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (unless no-padding
                      (put p #\=))))
                 (else
                  (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (unless no-padding
                      (put p #\=)
                      (put p #\=)))))))
       (extract)))))

;; Create a lookup table for the alphabet and remember the latest table.
(define get-decode-table
  (let ((ascii-table #f)
        (extra-table '())     ;in the unlikely case of unicode chars
        (table-alphabet #f))
    (lambda (alphabet)
      (unless (eq? alphabet table-alphabet)
        ;; Rebuild the table.
        (do ((ascii (make-vector 128 #f))
             (extra '())
             (i 0 (+ i 1)))
            ((= i (string-length alphabet))
             (set! ascii-table ascii)
             (set! extra-table extra))
          (let ((c (char->integer (string-ref alphabet i))))
            (if (fx<=? c 127)
                (vector-set! ascii c i)
                (set! extra (cons (cons c i) extra)))))
        (set! table-alphabet alphabet))
      (values ascii-table extra-table))))

;; Decodes a base64 string, optionally ignoring non-alphabet
;; characters and lack of padding.
(define base64-decode
  (case-lambda
    ((str)
     (base64-decode str base64-alphabet #f))
    ((str alphabet)
     (base64-decode str alphabet #f))
    ((str alphabet port)
     (base64-decode str alphabet port #t))
    ((str alphabet port strict?)
     (base64-decode str alphabet port strict? #t))
    ((str alphabet port strict? strict-padding?)
     (define (pad? c) (eqv? c (char->integer #\=)))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-bytevector-output-port)))
                  ((ascii extra) (get-decode-table alphabet)))
       (define-syntax lookup
         (syntax-rules ()
           ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c))
                      (cond ((assv c extra) => cdr)
                            (else #f))))))
       (let lp-restart ((str str))
         (let* ((len (if strict?
                         (string-length str)
                         (let lp ((i (fx- (string-length str) 1)))
                           ;; Skip trailing invalid chars.
                           (cond ((fxzero? i) 0)
                                 ((let ((c (char->integer (string-ref str i))))
                                    (or (lookup c) (pad? c)))
                                  (fx+ i 1))
                                 (else (lp (fx- i 1))))))))
           (let lp ((i 0))
             (cond
              ((fx=? i len)
               (extract))
              ((fx<=? i (fx- len 4))
               (let lp* ((c1 (char->integer (string-ref str i)))
                         (c2 (char->integer (string-ref str (fx+ i 1))))
                         (c3 (char->integer (string-ref str (fx+ i 2))))
                         (c4 (char->integer (string-ref str (fx+ i 3))))
                         (i i))
                 (let ((i1 (lookup c1)) (i2 (lookup c2))
                       (i3 (lookup c3)) (i4 (lookup c4)))
                   (cond
                    ((and i1 i2 i3 i4)
                     ;; All characters present and accounted for.
                     ;; The most common case.
                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                     (fxarithmetic-shift-left i2 12)
                                     (fxarithmetic-shift-left i3 6)
                                     i4)))
                       (put-u8 p (fxbit-field x 16 24))
                       (put-u8 p (fxbit-field x 8 16))
                       (put-u8 p (fxbit-field x 0 8))
                       (lp (fx+ i 4))))
                    ((and i1 i2 i3 (pad? c4) (= i (- len 4)))
                     ;; One padding character at the end of the input.
                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                     (fxarithmetic-shift-left i2 12)
                                     (fxarithmetic-shift-left i3 6))))
                       (put-u8 p (fxbit-field x 16 24))
                       (put-u8 p (fxbit-field x 8 16))
                       (lp (fx+ i 4))))
                    ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4)))
                     ;; Two padding characters.
                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                     (fxarithmetic-shift-left i2 12))))
                       (put-u8 p (fxbit-field x 16 24))
                       (lp (fx+ i 4))))
                    ((not strict?)
                     ;; Non-alphabet characters.
                     (let lp ((i i) (c* '()) (n 4))
                       (cond ((fxzero? n)
                              ;; Found four valid characters.
                              (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*)
                                   (fx- i 4)))
                             ((fx=? i len)
                              (error 'base64-decode
                                     "Invalid input in non-strict mode."
                                     i c*))
                             (else
                              ;; Gather alphabetic (or valid
                              ;; padding) characters.
                              (let ((c (char->integer (string-ref str i))))
                                (cond ((or (lookup c)
                                           (and (pad? c)
                                                (fx<=? n 2)
                                                (fx=? i (fx- len n))))
                                       (lp (fx+ i 1) (cons c c*) (fx- n 1)))
                                      (else
                                       (lp (fx+ i 1) c* n))))))))
                    (else
                     (error 'base64-decode
                            "Invalid input in strict mode."
                            c1 c2 c3 c4))))))
              ((not strict-padding?)
               ;; Append an appropriate amount of padding after the
               ;; remaining characters.
               (if (<= 2 (- len i) 3)
                   (lp-restart (string-append (substring str i (string-length str))
                                              (if (= (- len i) 2) "==" "=")))
                   (error 'base64-decode "The input is too short." i)))
              (else
               (error 'base64-decode
                      "The input is too short, it may be missing padding."
                      i))))))))))

(define (get-line-comp f port)
  (if (port-eof? port)
      (eof-object)
      (f (get-line port))))

;; Reads the common -----BEGIN/END type----- delimited format from
;; the given port. Returns two values: a string with the type and a
;; bytevector containing the base64 decoded data. The second value
;; is the eof object if there is an eof before the BEGIN delimiter.
(define get-delimited-base64
  (case-lambda
    ((port)
     (get-delimited-base64 port #t))
    ((port strict)
     (define (get-first-data-line port)
       ;; Some MIME data has header fields in the same format as mail
       ;; or http. These are ignored.
       (let ((line (get-line-comp string-trim-both port)))
         (cond ((eof-object? line) line)
               ((string-index line #\:)
                (let lp ()               ;read until empty line
                  (let ((line (get-line-comp string-trim-both port)))
                    (if (string=? line "")
                        (get-line-comp string-trim-both port)
                        (lp)))))
               (else line))))
     (let ((line (get-line-comp string-trim-both port)))
       (cond ((eof-object? line)
              (values "" (eof-object)))
             ((string=? line "")
              (get-delimited-base64 port))
             ((and (string-prefix? "-----BEGIN " line)
                   (string-suffix? "-----" line))
              (let* ((type (substring line 11 (- (string-length line) 5)))
                     (endline (string-append "-----END " type "-----")))
                (let-values ([(outp extract) (open-bytevector-output-port)])
                  (let lp ((previous "") (line (get-first-data-line port)))
                    (cond ((eof-object? line)
                           (error 'get-delimited-base64
                                  "unexpected end of file"))
                          ((string-prefix? "-" line)
                           (unless (string=? line endline)
                             (error 'get-delimited-base64
                                    "bad end delimiter" type line))
                           (values type (extract)))
                          ((and (= (string-length line) 5)
                                (string-prefix? "=" line))
                           ;; Skip Radix-64 checksum
                           (lp previous (get-line-comp string-trim-both port)))
                          ((not (fxzero? (fxmod (fx+ (string-length previous)
                                                     (string-length line))
                                                4)))
                           ;; OpenSSH outputs lines with a bad length
                           (lp (string-append previous line)
                               (get-line-comp string-trim-both port)))
                          (else
                           (base64-decode (string-append previous line) base64-alphabet outp)
                           (lp "" (get-line-comp string-trim-both port))))))))
             (else ;skip garbage (like in openssl x509 -in foo -text output).
              (get-delimited-base64 port)))))))

(define put-delimited-base64
  (case-lambda
    ((port type bv line-length)
     (display (string-append "-----BEGIN " type "-----\n") port)
     (base64-encode bv 0 (bytevector-length bv)
                    line-length #f base64-alphabet port)
     (display (string-append "\n-----END " type "-----\n") port))
    ((port type bv)
     (put-delimited-base64 port type bv 76))))


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt common)
  #:use-module (gcrypt internal)
  #:use-module (system foreign)
  #:use-module (ice-9 match)
  #:re-export (gcrypt-version)
  #:export (gcrypt-error
            strip-error-source
            error-code=?
            error-source
            error-string))

;;; Commentary:
;;;
;;; Common code for the GNU Libgcrypt bindings.
;;;
;;; Code:

(define-syntax GPG_ERR_SOURCE_GCRYPT              ;from <gpg-error.h>
  (identifier-syntax 1))

(define-inlinable (strip-error-source error)
  "Strip the error source bits from ERROR, a libgpg-error error code."
  (logand error #xfffff))

(define-inlinable (gcrypt-error value)
  "Return VALUE as a libgpg-error code originating from Libgcrypt."
  (logior (ash GPG_ERR_SOURCE_GCRYPT 24)
          (strip-error-source value)))

(define-inlinable (error-code=? error1 error2)
  "Return true if ERROR1 and ERROR2 denote the same error code, regardless of
the error source."
  (= (strip-error-source error1) (strip-error-source error2)))

(define-syntax define-error-codes
  (syntax-rules ()
    "Define one variable for each error code given, using
GPG_ERR_SOURCE_GCRYPT as the error source."
    ((_ name value rest ...)
     (begin
       (define-public name value)
       (define-error-codes rest ...)))
    ((_)
     #t)))

;; GPG_ERR_ values of 'gpg_err_code_t' in <gpg-error.h>.
(define-error-codes
  error/no-error 0
  error/general 1
  error/unknown-packet 2
  error/unknown-version 3
  error/public-key-algo 4
  error/digest-algo 5
  error/bad-public-key 6
  error/bad-secret-key 7
  error/bad-signature 8
  error/no-public-key 9
  error/checksum 10
  error/bad-passphrase 11
  error/cipher-algo 12
  error/keyring-open 13
  error/invalid-packet 14
  error/invalid-armor 15
  error/no-user-id 16
  error/no-secret-key 17
  error/wrong-secret-key 18
  error/bad-key 19
  error/compr-algo 20
  error/no-prime 21
  error/no-encoding-method 22
  error/no-encryption-scheme 23
  error/no-signature-scheme 24
  error/invalid-attr 25
  error/no-value 26
  error/not-found 27
  error/value-not-found 28
  error/syntax 29
  error/bad-mpi 30
  error/invalid-passphrase 31
  error/sig-class 32
  error/resource-limit 33
  error/invalid-keyring 34
  error/trustdb 35
  error/bad-cert 36
  error/invalid-user-id 37
  error/unexpected 38
  error/time-conflict 39
  error/keyserver 40
  error/wrong-public-key-algo 41
  error/weak-key 43
  ;; The answer.
  error/invalid-key-length 44
  error/invalid-argument 45
  error/bad-uri 46
  error/invalid-uri 47
  error/network 48
  error/unknown-host 49
  error/selftest-failed 50
  error/not-encrypted 51
  error/not-processed 52
  error/unusable-public-key 53
  error/unusable-secret-key 54
  error/invalid-value 55
  error/bad-cert-chain 56
  error/missing-cert 57
  error/no-data 58
  error/bug 59
  error/not-supported 60
  error/invalid-op 61
  error/timeout 62
  error/internal 63
  error/eof-gcrypt 64
  error/invalid-object 65
  error/too-short 66
  error/too-large 67
  error/no-obj 68
  error/not-implemented 69
  error/conflict 70
  error/invalid-cipher-mode 71
  error/invalid-flag 72
  error/invalid-handle 73
  error/truncated 74
  error/incomplete-line 75
  error/invalid-response 76
  error/no-agent 77
  error/agent 78
  error/invalid-data 79
  error/assuan-server-fault 80
  error/assuan 81
  error/invalid-session-key 82
  error/invalid-sexp 83
  error/unsupported-algorithm 84
  error/no-pin-entry 85
  error/pin-entry 86
  error/bad-pin 87
  error/invalid-name 88
  error/bad-data 89
  error/invalid-parameter 90
  error/wrong-card 91
  error/no-dirmngr 92
  error/dirmngr 93
  error/cert-revoked 94
  error/no-crl-known 95
  error/crl-too-old 96
  error/line-too-long 97
  error/not-trusted 98
  error/canceled 99
  error/bad-ca-cert 100
  error/cert-expired 101
  error/cert-too-young 102
  error/unsupported-cert 103
  error/unknown-sexp 104
  error/unsupported-protection 105
  error/corrupted-protection 106
  error/ambiguous-name 107
  error/card 108
  error/card-reset 109
  error/card-removed 110
  error/invalid-card 111
  error/card-not-present 112
  error/no-pkcs15-app 113
  error/not-confirmed 114
  error/configuration 115
  error/no-policy-match 116
  error/invalid-index 117
  error/invalid-id 118
  error/no-scdaemon 119
  error/scdaemon 120
  error/unsupported-protocol 121
  error/bad-pin-method 122
  error/card-not-initialized 123
  error/unsupported-operation 124
  error/wrong-key-usage 125
  error/nothing-found 126
  error/wrong-blob-type 127
  error/missing-value 128
  error/hardware 129
  error/pin-blocked 130
  error/use-conditions 131
  error/pin-not-synced 132
  error/invalid-crl 133
  error/bad-ber 134
  error/invalid-ber 135
  error/element-not-found 136
  error/identifier-not-found 137
  error/invalid-tag 138
  error/invalid-length 139
  error/invalid-keyinfo 140
  error/unexpected-tag 141
  error/not-der-encoded 142
  error/no-cms-obj 143
  error/invalid-cms-obj 144
  error/unknown-cms-obj 145
  error/unsupported-cms-obj 146
  error/unsupported-encoding 147
  error/unsupported-cms-version 148
  error/unknown-algorithm 149
  error/invalid-engine 150
  error/public-key-not-trusted 151
  error/decrypt-failed 152
  error/key-expired 153
  error/sig-expired 154
  error/encoding-problem 155
  error/invalid-state 156
  error/dup-value 157
  error/missing-action 158
  error/module-not-found 159
  error/invalid-oid-string 160
  error/invalid-time 161
  error/invalid-crl-obj 162
  error/unsupported-crl-version 163
  error/invalid-cert-obj 164
  error/unknown-name 165
  error/locale-problem 166
  error/not-locked 167
  error/protocol-violation 168
  error/invalid-mac 169
  error/invalid-request 170
  error/unknown-extn 171
  error/unknown-crit-extn 172
  error/locked 173
  error/unknown-option 174
  error/unknown-command 175
  error/not-operational 176
  error/no-passphrase 177
  error/no-pin 178
  error/not-enabled 179
  error/no-engine 180
  error/missing-key 181
  error/too-many 182
  error/limit-reached 183
  error/not-initialized 184
  error/missing-issuer-cert 185
  error/no-keyserver 186
  error/invalid-curve 187
  error/unknown-curve 188
  error/dup-key 189
  error/ambiguous 190
  error/no-crypt-ctx 191
  error/wrong-crypt-ctx 192
  error/bad-crypt-ctx 193
  error/crypt-ctx-conflict 194
  error/broken-public-key 195
  error/broken-secret-key 196
  error/mac-algo 197
  error/fully-canceled 198
  error/unfinished 199
  error/buffer-too-short 200
  error/sexp-invalid-len-spec 201
  error/sexp-string-too-long 202
  error/sexp-unmatched-paren 203
  error/sexp-not-canonical 204
  error/sexp-bad-character 205
  error/sexp-bad-quotation 206
  error/sexp-zero-prefix 207
  error/sexp-nested-dh 208
  error/sexp-unmatched-dh 209
  error/sexp-unexpected-punc 210
  error/sexp-bad-hex-char 211
  error/sexp-odd-hex-numbers 212
  error/sexp-bad-oct-char 213
  error/subkeys-exp-or-rev 217
  error/db-corrupted 218
  error/server-failed 219
  error/no-name 220
  error/no-key 221
  error/legacy-key 222
  error/request-too-short 223
  error/request-too-long 224
  error/obj-term-state 225
  error/no-cert-chain 226
  error/cert-too-large 227
  error/invalid-record 228
  error/bad-mac 229
  error/unexpected-msg 230
  error/compr-failed 231
  error/would-wrap 232
  error/fatal-alert 233
  error/no-cipher 234
  error/missing-client-cert 235
  error/close-notify 236
  error/ticket-expired 237
  error/bad-ticket 238
  error/unknown-identity 239
  error/bad-hs-cert 240
  error/bad-hs-cert-req 241
  error/bad-hs-cert-ver 242
  error/bad-hs-change-cipher 243
  error/bad-hs-client-hello 244
  error/bad-hs-server-hello 245
  error/bad-hs-server-hello-done 246
  error/bad-hs-finished 247
  error/bad-hs-server-kex 248
  error/bad-hs-client-kex 249
  error/bogus-string 250
  error/forbidden 251
  error/key-disabled 252
  error/key-on-card 253
  error/invalid-lock-obj 254
  error/true 255
  error/false 256
  error/ass-general 257
  error/ass-accept-failed 258
  error/ass-connect-failed 259
  error/ass-invalid-response 260
  error/ass-invalid-value 261
  error/ass-incomplete-line 262
  error/ass-line-too-long 263
  error/ass-nested-commands 264
  error/ass-no-data-cb 265
  error/ass-no-inquire-cb 266
  error/ass-not-a-server 267
  error/ass-not-a-client 268
  error/ass-server-start 269
  error/ass-read-error 270
  error/ass-write-error 271
  error/ass-too-much-data 273
  error/ass-unexpected-cmd 274
  error/ass-unknown-cmd 275
  error/ass-syntax 276
  error/ass-canceled 277
  error/ass-no-input 278
  error/ass-no-output 279
  error/ass-parameter 280
  error/ass-unknown-inquire 281
  error/engine-too-old 300
  error/window-too-small 301
  error/window-too-large 302
  error/missing-envvar 303
  error/user-id-exists 304
  error/name-exists 305
  error/dup-name 306
  error/too-young 307
  error/too-old 308
  error/unknown-flag 309
  error/invalid-order 310
  error/already-fetched 311
  error/try-later 312
  error/wrong-name 313
  error/no-auth 314
  error/bad-auth 315
  error/system-bug 666)

(define error-source
  (let ((proc (libgcrypt->procedure '* "gcry_strsource" (list int))))
    (lambda (err)
      "Return the error source (a string) for ERR, an error code as thrown
along with 'gcry-error'."
      (pointer->string (proc err)))))

(define error-string
  (let ((proc (libgcrypt->procedure '* "gcry_strerror" (list int))))
    (lambda (err)
      "Return the error description (a string) for ERR, an error code as
thrown along with 'gcry-error'."
      (pointer->string (proc err)))))

(define (gcrypt-error-printer port key args default-printer)
  "Print the gcrypt error specified by ARGS."
  (match args
    ((proc err)
     (format port "In procedure ~a: ~a: ~a"
             proc (error-source err) (error-string err)))))

(set-exception-printer! 'gcry-error gcrypt-error-printer)

;;; gcrypt.scm ends here


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt hash)
  #:use-module (gcrypt utils)
  #:use-module (gcrypt internal)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (system foreign)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (hash-algorithm
            lookup-hash-algorithm
            hash-algorithm-name
            hash-size

            bytevector-hash
            open-hash-port
            port-hash
            file-hash
            open-hash-input-port

            open-sha256-port
            port-sha256
            file-sha256
            open-sha256-input-port))

;;; Commentary:
;;;
;;; Cryptographic hashes.
;;;
;;; Code:

;;;
;;; Hash.
;;;

(define-syntax-rule (define-hash-algorithms name->integer
                      symbol->integer integer->symbol hash-size
                      (name id size) ...)
  "Define hash algorithms with their NAME, numerical ID, and SIZE in bytes."
  (begin
    ;; Make sure NAME is bound to follow best practices for syntax matching
    ;; (info "(guile) Syntax Rules").  As a bonus, it provides convenient
    ;; shorthand procedures.
    (define-public name
      (cut bytevector-hash <> id))
    ...

    (define-enumerate-type name->integer symbol->integer integer->symbol
      (name id) ...)

    (define-lookup-procedure hash-size
      "Return the size in bytes of a digest of the given hash algorithm."
      (id size) ...)))

(define %hash-size
  ;; This procedure was used to double-check the hash sizes below.  (We
  ;; cannot use it at macro-expansion time because it wouldn't work when
  ;; cross-compiling.)
  (libgcrypt->procedure unsigned-int
                        "gcry_md_get_algo_dlen"
                        (list int)))

;; 'GCRY_MD_' values as of Libgcrypt 1.8.3.
(define-hash-algorithms hash-algorithm
  lookup-hash-algorithm hash-algorithm-name
  hash-size

  (md5 1 16)
  (sha1 2 20)
  (rmd160 3 20)
  ;; (md2 5 0)
  (tiger 6 24)   ;TIGER/192 as used by gpg <= 1.3.2
  (haval 7 20)   ;HAVAL, 5 pass, 160 bit
  (sha256 8 32)
  (sha384 9 48)
  (sha512 10 64)
  (sha224 11 28)

  (md4 301 16)
  (crc32 302 4)
  (crc32-rfc1510 303 4)
  (crc24-rfc2440 304 3)
  (whirlpool 305 64)
  (tiger1 306 24) ;TIGER fixed
  (tiger2 307 24) ;TIGER2 variant
  (gostr3411-94 308 32) ;GOST R 34.11-94
  (stribog256 309 32) ;GOST R 34.11-2012, 256 bit
  (stribog512 310 64) ;GOST R 34.11-2012, 512 bit
  (gostr3411-cp 311 32) ;GOST R 34.11-94 with CryptoPro-A S-Box
  (sha3-224 312 28)
  (sha3-256 313 32)
  (sha3-384 314 48)
  (sha3-512 315 64)
  ;; (shake128 316 0)
  ;; (shake256 317 0)
  (blake2b-512 318 64)
  (blake2b-384 319 48)
  (blake2b-256 320 32)
  (blake2b-160 321 20)
  (blake2s-256 322 32)
  (blake2s-224 323 28)
  (blake2s-160 324 20)
  (blake2s-128 325 16))

(define bytevector-hash
  (let ((proc (libgcrypt->procedure void
                                    "gcry_md_hash_buffer"
                                    `(,int * * ,size_t))))
    (lambda (bv algorithm)
      "Return the hash ALGORITHM of BV as a bytevector."
      (let ((digest (make-bytevector (hash-size algorithm))))
        (proc algorithm (bytevector->pointer digest)
              (bytevector->pointer bv) (bytevector-length bv))
        digest))))

(define open-md
  (let ((proc (libgcrypt->procedure int
                                    "gcry_md_open"
                                    `(* ,int ,unsigned-int))))
    (lambda (algorithm)
      (let* ((md  (bytevector->pointer (make-bytevector (sizeof '*))))
             (err (proc md algorithm 0)))
        (if (zero? err)
            (dereference-pointer md)
            (throw 'gcrypt-error err))))))

(define md-write
  (libgcrypt->procedure void "gcry_md_write" `(* * ,size_t)))

(define md-read
  (libgcrypt->procedure '* "gcry_md_read" `(* ,int)))

(define md-close
  (libgcrypt->procedure void "gcry_md_close" '(*)))

(define (open-hash-port algorithm)
  "Return two values: an output port, and a thunk.  When the thunk is called,
it returns the hash (a bytevector) for ALGORITHM of all the data written to the
output port."
  (define md
    (open-md algorithm))

  (define md-size
    (hash-size algorithm))

  (define digest #f)
  (define position 0)

  (define (finalize!)
    (let ((ptr (md-read md 0)))
      (set! digest (bytevector-copy (pointer->bytevector ptr md-size)))
      (md-close md)))

  (define (write! bv offset len)
    (if (zero? len)
        (begin
          (finalize!)
          0)
        (let ((ptr (bytevector->pointer bv offset)))
          (md-write md ptr len)
          (set! position (+ position len))
          len)))

  (define (get-position)
    position)

  (define (close)
    (unless digest
      (finalize!)))

  (values (make-custom-binary-output-port "hash"
                                          write! get-position #f
                                          close)
          (lambda ()
            (unless digest
              (finalize!))
            digest)))

(define (port-hash algorithm port)
  "Return the ALGORITHM hash (a bytevector) of all the data drained from
PORT."
  (let-values (((out get)
                (open-hash-port algorithm)))
    (dump-port port out)
    (close-port out)
    (get)))

(define (file-hash algorithm file)
  "Return the ALGORITHM hash (a bytevector) of FILE."
  (call-with-input-file file
    (cut port-hash algorithm <>)))

(define (open-hash-input-port algorithm port)
  "Return an input port that wraps PORT and a thunk to get the hash of all the
data read from PORT.  The thunk always returns the same value."
  (define md
    (open-md algorithm))

  (define md-size
    (hash-size algorithm))

  (define (read! bv start count)
    (let ((n (get-bytevector-n! port bv start count)))
      (if (eof-object? n)
          0
          (begin
            (unless digest
              (let ((ptr (bytevector->pointer bv start)))
                (md-write md ptr n)))
            n))))

  (define digest #f)

  (define (finalize!)
    (let ((ptr (md-read md 0)))
      (set! digest (bytevector-copy (pointer->bytevector ptr md-size)))
      (md-close md)))

  (define (get-hash)
    (unless digest
      (finalize!))
    digest)

  (define (unbuffered port)
    ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
    ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile.  :-)
    (setvbuf port
             (cond-expand ((and guile-2 (not guile-2.2)) _IONBF)
                          (else 'none)))
    port)

  (values (unbuffered (make-custom-binary-input-port "hash-input"
                                                     read! #f #f #f))
          get-hash))

(define open-sha256-port
  (cut open-hash-port (hash-algorithm sha256)))
(define port-sha256
  (cut port-hash (hash-algorithm sha256) <>))
(define file-sha256
  (cut file-hash (hash-algorithm sha256) <>))
(define open-sha256-input-port
  (cut open-hash-input-port (hash-algorithm sha256) <>))

;;; hash.scm ends here


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt hmac)
  #:use-module ((gcrypt mac) #:prefix mac:)
  #:export (sign-data
            sign-data-base64
            verify-sig
            verify-sig-base64
            gen-signing-key))

;;; Code:
;;;
;;; This module is deprecated and provided for compatibility with
;;; Guile-Gcrypt 0.1.0.  Use (gcrypt mac) instead.
;;;
;;; Commentary:

(define (symbol->algorithm symbol)
  "Convert SYMBOL (e.g., 'sha256) to the corresponding MAC algorithm."
  ;; Note: In 0.1.0, only a few hmac algorithms were supported, without the
  ;; 'hmac-' prefix.
  (mac:lookup-mac-algorithm (symbol-append 'hmac- symbol)))

(define* (sign-data key data #:key (algorithm 'sha512))
  "Signs DATA with KEY for ALGORITHM.  Returns a bytevector."
  (mac:sign-data key data
                 #:algorithm (symbol->algorithm algorithm)))

(define* (sign-data-base64 key data #:key (algorithm 'sha512))
  "Signs DATA with KEY for ALGORITHM.  Returns a bytevector."
  (mac:sign-data-base64 key data
                        #:algorithm
                        (symbol->algorithm algorithm)))

(define* (verify-sig key data sig #:key (algorithm 'sha512))
  "Verify that DATA with KEY matches previous signature SIG for ALGORITHM."
  (mac:valid-signature? key data sig
                        #:algorithm (symbol->algorithm algorithm)))

(define* (verify-sig-base64 key data sig #:key (algorithm 'sha512))
  "Verify that DATA with KEY matches previous signature SIG for ALGORITHM."
  (mac:valid-base64-signature? key data sig
                               #:algorithm (symbol->algorithm algorithm)))

(define gen-signing-key
  mac:generate-signing-key)


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt internal)
  #:use-module (gcrypt package-config)
  #:use-module (system foreign)
  #:export (libgcrypt->pointer
            libgcrypt->procedure

            define-enumerate-type
            define-lookup-procedure

            gcrypt-version))

;;; Code:
;;;
;;; This module provides tools for internal use.  The API of this module may
;;; change anytime; you should not rely on it.  Loading this module
;;; initializes Libgcrypt as a side effect.
;;;
;;; Comment:

(define (libgcrypt->pointer name)
  "Return a pointer to symbol FUNC in libgcrypt."
  (catch #t
    (lambda ()
      (dynamic-func name (dynamic-link %libgcrypt)))
    (lambda args
      (lambda _
        (throw 'system-error name  "~A" (list (strerror ENOSYS))
               (list ENOSYS))))))

(define (libgcrypt->procedure return name params)
  "Return a pointer to symbol FUNC in libgcrypt."
  (catch #t
    (lambda ()
      (let ((ptr (dynamic-func name (dynamic-link %libgcrypt))))
        ;; The #:return-errno? facility was introduced in Guile 2.0.12.
        (pointer->procedure return ptr params
                            #:return-errno? #t)))
    (lambda args
      (lambda _
        (throw 'system-error name  "~A" (list (strerror ENOSYS))
               (list ENOSYS))))))

(define-syntax-rule (define-enumerate-type name->integer symbol->integer
                      integer->symbol
                      (name id) ...)
  (begin
    (define-syntax name->integer
      (syntax-rules (name ...)
        "Return hash algorithm NAME."
        ((_ name) id) ...))

    (define symbol->integer
      (let ((alist '((name . id) ...)))
        (lambda (symbol)
          "Look up SYMBOL and return the corresponding integer or #f if it
could not be found."
          (assq-ref alist symbol))))

    (define-lookup-procedure integer->symbol
      "Return the name (a symbol) corresponding to the given integer value."
      (id name) ...)))

(define-syntax define-lookup-procedure
  (lambda (s)
    "Define LOOKUP as a procedure that maps an integer to its corresponding
value in O(1)."
    (syntax-case s ()
      ((_ lookup docstring (index value) ...)
       (let* ((values (map cons
                           (syntax->datum #'(index ...))
                           #'(value ...)))
              (min    (apply min (syntax->datum #'(index ...))))
              (max    (apply max (syntax->datum #'(index ...))))
              (array  (let loop ((i max)
                                 (result '()))
                        (if (< i min)
                            result
                            (loop (- i 1)
                                  (cons (or (assv-ref values i) *unspecified*)
                                        result))))))
         #`(define lookup
             ;; Allocate a big sparse vector.
             (let ((values '#(#,@array)))
               (lambda (integer)
                 docstring
                 (and (<= integer #,max) (>= integer #,min)
                      (let ((result (vector-ref values (- integer #,min))))
                        (if (unspecified? result)
                            #f
                            result)))))))))))

(define gcrypt-version
  ;; According to the manual, this function must be called before any other,
  ;; and it's not clear whether it can be called more than once.  So call it
  ;; right here from the top level.  During cross-compilation, the call to
  ;; PROC fails with a 'system-error exception; catch it.
  (let* ((proc    (libgcrypt->procedure '* "gcry_check_version" '(*)))
         (version (catch 'system-error
                    (lambda ()
                      (pointer->string (proc %null-pointer)))
                    (const ""))))
    (lambda ()
      "Return the version number of libgcrypt as a string."
      version)))


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt mac)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (gcrypt base64)
  #:use-module (gcrypt internal)
  #:use-module (gcrypt random)
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:export (mac-algorithm
            lookup-mac-algorithm
            mac-algorithm-name
            mac-size

            sign-data
            sign-data-base64
            valid-signature?
            valid-base64-signature?
            generate-signing-key))

(define-syntax-rule (define-syntax-public name value)
  (begin
    (define-syntax name value)
    (export name)))

(define-syntax-rule (define-mac-algorithms name->integer
                      symbol->integer integer->symbol mac-size
                      (name id size) ...)
  "Define hash algorithms with their NAME, numerical ID, and SIZE in bytes."
  (begin
    ;; Make sure NAME is bound to follow best practices for syntax matching
    ;; (info "(guile) Syntax Rules").
    (define-syntax-public name
      (lambda (s)
        (syntax-violation 'name "\
syntactic keyword is meant to be used with 'mac-algorithm'"
                          s s)))
    ...

    (define-enumerate-type name->integer symbol->integer integer->symbol
      (name id) ...)

    (define-lookup-procedure mac-size
      "Return the size in bytes of a digest of the given hash algorithm."
      (id size) ...)))

(define-mac-algorithms mac-algorithm
  lookup-mac-algorithm mac-algorithm-name
  mac-size

  ;; GCRY_MAC_*

  (hmac-sha256 101 32)
  (hmac-sha224 102 28)
  (hmac-sha512 103 64)
  (hmac-sha384 104 48)
  (hmac-sha1 105 20)
  (hmac-md5 106 16)
  (hmac-md4 107 16)
  (hmac-rmd160 108 20)
  (hmac-tiger1 109 24)
  (hmac-whirlpool 110 64)
  (hmac-gostr3411-94 111 32)
  (hmac-stribog256 112 32)
  (hmac-stribog512 113 64)
  ;; (hmac-md2 114 0)
  (hmac-sha3-224 115 28)
  (hmac-sha3-256 116 32)
  (hmac-sha3-384 117 48)
  (hmac-sha3-512 118 64)

  (cmac-aes 201 16)
  (cmac-3des 202 8)
  (cmac-camellia 203 16)
  (cmac-cast5 204 8)
  (cmac-blowfish 205 8)
  (cmac-twofish 206 16)
  (cmac-serpent 207 16)
  (cmac-seed 208 16)
  (cmac-rfc2268 209 8)
  (cmac-idea 210 8)
  (cmac-gost28147 211 8)

  (gmac-aes 401 16)
  (gmac-camellia 402 16)
  (gmac-twofish 403 16)
  (gmac-serpent 404 16)
  (gmac-seed 405 16)

  (poly1305 501 16)
  (poly1305-aes 502 16)
  (poly1305-camellia 503 16)
  (poly1305-twofish 504 16)
  (poly1305-serpent 505 16)
  (poly1305-seed 506 16))

(define mac-algo-maclen
  ;; This procedure was used to double-check the hash sizes above.  (We
  ;; cannot use it at macro-expansion time because it wouldn't work when
  ;; cross-compiling.)
  (libgcrypt->procedure int "gcry_mac_get_algo_maclen" `(,int)))

(define %no-error 0)  ; GPG_ERR_NO_ERROR

(define-wrapped-pointer-type <mac>
  mac?
  pointer->mac mac->pointer
  (lambda (mac port)
    (format port "#<mac ~x>"
            (pointer-address (mac->pointer mac)))))

(define %gcry-mac-open
  (libgcrypt->procedure int "gcry_mac_open"
                        ;; gcry_mac_hd_t *HD, int ALGO,
                        ;; unsigned int FLAGS, gcry_ctx_t CTX
                        `(* ,int ,unsigned-int *)))

(define (mac-open algorithm)
  "Create a <mac> object set to use ALGORITHM"
  (let* ((mac (bytevector->pointer (make-bytevector (sizeof '*))))
         (err (%gcry-mac-open mac algorithm 0 %null-pointer)))
    (if (= err 0)
        (pointer->mac (dereference-pointer mac))
        (throw 'gcry-error 'mac-open err))))

(define %gcry-mac-setkey
  (libgcrypt->procedure int "gcry_mac_setkey" `(* * ,size_t)))

(define (mac-setkey mac key)
  "Set the KEY on <mac> object MAC

In our case, KEY is either a string or a bytevector."
  (let* ((key (match key
                ((? bytevector? key)
                 key)
                ((? string? key)
                 (string->utf8 key))))
         (err (%gcry-mac-setkey (mac->pointer mac)
                                (bytevector->pointer key)
                                (bytevector-length key))))
    (if (= err 0)
        #t
        (throw 'gcry-error 'mac-setkey err))))

(define mac-close
  (let ((proc (libgcrypt->procedure void
                                    "gcry_mac_close"
                                    '(*))))  ; gcry_mac_hd_t H
    (lambda (mac)
      "Release all resources of MAC.

Running this on an already closed <mac> might segfault :)"
      (proc (mac->pointer mac)))))

(define mac-write
  (let ((proc (libgcrypt->procedure int
                                    "gcry_mac_write"
                                    `(* * ,size_t))))
    (lambda (mac obj)
      "Writes string or bytevector OBJ to MAC"
      (let* ((bv (match obj
                   ((? bytevector? obj)
                    obj)
                   ((? string? obj)
                    (string->utf8 obj))))
             (err (proc (mac->pointer mac)
                        (bytevector->pointer bv)
                        (bytevector-length bv))))
        (if (= err 0)
            #t
            (throw 'gcry-error 'mac-write err))))))

(define mac-read
  (let ((proc (libgcrypt->procedure int
                                    "gcry_mac_read"
                                    `(* * *))))
    (lambda (mac algorithm)
      "Get bytevector representing result of MAC's written, signed data"
      (define (int-bv* n)
        ;; Get the pointer to a bytevector holding an integer with this number
        (let ((bv (make-bytevector (sizeof int))))
          (bytevector-uint-set! bv 0 n (native-endianness) (sizeof int))
          (bytevector->pointer bv)))
      (let* ((bv-len (mac-size algorithm))
             (bv (make-bytevector bv-len))
             (err (proc (mac->pointer mac)
                        (bytevector->pointer bv)
                        (int-bv* bv-len))))
        (if (= err 0)
            bv
            (throw 'gcry-error 'mac-read err))))))

;; GPG_ERR_CHECKSUM *should* be 10, but it seems to return here as
;; 16777226... unfortunately this is because we're pulling back an integer
;; rather than the gcry_error_t type.

(define mac-verify
  (let ((proc (libgcrypt->procedure int
                                    "gcry_mac_verify"
                                    `(* * ,size_t))))
    (lambda (mac bv)
      "Verify that BV matches result calculated in MAC

BV should be a bytevector with previously calculated data."
      (let ((err (proc (mac->pointer mac)
                       (bytevector->pointer bv)
                       (bytevector-length bv))))
        (if (= err 0)
            (values #t err)
            ;; TODO: This is WRONG!  See the comment above
            ;;   this procedure's definition for why.  If we could
            ;;   parse it as the appropriate GPG error, GPG_ERR_CHECKSUM
            ;;   should be 10.
            (values #f err))))))

(define* (sign-data key data #:key
                    (algorithm (mac-algorithm hmac-sha512)))
  "Signs DATA with KEY for ALGORITHM.  Returns a bytevector."
  (let ((mac (mac-open algorithm)))
    (mac-setkey mac key)
    (mac-write mac data)
    (let ((result (mac-read mac algorithm)))
      (mac-close mac)
      result)))

(define* (sign-data-base64 key data #:key
                           (algorithm (mac-algorithm hmac-sha512)))
  "Like sign-data, but conveniently encodes to base64."
  (base64-encode (sign-data key data #:algorithm algorithm)))

(define* (valid-signature? key data sig
                           #:key (algorithm (mac-algorithm hmac-sha512)))
  "Verify that DATA with KEY matches previous signature SIG for ALGORITHM."
  (let ((mac (mac-open algorithm)))
    (mac-setkey mac key)
    (mac-write mac data)
    (let ((result (mac-verify mac sig)))
      (mac-close mac)
      result)))

(define* (valid-base64-signature? key data b64-sig
                                  #:key
                                  (algorithm (mac-algorithm hmac-sha512)))
  (valid-signature? key data
                    (base64-decode b64-sig)
                    #:algorithm algorithm))

(define* (generate-signing-key #:optional (key-length 128))
  "Generate a signing key (a bytevector).

KEY-LENGTH is the length, in bytes, of the key.  The default is 128.
This should be a multiple of 8."
  (gen-random-bv key-length %gcry-very-strong-random))


code:
;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcrypt package-config)
  #:export (%libgcrypt
            %guile-gcrypt-package-name %guile-gcrypt-version))

(define %libgcrypt
  "@LIBGCRYPT@")

(define %guile-gcrypt-package-name
  "@PACKAGE_NAME@")

(define %guile-gcrypt-version
  "@PACKAGE_VERSION@")