Hello everyone,
While hoping to make something in Guile that needed symmetric
encryption, it fell to me to extend guile-gcrypt. Unfortunately, because
of how some procedures like `gcrypt_cipher_gettag` are implemented, the
Guile FFI reports that they don't exist! This blocks AEAD, which is what
I needed, so it's back to the drawing board for me. But, short of AEAD,
some amount of symmetric cryptographic functionality is accessible from
Guile, hence the attached patch.
I've left the AEAD-related code commented out in the module in case
anyone is interested in this challenge.
Regards,
S. Rhoulam
diff --git a/gcrypt/cipher.scm b/gcrypt/cipher.scm
new file mode 100644
index 0000000..bff28c8
--- /dev/null
+++ b/gcrypt/cipher.scm
@@ -0,0 +1,425 @@
+;;; guile-gcrypt --- crypto tooling for guile
+;;; Copyright © 2026 Saad Rhoulam <[email protected]>
+;;;
+;;; 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 Lesser 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gcrypt cipher)
+ #:use-module (ice-9 match)
+ #:use-module (gcrypt internal)
+ #:use-module (gcrypt random)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:export (cipher-algorithm
+ lookup-cipher-algorithm
+ cipher-algorithm-name
+ cipher-key-size
+
+ cipher-mode
+ lookup-cipher-mode
+ cipher-mode-name
+
+ decrypt
+ ;; decrypt-aead
+ encrypt
+ ;; encrypt-aead
+ )
+ )
+
+(define-syntax-rule (define-syntax-public name value)
+ (begin
+ (define-syntax name value)
+ (export name)))
+
+(define-syntax-rule (define-cipher-algorithms name->integer
+ symbol->integer integer->symbol cipher-key-size
+ (name id size) ...)
+ "Define cipher 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 'cipher-algorithm'"
+ s s)))
+ ...
+
+ (define-enumerate-type name->integer symbol->integer integer->symbol
+ (name id) ...)
+
+ (define-lookup-procedure cipher-key-size
+ "Return the size in bytes of a key for the given cipher algorithm."
+ (id size) ...)))
+
+(define-syntax-rule (define-cipher-modes name->integer
+ symbol->integer integer->symbol
+ (name id) ...)
+ "Define cipher modes with their NAME and numerical ID."
+ (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 'cipher-mode'"
+ s s)))
+ ...
+
+ (define-enumerate-type name->integer symbol->integer integer->symbol
+ (name id) ...)))
+
+(define-cipher-algorithms cipher-algorithm
+ lookup-cipher-algorithm cipher-algorithm-name
+ cipher-key-size
+
+ ;; GCRY_CIPHER_*
+
+ (3des 2 24)
+ (cast5 3 16)
+ (aes128 7 16)
+ (aes192 8 24)
+ (aes256 9 32)
+ (twofish 10 32)
+ (twofish128 303 16)
+ (serpent128 304 16)
+ (serpent192 305 24)
+ (serpent256 306 32)
+ (seed 309 16)
+ (camellia128 310 16)
+ (camellia192 311 24)
+ (camellia256 312 32)
+ (sm4 318 16))
+
+(define-cipher-modes cipher-mode
+ lookup-cipher-mode cipher-mode-name
+
+ ;; GCRY_CIPHER_MODE_*
+ (ecb 1)
+ (cfb 2)
+ (cbc 3)
+ (stream 4)
+ (ofb 5)
+ (ctr 6)
+ (aeswrap 7)
+ (ccm 8)
+ (gcm 9)
+ (poly1305 10)
+ (ocb 11)
+ (cfb8 12)
+ (xts 13)
+ (eax 14)
+ (siv 15)
+ (gcm-siv 16))
+
+(define cipher-algo-keylen
+ (libgcrypt->procedure int "gcry_cipher_get_algo_keylen" `(,int)))
+
+(define cipher-algo-blklen
+ (libgcrypt->procedure int "gcry_cipher_get_algo_blklen" `(,int)))
+
+(define %no-error 0) ; GPG_ERR_NO_ERROR
+
+(define-wrapped-pointer-type <cipher>
+ cipher?
+ pointer->cipher cipher->pointer
+ (lambda (cipher port)
+ (format port "#<cipher ~x>"
+ (pointer-address (cipher->pointer cipher)))))
+
+(define %gcry-cipher-open
+ (libgcrypt->procedure int "gcry_cipher_open"
+ ;; gcry_cipher_hd_t *HD, int ALGO,
+ ;; int MODE,
+ ;; unsigned int FLAGS
+ `(* ,int ,int ,unsigned-int)))
+
+(define (cipher-open algorithm mode)
+ "Create a <cipher> object set to use ALGORITHM and MODE"
+ (let* ((cipher (bytevector->pointer (make-bytevector (sizeof '*))))
+ (err (%gcry-cipher-open cipher algorithm mode 0)))
+ (if (= err 0)
+ (pointer->cipher (dereference-pointer cipher))
+ (throw 'gcry-error 'cipher-open err))))
+
+(define %gcry-cipher-setkey
+ (libgcrypt->procedure int "gcry_cipher_setkey" `(* * ,size_t)))
+
+(define (cipher-setkey cipher key)
+ "Set the KEY on <cipher> object CIPHER
+
+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-cipher-setkey (cipher->pointer cipher)
+ (bytevector->pointer key)
+ (bytevector-length key))))
+ (if (= err 0)
+ #t
+ (throw 'gcry-error 'cipher-setkey err))))
+
+(define %gcry-cipher-setiv
+ (libgcrypt->procedure int "gcry_cipher_setiv" `(* * ,size_t)))
+
+(define (cipher-setiv cipher iv)
+ "Set the IV on <cipher> object CIPHER
+
+In our case, IV is either a string or a bytevector."
+ (let* ((iv (match iv
+ ((? bytevector? iv)
+ iv)
+ ((? string? iv)
+ (string->utf8 iv))))
+ (err (%gcry-cipher-setiv (cipher->pointer cipher)
+ (bytevector->pointer iv)
+ (bytevector-length iv))))
+ (if (= err 0)
+ #t
+ (throw 'gcry-error 'cipher-setiv err))))
+
+(define %gcry-cipher-setctr
+ (libgcrypt->procedure int "gcry_cipher_setctr" `(* * ,size_t)))
+
+(define (cipher-setctr cipher ctr)
+ "Set the CTR on <cipher> object CIPHER
+
+In our case, CTR is either a string or a bytevector."
+ (let* ((ctr (match ctr
+ ((? bytevector? ctr)
+ ctr)
+ ((? string? ctr)
+ (string->utf8 ctr))))
+ (err (%gcry-cipher-setctr (cipher->pointer cipher)
+ (bytevector->pointer ctr)
+ (bytevector-length ctr))))
+ (if (= err 0)
+ #t
+ (throw 'gcry-error 'cipher-setctr err))))
+
+(define %gcry-cipher-close
+ (libgcrypt->procedure void
+ "gcry_cipher_close"
+ ;; gcry_cipher_hd_t H
+ '(*)))
+
+(define (cipher-close cipher)
+ "Release all resources of CIPHER.
+
+Running this on an already closed <cipher> might segfault :)"
+ (%gcry-cipher-close (cipher->pointer cipher)))
+
+(define %gcry-cipher-encrypt
+ (libgcrypt->procedure int
+ "gcry_cipher_encrypt"
+ ;; gcry_cipher_hd_t, uchar* out, size_t outsize
+ ;; const uchar* in, size_t inlen
+ `(* * ,size_t * ,size_t)))
+
+(define (cipher-encrypt cipher obj)
+ "Runs a prepared cipher to encrypt data. Pad your plaintext if using a non-stream cipher mode."
+ (let* ((bv (match obj
+ ((? bytevector? obj)
+ (bytevector-copy obj))
+ ((? string? obj)
+ (string->utf8 obj))))
+ (err (%gcry-cipher-encrypt (cipher->pointer cipher)
+ (bytevector->pointer bv)
+ (bytevector-length bv)
+ %null-pointer
+ 0)))
+ (if (= err 0)
+ bv
+ (throw 'gcry-error 'cipher-encrypt err))))
+
+(define %gcry-cipher-decrypt
+ (libgcrypt->procedure int
+ "gcry_cipher_decrypt"
+ ;; gcry_cipher_hd_t, uchar* out, size_t outsize
+ ;; const uchar* in, size_t inlen
+ `(* * ,size_t * ,size_t)))
+
+(define (cipher-decrypt cipher obj)
+ "Runs a prepared cipher to decrypt data."
+ (let* ((bv (match obj
+ ((? bytevector? obj)
+ (bytevector-copy obj))
+ ((? string? obj)
+ (string->utf8 obj))))
+ (err (%gcry-cipher-decrypt (cipher->pointer cipher)
+ (bytevector->pointer bv)
+ (bytevector-length bv)
+ %null-pointer
+ 0)))
+ (if (= err 0)
+ bv
+ (throw 'gcry-error 'cipher-decrypt err))))
+
+(define %gcry-cipher-authenticate
+ (libgcrypt->procedure int
+ "gcry_cipher_authenticate"
+ ;; gcry_cipher_hd_t h, const void *abuf, size_t abuflen
+ '(* * ,size_t)))
+
+(define (cipher-authenticate cipher obj)
+ "Process additional authenticated data (AAD), AEAD cipher modes only."
+ (let* ((bv (match obj
+ ((? bytevector? obj)
+ obj)
+ ((? string? obj)
+ (string->utf8 obj))))
+ (err (%gcry-cipher-authenticate (cipher->pointer cipher)
+ (bytevector->pointer bv)
+ (bytevector-length bv))))
+ (if (= err 0)
+ #t
+ (throw 'gcry-error 'cipher-authenticate err))))
+
+;; (define %gcryctl-get-taglen 76)
+;; (define %gcry-cipher-info
+;; (libgcrypt->procedure int
+;; "gcry_cipher_info"
+;; ;; gcry_cipher_hd_t h, int what, void *buffer, size_t *nbytes
+;; '(* ,int * ,size_t)))
+
+;; (define %gcry-cipher-gettag
+;; (libgcrypt->procedure int
+;; "gcry_cipher_gettag"
+;; ;; gcry_cipher_hd_t h, void *tag, size_t taglen
+;; '(* * ,size_t)))
+
+;; (define (cipher-get-tag cipher)
+;; "Retrieve the tag after encrypting data with an AEAD cipher mode."
+;; (let* (
+;; (tag-len-bv (make-bytevector (sizeof size_t) 0))
+;; (tag-len-err (%gcry-cipher-info cipher
+;; %gcryctl-get-taglen
+;; %null-pointer
+;; (bytevector->pointer tag-len-bv)))
+;; (bv-len (bytevector-uint-ref tag-len-bv 0 (native-endianness) (sizeof size_t)))
+;; (bv-len 16)
+;; (bv (make-bytevector bv-len))
+;; (err (%gcry-cipher-gettag (cipher->pointer cipher)
+;; (bytevector->pointer bv)
+;; bv-len)))
+;; (if (= err 0)
+;; bv
+;; (throw 'gcry-error 'cipher-get-tag err))))
+
+;; (define %gcry-cipher-checktag
+;; (libgcrypt->procedure int
+;; "gcry_cipher_checktag"
+;; ;; gcry_cipher_hd_t h, const void *tag, size_t taglen
+;; '(* * size_t)))
+
+;; (define %gpg-err-checksum 10)
+
+;; (define (cipher-check-tag cipher obj)
+;; "Compare the tag to the tag computed while decrypting a ciphertext. AEAD cipher modes only."
+;; (let* ((bv (match obj
+;; ((? bytevector? obj)
+;; obj)
+;; ((? string? obj)
+;; (string->utf8 obj))))
+;; (err (%gcry-cipher-checktag (cipher->pointer cipher)
+;; (bytevector->pointer bv)
+;; (bytevector-length bv))))
+;; (if (= err 0)
+;; #t
+;; (if (= err %gpg-err-checksum)
+;; #f
+;; (throw 'gcry-error 'cipher-check-tag err)))))
+
+;; (define %gcry-cipher-set-decryption-tag
+;; ;; Needed for SIV and GCM-SIV
+;; (libgcrypt->procedure int
+;; "gcry_cipher_set_decryption_tag"
+;; ;; gcry_cipher_hd_t h, const void *tag, size_t taglen
+;; `(* * ,size_t)
+;; ))
+
+;; (define (cipher-set-decryption-tag cipher obj)
+;; "Use only for SIV and GCM-SIV modes. For other modes, use `_checktag'."
+;; (let* ((bv (match obj
+;; ((? bytevector? obj)
+;; obj)
+;; ((? string? obj)
+;; (string->utf8 obj))))
+;; (err (%gcry-cipher-set-decryption-tag (cipher->pointer cipher)
+;; (bytevector->pointer bv)
+;; (bytevector-length bv))))
+;; (if (= err 0)
+;; #t
+;; (throw 'gcry-error 'cipher-set-decryption-tag err))))
+
+(define* (encrypt algorithm mode key iv plaintext #:key (ctr #f))
+ "Encrypt data using the specified algorithm, mode, key, and IV.
+
+Pad your plaintext if the mode requires it!
+Returns a bytevector with the ciphertext."
+ (let ((cipher (cipher-open algorithm mode)))
+ (cipher-setkey cipher key)
+ (if ctr
+ (cipher-setctr cipher iv)
+ (cipher-setiv cipher iv))
+ (let ((ciphertext (cipher-encrypt cipher plaintext)))
+ (cipher-close cipher)
+ ciphertext)))
+
+;; (define* (encrypt-aead algorithm mode key iv plaintext #:key (aad #f) (ctr #f))
+;; "Encrypt data using the specified algorithm, mode, key, and IV.
+
+;; Pad your plaintext if the mode requires it!
+;; Returns `(ciphertext . tag)'."
+;; (let ((cipher (cipher-open algorithm mode)))
+;; (cipher-setkey cipher key)
+;; (if ctr
+;; (cipher-setctr cipher ctr)
+;; (cipher-setiv cipher iv))
+;; (if aad (cipher-authenticate cipher aad))
+;; (let ((ciphertext-tag (cons (cipher-encrypt cipher plaintext)
+;; (cipher-get-tag cipher))))
+;; (cipher-close cipher)
+;; ciphertext-tag)))
+
+(define* (decrypt algorithm mode key iv ciphertext #:key (ctr #f))
+ "Decrypt data using the specified algorithm, mode, key, and IV.
+
+Returns a bytevector with the plaintext."
+ (let ((cipher (cipher-open algorithm mode)))
+ (cipher-setkey cipher key)
+ (if ctr
+ (cipher-setctr cipher iv)
+ (cipher-setiv cipher iv))
+ (let ((plaintext (cipher-decrypt cipher ciphertext)))
+ (cipher-close cipher)
+ plaintext)))
+
+;; (define* (decrypt-aead algorithm mode key iv ciphertext tag #:key (aad #f) (ctr #f))
+;; "Decrypt data using the specified algorithm, mode, key, and IV.
+
+;; Returns `(plaintext . tag-verified?)'."
+;; (let ((cipher (cipher-open algorithm mode)))
+;; (cipher-setkey cipher key)
+;; (if ctr
+;; (cipher-setctr cipher ctr)
+;; (cipher-setiv cipher iv))
+;; (if aad (cipher-authenticate cipher aad))
+;; (let ((plaintext-tagv (cons (cipher-decrypt cipher ciphertext)
+;; (cipher-check-tag cipher tag))))
+;; (cipher-close cipher)
+;; plaintext-tagv)))
diff --git a/tests/cipher.scm b/tests/cipher.scm
new file mode 100644
index 0000000..5695724
--- /dev/null
+++ b/tests/cipher.scm
@@ -0,0 +1,68 @@
+;;; guile-gcrypt --- crypto tooling for guile
+;;; Copyright © 2026 Saad Rhoulam <[email protected]>
+;;;
+;;; 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 Lesser 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-mac)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-64)
+ #:use-module (gcrypt cipher)
+ #:use-module (gcrypt random))
+
+(test-begin "cipher")
+
+(test-equal "lookup-cipher-algorithm"
+ (cipher-algorithm aes128)
+ (lookup-cipher-algorithm 'aes128))
+
+(test-equal "lookup-cipher-mode"
+ (cipher-mode gcm)
+ (lookup-cipher-mode 'gcm))
+
+(test-eq "cipher-algorithm-name"
+ 'aes128
+ (cipher-algorithm-name (cipher-algorithm aes128)))
+
+(test-eq "cipher-mode-name"
+ 'gcm
+ (cipher-mode-name (cipher-mode gcm)))
+
+(test-equal "cipher-key-size"
+ (list 16 24 32)
+ (map cipher-key-size
+ (list (cipher-algorithm aes128)
+ (cipher-algorithm aes192)
+ (cipher-algorithm aes256))))
+
+(define test-key (gen-random-bv 16))
+(define test-iv (gen-random-bv 16))
+(define test-aad (gen-random-bv 8))
+
+(let* ((ct (encrypt (cipher-algorithm aes128) (cipher-mode cbc) test-key test-iv "sixteencharacter")))
+ ;; Should be a bytevector
+ (test-assert (bytevector? ct))
+ ;; Decrypts to original plaintext
+ (test-assert (equal? (string->utf8 "sixteencharacter") (decrypt (cipher-algorithm aes128) (cipher-mode cbc) test-key test-iv ct)))
+ ;; Wrong algorithm fails
+ (test-assert (not (equal? "sixteencharacter" (decrypt (cipher-algorithm serpent128) (cipher-mode cbc) test-key test-iv ct))))
+ ;; Wrong mode fails
+ (test-assert (not (equal? ct (encrypt (cipher-algorithm aes128) (cipher-mode ctr) test-key test-iv "sixteencharacter" #:ctr #t))))
+ ;; Should equal a re-run of itself
+ (test-equal ct (encrypt (cipher-algorithm aes128) (cipher-mode cbc) test-key test-iv "sixteencharacter"))
+ ;; Shouldn't equal something different
+ (test-assert (not (equal? ct (encrypt (cipher-algorithm aes128) (cipher-mode cbc) test-key test-iv "filthycaricature")))))
+
+(test-end "cipher")
_______________________________________________
Gcrypt-devel mailing list
[email protected]
https://lists.gnupg.org/mailman/listinfo/gcrypt-devel
