hmac.scm 6.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
  3. ;;;
  4. ;;; This file is part of guile-gcrypt.
  5. ;;;
  6. ;;; guile-gcrypt is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or
  9. ;;; (at your option) any later version.
  10. ;;;
  11. ;;; guile-gcrypt is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;; General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gcrypt hmac)
  19. #:use-module (ice-9 hash-table)
  20. #:use-module (ice-9 format)
  21. #:use-module (ice-9 match)
  22. #:use-module (gcrypt base64)
  23. #:use-module (gcrypt common)
  24. #:use-module (gcrypt random)
  25. #:use-module (rnrs bytevectors)
  26. #:use-module (system foreign)
  27. #:export (sign-data
  28. sign-data-base64
  29. verify-sig verify-sig-base64
  30. gen-signing-key))
  31. ;;; HMAC
  32. ;;; ====
  33. (define %no-error 0) ; GPG_ERR_NO_ERROR
  34. (define-wrapped-pointer-type <mac>
  35. mac?
  36. pointer->mac mac->pointer
  37. (lambda (mac port)
  38. (format port "#<mac ~x>"
  39. (pointer-address (mac->pointer mac)))))
  40. (define %gcry-mac-open
  41. (pointer->procedure int (libgcrypt-func "gcry_mac_open")
  42. `(* ,int ,unsigned-int *))) ; gcry_mac_hd_t *HD, int ALGO,
  43. ; unsigned int FLAGS, gcry_ctx_t CTX
  44. (define mac-algorithms-mapping
  45. (alist->hashq-table
  46. `((sha256 . 101)
  47. (sha512 . 103)
  48. (sha3-256 . 116)
  49. (sha3-512 . 118))))
  50. (define (mac-algo-ref sym)
  51. (hashq-ref mac-algorithms-mapping sym))
  52. (define mac-algo-maclen
  53. (let ((proc (pointer->procedure
  54. int (libgcrypt-func "gcry_mac_get_algo_maclen")
  55. `(,int))))
  56. (lambda (sym)
  57. "Get expected length in bytes of mac yielded by algorithm SYM"
  58. (proc (mac-algo-ref sym)))))
  59. (define (mac-open algorithm)
  60. "Create a <mac> object set to use ALGORITHM"
  61. (let* ((mac (bytevector->pointer (make-bytevector (sizeof '*))))
  62. (algo (mac-algo-ref algorithm))
  63. (err (%gcry-mac-open mac algo 0 %null-pointer)))
  64. (if (= err 0)
  65. (pointer->mac (dereference-pointer mac))
  66. (throw 'gcry-error 'mac-open err))))
  67. (define %gcry-mac-setkey
  68. (pointer->procedure int (libgcrypt-func "gcry_mac_setkey")
  69. `(* * ,size_t)))
  70. (define (mac-setkey mac key)
  71. "Set the KEY on <mac> object MAC
  72. In our case, KEY is either a string or a bytevector."
  73. (let* ((key (match key
  74. ((? bytevector? key)
  75. key)
  76. ((? string? key)
  77. (string->utf8 key))))
  78. (err (%gcry-mac-setkey (mac->pointer mac)
  79. (bytevector->pointer key)
  80. (bytevector-length key))))
  81. (if (= err 0)
  82. #t
  83. (throw 'gcry-error 'mac-setkey err))))
  84. (define mac-close
  85. (let ((proc (pointer->procedure
  86. void (libgcrypt-func "gcry_mac_close")
  87. '(*)))) ; gcry_mac_hd_t H
  88. (lambda (mac)
  89. "Release all resources of MAC.
  90. Running this on an already closed <mac> might segfault :)"
  91. (proc (mac->pointer mac)))))
  92. (define mac-write
  93. (let ((proc (pointer->procedure
  94. int (libgcrypt-func "gcry_mac_write")
  95. `(* * ,size_t))))
  96. (lambda (mac obj)
  97. "Writes string or bytevector OBJ to MAC"
  98. (let* ((bv (match obj
  99. ((? bytevector? obj)
  100. obj)
  101. ((? string? obj)
  102. (string->utf8 obj))))
  103. (err (proc (mac->pointer mac)
  104. (bytevector->pointer bv)
  105. (bytevector-length bv))))
  106. (if (= err 0)
  107. #t
  108. (throw 'gcry-error 'mac-write err))))))
  109. (define mac-read
  110. (let ((proc (pointer->procedure
  111. int (libgcrypt-func "gcry_mac_read")
  112. `(* * *))))
  113. (lambda (mac algorithm)
  114. "Get bytevector representing result of MAC's written, signed data"
  115. (define (int-bv* n)
  116. ;; Get the pointer to a bytevector holding an integer with this number
  117. (let ((bv (make-bytevector (sizeof int))))
  118. (bytevector-uint-set! bv 0 n (native-endianness) (sizeof int))
  119. (bytevector->pointer bv)))
  120. (let* ((bv-len (mac-algo-maclen algorithm))
  121. (bv (make-bytevector bv-len))
  122. (err (proc (mac->pointer mac)
  123. (bytevector->pointer bv)
  124. (int-bv* bv-len))))
  125. (if (= err 0)
  126. bv
  127. (throw 'gcry-error 'mac-read err))))))
  128. ;; GPG_ERR_CHECKSUM *should* be 10, but it seems to return here as
  129. ;; 16777226... unfortunately this is because we're pulling back an integer
  130. ;; rather than the gcry_error_t type.
  131. (define mac-verify
  132. (let ((proc (pointer->procedure
  133. int (libgcrypt-func "gcry_mac_verify")
  134. `(* * ,size_t))))
  135. (lambda (mac bv)
  136. "Verify that BV matches result calculated in MAC
  137. BV should be a bytevector with previously calculated data."
  138. (let ((err (proc (mac->pointer mac)
  139. (bytevector->pointer bv)
  140. (bytevector-length bv))))
  141. (if (= err 0)
  142. (values #t err)
  143. ;; TODO: This is WRONG! See the comment above
  144. ;; this procedure's definition for why. If we could
  145. ;; parse it as the appropriate GPG error, GPG_ERR_CHECKSUM
  146. ;; should be 10.
  147. (values #f err))))))
  148. (define* (sign-data key data #:key (algorithm 'sha512))
  149. "Signs DATA with KEY for ALGORITHM. Returns a bytevector."
  150. (let ((mac (mac-open algorithm)))
  151. (mac-setkey mac key)
  152. (mac-write mac data)
  153. (let ((result (mac-read mac algorithm)))
  154. (mac-close mac)
  155. result)))
  156. (define* (sign-data-base64 key data #:key (algorithm 'sha512))
  157. "Like sign-data, but conveniently encodes to base64."
  158. (base64-encode (sign-data key data #:algorithm algorithm)))
  159. ;; @@: Shouldn't this be "valid-sig?"
  160. (define* (verify-sig key data sig #:key (algorithm 'sha512))
  161. "Verify that DATA with KEY matches previous signature SIG for ALGORITHM."
  162. (let ((mac (mac-open algorithm)))
  163. (mac-setkey mac key)
  164. (mac-write mac data)
  165. (let ((result (mac-verify mac sig)))
  166. (mac-close mac)
  167. result)))
  168. (define* (verify-sig-base64 key data b64-sig #:key (algorithm 'sha512))
  169. (verify-sig key data
  170. (base64-decode b64-sig)
  171. #:algorithm algorithm))
  172. (define* (gen-signing-key #:optional (key-length 128))
  173. "Generate a signing key (a bytevector).
  174. KEY-LENGTH is the length, in bytes, of the key. The default is 128.
  175. This should be a multiple of 8."
  176. (gen-random-bv key-length %gcry-very-strong-random))