common.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
  4. ;;;
  5. ;;; This file is part of guile-gcrypt.
  6. ;;;
  7. ;;; guile-gcrypt is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU Lesser General Public License
  9. ;;; as published by the Free Software Foundation; either version 3 of
  10. ;;; the License, or (at your option) any later version.
  11. ;;;
  12. ;;; guile-gcrypt is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  15. ;;; Lesser General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU Lesser General Public License
  18. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (gcrypt common)
  20. #:use-module (gcrypt internal)
  21. #:use-module (system foreign)
  22. #:use-module (ice-9 match)
  23. #:re-export (gcrypt-version)
  24. #:export (gcrypt-error
  25. strip-error-source
  26. error-code=?
  27. error-source
  28. error-string))
  29. ;;; Commentary:
  30. ;;;
  31. ;;; Common code for the GNU Libgcrypt bindings.
  32. ;;;
  33. ;;; Code:
  34. (define-syntax GPG_ERR_SOURCE_GCRYPT ;from <gpg-error.h>
  35. (identifier-syntax 1))
  36. (define-inlinable (strip-error-source error)
  37. "Strip the error source bits from ERROR, a libgpg-error error code."
  38. (logand error #xfffff))
  39. (define-inlinable (gcrypt-error value)
  40. "Return VALUE as a libgpg-error code originating from Libgcrypt."
  41. (logior (ash GPG_ERR_SOURCE_GCRYPT 24)
  42. (strip-error-source value)))
  43. (define-inlinable (error-code=? error1 error2)
  44. "Return true if ERROR1 and ERROR2 denote the same error code, regardless of
  45. the error source."
  46. (= (strip-error-source error1) (strip-error-source error2)))
  47. (define-syntax define-error-codes
  48. (syntax-rules ()
  49. "Define one variable for each error code given, using
  50. GPG_ERR_SOURCE_GCRYPT as the error source."
  51. ((_ name value rest ...)
  52. (begin
  53. (define-public name value)
  54. (define-error-codes rest ...)))
  55. ((_)
  56. #t)))
  57. ;; GPG_ERR_ values of 'gpg_err_code_t' in <gpg-error.h>.
  58. (define-error-codes
  59. error/no-error 0
  60. error/general 1
  61. error/unknown-packet 2
  62. error/unknown-version 3
  63. error/public-key-algo 4
  64. error/digest-algo 5
  65. error/bad-public-key 6
  66. error/bad-secret-key 7
  67. error/bad-signature 8
  68. error/no-public-key 9
  69. error/checksum 10
  70. error/bad-passphrase 11
  71. error/cipher-algo 12
  72. error/keyring-open 13
  73. error/invalid-packet 14
  74. error/invalid-armor 15
  75. error/no-user-id 16
  76. error/no-secret-key 17
  77. error/wrong-secret-key 18
  78. error/bad-key 19
  79. error/compr-algo 20
  80. error/no-prime 21
  81. error/no-encoding-method 22
  82. error/no-encryption-scheme 23
  83. error/no-signature-scheme 24
  84. error/invalid-attr 25
  85. error/no-value 26
  86. error/not-found 27
  87. error/value-not-found 28
  88. error/syntax 29
  89. error/bad-mpi 30
  90. error/invalid-passphrase 31
  91. error/sig-class 32
  92. error/resource-limit 33
  93. error/invalid-keyring 34
  94. error/trustdb 35
  95. error/bad-cert 36
  96. error/invalid-user-id 37
  97. error/unexpected 38
  98. error/time-conflict 39
  99. error/keyserver 40
  100. error/wrong-public-key-algo 41
  101. error/weak-key 43
  102. ;; The answer.
  103. error/invalid-key-length 44
  104. error/invalid-argument 45
  105. error/bad-uri 46
  106. error/invalid-uri 47
  107. error/network 48
  108. error/unknown-host 49
  109. error/selftest-failed 50
  110. error/not-encrypted 51
  111. error/not-processed 52
  112. error/unusable-public-key 53
  113. error/unusable-secret-key 54
  114. error/invalid-value 55
  115. error/bad-cert-chain 56
  116. error/missing-cert 57
  117. error/no-data 58
  118. error/bug 59
  119. error/not-supported 60
  120. error/invalid-op 61
  121. error/timeout 62
  122. error/internal 63
  123. error/eof-gcrypt 64
  124. error/invalid-object 65
  125. error/too-short 66
  126. error/too-large 67
  127. error/no-obj 68
  128. error/not-implemented 69
  129. error/conflict 70
  130. error/invalid-cipher-mode 71
  131. error/invalid-flag 72
  132. error/invalid-handle 73
  133. error/truncated 74
  134. error/incomplete-line 75
  135. error/invalid-response 76
  136. error/no-agent 77
  137. error/agent 78
  138. error/invalid-data 79
  139. error/assuan-server-fault 80
  140. error/assuan 81
  141. error/invalid-session-key 82
  142. error/invalid-sexp 83
  143. error/unsupported-algorithm 84
  144. error/no-pin-entry 85
  145. error/pin-entry 86
  146. error/bad-pin 87
  147. error/invalid-name 88
  148. error/bad-data 89
  149. error/invalid-parameter 90
  150. error/wrong-card 91
  151. error/no-dirmngr 92
  152. error/dirmngr 93
  153. error/cert-revoked 94
  154. error/no-crl-known 95
  155. error/crl-too-old 96
  156. error/line-too-long 97
  157. error/not-trusted 98
  158. error/canceled 99
  159. error/bad-ca-cert 100
  160. error/cert-expired 101
  161. error/cert-too-young 102
  162. error/unsupported-cert 103
  163. error/unknown-sexp 104
  164. error/unsupported-protection 105
  165. error/corrupted-protection 106
  166. error/ambiguous-name 107
  167. error/card 108
  168. error/card-reset 109
  169. error/card-removed 110
  170. error/invalid-card 111
  171. error/card-not-present 112
  172. error/no-pkcs15-app 113
  173. error/not-confirmed 114
  174. error/configuration 115
  175. error/no-policy-match 116
  176. error/invalid-index 117
  177. error/invalid-id 118
  178. error/no-scdaemon 119
  179. error/scdaemon 120
  180. error/unsupported-protocol 121
  181. error/bad-pin-method 122
  182. error/card-not-initialized 123
  183. error/unsupported-operation 124
  184. error/wrong-key-usage 125
  185. error/nothing-found 126
  186. error/wrong-blob-type 127
  187. error/missing-value 128
  188. error/hardware 129
  189. error/pin-blocked 130
  190. error/use-conditions 131
  191. error/pin-not-synced 132
  192. error/invalid-crl 133
  193. error/bad-ber 134
  194. error/invalid-ber 135
  195. error/element-not-found 136
  196. error/identifier-not-found 137
  197. error/invalid-tag 138
  198. error/invalid-length 139
  199. error/invalid-keyinfo 140
  200. error/unexpected-tag 141
  201. error/not-der-encoded 142
  202. error/no-cms-obj 143
  203. error/invalid-cms-obj 144
  204. error/unknown-cms-obj 145
  205. error/unsupported-cms-obj 146
  206. error/unsupported-encoding 147
  207. error/unsupported-cms-version 148
  208. error/unknown-algorithm 149
  209. error/invalid-engine 150
  210. error/public-key-not-trusted 151
  211. error/decrypt-failed 152
  212. error/key-expired 153
  213. error/sig-expired 154
  214. error/encoding-problem 155
  215. error/invalid-state 156
  216. error/dup-value 157
  217. error/missing-action 158
  218. error/module-not-found 159
  219. error/invalid-oid-string 160
  220. error/invalid-time 161
  221. error/invalid-crl-obj 162
  222. error/unsupported-crl-version 163
  223. error/invalid-cert-obj 164
  224. error/unknown-name 165
  225. error/locale-problem 166
  226. error/not-locked 167
  227. error/protocol-violation 168
  228. error/invalid-mac 169
  229. error/invalid-request 170
  230. error/unknown-extn 171
  231. error/unknown-crit-extn 172
  232. error/locked 173
  233. error/unknown-option 174
  234. error/unknown-command 175
  235. error/not-operational 176
  236. error/no-passphrase 177
  237. error/no-pin 178
  238. error/not-enabled 179
  239. error/no-engine 180
  240. error/missing-key 181
  241. error/too-many 182
  242. error/limit-reached 183
  243. error/not-initialized 184
  244. error/missing-issuer-cert 185
  245. error/no-keyserver 186
  246. error/invalid-curve 187
  247. error/unknown-curve 188
  248. error/dup-key 189
  249. error/ambiguous 190
  250. error/no-crypt-ctx 191
  251. error/wrong-crypt-ctx 192
  252. error/bad-crypt-ctx 193
  253. error/crypt-ctx-conflict 194
  254. error/broken-public-key 195
  255. error/broken-secret-key 196
  256. error/mac-algo 197
  257. error/fully-canceled 198
  258. error/unfinished 199
  259. error/buffer-too-short 200
  260. error/sexp-invalid-len-spec 201
  261. error/sexp-string-too-long 202
  262. error/sexp-unmatched-paren 203
  263. error/sexp-not-canonical 204
  264. error/sexp-bad-character 205
  265. error/sexp-bad-quotation 206
  266. error/sexp-zero-prefix 207
  267. error/sexp-nested-dh 208
  268. error/sexp-unmatched-dh 209
  269. error/sexp-unexpected-punc 210
  270. error/sexp-bad-hex-char 211
  271. error/sexp-odd-hex-numbers 212
  272. error/sexp-bad-oct-char 213
  273. error/subkeys-exp-or-rev 217
  274. error/db-corrupted 218
  275. error/server-failed 219
  276. error/no-name 220
  277. error/no-key 221
  278. error/legacy-key 222
  279. error/request-too-short 223
  280. error/request-too-long 224
  281. error/obj-term-state 225
  282. error/no-cert-chain 226
  283. error/cert-too-large 227
  284. error/invalid-record 228
  285. error/bad-mac 229
  286. error/unexpected-msg 230
  287. error/compr-failed 231
  288. error/would-wrap 232
  289. error/fatal-alert 233
  290. error/no-cipher 234
  291. error/missing-client-cert 235
  292. error/close-notify 236
  293. error/ticket-expired 237
  294. error/bad-ticket 238
  295. error/unknown-identity 239
  296. error/bad-hs-cert 240
  297. error/bad-hs-cert-req 241
  298. error/bad-hs-cert-ver 242
  299. error/bad-hs-change-cipher 243
  300. error/bad-hs-client-hello 244
  301. error/bad-hs-server-hello 245
  302. error/bad-hs-server-hello-done 246
  303. error/bad-hs-finished 247
  304. error/bad-hs-server-kex 248
  305. error/bad-hs-client-kex 249
  306. error/bogus-string 250
  307. error/forbidden 251
  308. error/key-disabled 252
  309. error/key-on-card 253
  310. error/invalid-lock-obj 254
  311. error/true 255
  312. error/false 256
  313. error/ass-general 257
  314. error/ass-accept-failed 258
  315. error/ass-connect-failed 259
  316. error/ass-invalid-response 260
  317. error/ass-invalid-value 261
  318. error/ass-incomplete-line 262
  319. error/ass-line-too-long 263
  320. error/ass-nested-commands 264
  321. error/ass-no-data-cb 265
  322. error/ass-no-inquire-cb 266
  323. error/ass-not-a-server 267
  324. error/ass-not-a-client 268
  325. error/ass-server-start 269
  326. error/ass-read-error 270
  327. error/ass-write-error 271
  328. error/ass-too-much-data 273
  329. error/ass-unexpected-cmd 274
  330. error/ass-unknown-cmd 275
  331. error/ass-syntax 276
  332. error/ass-canceled 277
  333. error/ass-no-input 278
  334. error/ass-no-output 279
  335. error/ass-parameter 280
  336. error/ass-unknown-inquire 281
  337. error/engine-too-old 300
  338. error/window-too-small 301
  339. error/window-too-large 302
  340. error/missing-envvar 303
  341. error/user-id-exists 304
  342. error/name-exists 305
  343. error/dup-name 306
  344. error/too-young 307
  345. error/too-old 308
  346. error/unknown-flag 309
  347. error/invalid-order 310
  348. error/already-fetched 311
  349. error/try-later 312
  350. error/wrong-name 313
  351. error/no-auth 314
  352. error/bad-auth 315
  353. error/system-bug 666)
  354. (define error-source
  355. (let ((proc (libgcrypt->procedure '* "gcry_strsource" (list int))))
  356. (lambda (err)
  357. "Return the error source (a string) for ERR, an error code as thrown
  358. along with 'gcry-error'."
  359. (pointer->string (proc err)))))
  360. (define error-string
  361. (let ((proc (libgcrypt->procedure '* "gcry_strerror" (list int))))
  362. (lambda (err)
  363. "Return the error description (a string) for ERR, an error code as
  364. thrown along with 'gcry-error'."
  365. (pointer->string (proc err)))))
  366. (define (gcrypt-error-printer port key args default-printer)
  367. "Print the gcrypt error specified by ARGS."
  368. (match args
  369. ((proc err)
  370. (format port "In procedure ~a: ~a: ~a"
  371. proc (error-source err) (error-string err)))))
  372. (set-exception-printer! 'gcry-error gcrypt-error-printer)
  373. ;;; gcrypt.scm ends here