common.scm 2.7 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.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 common)
  19. #:use-module (gcrypt package-config)
  20. #:use-module (system foreign)
  21. #:use-module (ice-9 match)
  22. #:export (gcrypt-version
  23. libgcrypt-func
  24. error-source error-string))
  25. ;;; Commentary:
  26. ;;;
  27. ;;; Common code for the GNU Libgcrypt bindings. Loading this module
  28. ;;; initializes Libgcrypt as a side effect.
  29. ;;;
  30. ;;; Code:
  31. (define libgcrypt-func
  32. (let ((lib (dynamic-link %libgcrypt)))
  33. (lambda (func)
  34. "Return a pointer to symbol FUNC in libgcrypt."
  35. (dynamic-func func lib))))
  36. (define gcrypt-version
  37. ;; According to the manual, this function must be called before any other,
  38. ;; and it's not clear whether it can be called more than once. So call it
  39. ;; right here from the top level.
  40. (let* ((ptr (libgcrypt-func "gcry_check_version"))
  41. (proc (pointer->procedure '* ptr '(*)))
  42. (version (pointer->string (proc %null-pointer))))
  43. (lambda ()
  44. "Return the version number of libgcrypt as a string."
  45. version)))
  46. (define error-source
  47. (let* ((ptr (libgcrypt-func "gcry_strsource"))
  48. (proc (pointer->procedure '* ptr (list int))))
  49. (lambda (err)
  50. "Return the error source (a string) for ERR, an error code as thrown
  51. along with 'gcry-error'."
  52. (pointer->string (proc err)))))
  53. (define error-string
  54. (let* ((ptr (libgcrypt-func "gcry_strerror"))
  55. (proc (pointer->procedure '* ptr (list int))))
  56. (lambda (err)
  57. "Return the error description (a string) for ERR, an error code as
  58. thrown along with 'gcry-error'."
  59. (pointer->string (proc err)))))
  60. (define (gcrypt-error-printer port key args default-printer)
  61. "Print the gcrypt error specified by ARGS."
  62. (match args
  63. ((proc err)
  64. (format port "In procedure ~a: ~a: ~a"
  65. proc (error-source err) (error-string err)))))
  66. (set-exception-printer! 'gcry-error gcrypt-error-printer)
  67. ;;; gcrypt.scm ends here