1 /* Part of SWI-Prolog
2
3 Author: Jan van der Steen, Jan Wielemaker, Matt Lilley,
4 Markus Triska and James Cash
5 E-mail: J.Wielemaker@vu.nl
6 WWW: http://www.swi-prolog.org
7 Copyright (c) 2004-2020, SWI-Prolog Foundation
8 VU University Amsterdam
9 CWI, Amsterdam
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions
14 are met:
15
16 1. Redistributions of source code must retain the above copyright
17 notice, this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in
21 the documentation and/or other materials provided with the
22 distribution.
23
24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
25 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
26 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
27 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
28 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
29 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
30 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
31 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
32 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
33 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
34 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
35 POSSIBILITY OF SUCH DAMAGE.
36 */
37
38 #include <config.h>
39 #include <SWI-Stream.h>
40 #include <SWI-Prolog.h>
41 #include <assert.h>
42 #include <string.h>
43 #include <openssl/rand.h>
44 #ifdef _REENTRANT
45 #include <pthread.h>
46 #endif
47
48 #include <openssl/x509v3.h>
49 #include <openssl/ssl.h>
50 #include <openssl/bn.h>
51 #include <openssl/dh.h>
52 #define NEED_BIO 1
53 #define NEED_SSL_ERR 1
54 #include "cryptolib.c"
55
56 #ifdef LIBRESSL_VERSION_NUMBER
57 #undef HAVE_X509_CHECK_HOST /* seems broken. must investigate */
58 #endif
59
60 #define SSL_CONFIG_MAGIC 0x539dbe3a
61 #ifndef SYSTEM_CACERT_FILENAME
62 #define SYSTEM_CACERT_FILENAME "/etc/ssl/certs/ca-certificates.crt"
63 #endif
64
65 #define SSL_MAX_CERT_KEY_PAIRS 12
66
67 typedef int BOOL;
68 #ifndef TRUE
69 #define TRUE 1
70 #endif
71 #ifndef FALSE
72 #define FALSE 0
73 #endif
74
75 static atom_t ATOM_server;
76 static atom_t ATOM_client;
77 static atom_t ATOM_password;
78 static atom_t ATOM_host;
79 static atom_t ATOM_peer_cert;
80 static atom_t ATOM_cacerts;
81 static atom_t ATOM_require_crl;
82 static atom_t ATOM_crl;
83 static atom_t ATOM_certificate_file;
84 static atom_t ATOM_certificate_key_pairs;
85 static atom_t ATOM_key_file;
86 static atom_t ATOM_pem_password_hook;
87 static atom_t ATOM_cert_verify_hook;
88 static atom_t ATOM_close_parent;
89 static atom_t ATOM_close_notify;
90 static atom_t ATOM_disable_ssl_methods;
91 static atom_t ATOM_min_protocol_version;
92 static atom_t ATOM_max_protocol_version;
93 static atom_t ATOM_cipher_list;
94 static atom_t ATOM_ecdh_curve;
95 static atom_t ATOM_root_certificates;
96 static atom_t ATOM_sni_hook;
97 static atom_t ATOM_alpn_protocols;
98 static atom_t ATOM_alpn_protocol_hook;
99
100 static atom_t ATOM_sslv2;
101 static atom_t ATOM_sslv23;
102 static atom_t ATOM_sslv3;
103 static atom_t ATOM_tlsv1;
104 static atom_t ATOM_tlsv1_1;
105 static atom_t ATOM_tlsv1_2;
106 static atom_t ATOM_tlsv1_3;
107 static atom_t ATOM_minus; /* "-" */
108
109 static functor_t FUNCTOR_unsupported_hash_algorithm1;
110 static functor_t FUNCTOR_system1;
111 static functor_t FUNCTOR_error2;
112 static functor_t FUNCTOR_ssl_error4;
113 static functor_t FUNCTOR_permission_error3;
114 static functor_t FUNCTOR_version1;
115 static functor_t FUNCTOR_notbefore1;
116 static functor_t FUNCTOR_notafter1;
117 static functor_t FUNCTOR_subject1;
118 static functor_t FUNCTOR_issuername1;
119 static functor_t FUNCTOR_serial1;
120 static functor_t FUNCTOR_public_key1;
121 static functor_t FUNCTOR_private_key1;
122 static functor_t FUNCTOR_rsa8;
123 static functor_t FUNCTOR_ec3;
124 static functor_t FUNCTOR_key1;
125 static functor_t FUNCTOR_hash1;
126 static functor_t FUNCTOR_next_update1;
127 static functor_t FUNCTOR_signature1;
128 static functor_t FUNCTOR_signature_algorithm1;
129 static functor_t FUNCTOR_to_be_signed1;
130 static functor_t FUNCTOR_equals2;
131 static functor_t FUNCTOR_crl1;
132 static functor_t FUNCTOR_revocations1;
133 static functor_t FUNCTOR_revoked2;
134 #ifndef OPENSSL_NO_SSL2
135 static functor_t FUNCTOR_session_key1;
136 #endif
137 static functor_t FUNCTOR_cipher1;
138 static functor_t FUNCTOR_master_key1;
139 static functor_t FUNCTOR_session_id1;
140 static functor_t FUNCTOR_client_random1;
141 static functor_t FUNCTOR_server_random1;
142 static functor_t FUNCTOR_system1;
143 static functor_t FUNCTOR_unknown1;
144 static functor_t FUNCTOR_alpn_protocol1;
145 static functor_t FUNCTOR_file1;
146 static functor_t FUNCTOR_certificate1;
147
148 typedef enum
149 { PL_SSL_NONE,
150 PL_SSL_SERVER,
151 PL_SSL_CLIENT
152 } PL_SSL_ROLE;
153
154 typedef enum
155 { SSL_PL_OK,
156 SSL_PL_RETRY,
157 SSL_PL_ERROR
158 } SSL_PL_STATUS;
159
160 #define SSL_CERT_VERIFY_MORE 0
161
162 static STACK_OF(X509) *system_root_store = NULL;
163 static int system_root_store_fetched = FALSE;
164 static pthread_mutex_t root_store_lock = PTHREAD_MUTEX_INITIALIZER;
165
166 /*
167 * Index of our config data in the SSL data
168 */
169 static int ssl_idx;
170 static int ctx_idx;
171
172 typedef struct pl_cert_key_pair
173 { X509 *certificate_X509;
174 char *key;
175 char *certificate;
176 } PL_CERT_KEY_PAIR;
177
178 typedef struct pl_ssl_callback
179 { record_t goal;
180 module_t module;
181 } PL_SSL_CALLBACK;
182
183 typedef struct pl_ssl_protocol
184 { BOOL is_set;
185 int version;
186 } PL_SSL_PROTOCOL;
187
188 typedef struct
189 { int references;
190 STACK_OF(X509) *cacerts;
191 } cacert_stack;
192
193 typedef struct pl_ssl
194 { long magic;
195 /*
196 * Are we server or client
197 */
198 PL_SSL_ROLE role;
199
200 int close_parent;
201 atom_t atom;
202 BOOL close_notify;
203
204 /*
205 * Context, Certificate, SSL info
206 */
207 SSL_CTX *ctx;
208 int idx;
209 X509 *peer_cert;
210
211 /*
212 * In case of the client the host we're connecting to.
213 */
214 char *host;
215
216 /*
217 * Various parameters affecting the SSL layer
218 */
219 cacert_stack *cacerts;
220
221 char *certificate_file;
222 char *key_file;
223 PL_CERT_KEY_PAIR cert_key_pairs[SSL_MAX_CERT_KEY_PAIRS];
224 int num_cert_key_pairs;
225
226 char *cipher_list;
227 char *ecdh_curve;
228 STACK_OF(X509_CRL) *crl_list;
229 char *password;
230 BOOL crl_required;
231 BOOL peer_cert_required;
232
233 PL_SSL_PROTOCOL min_protocol;
234 PL_SSL_PROTOCOL max_protocol;
235
236 /*
237 * Application defined handlers
238 */
239 PL_SSL_CALLBACK cb_cert_verify;
240 PL_SSL_CALLBACK cb_pem_passwd;
241 PL_SSL_CALLBACK cb_sni;
242 PL_SSL_CALLBACK cb_alpn_proto;
243 #ifndef HAVE_X509_CHECK_HOST
244 int hostname_check_status;
245 #endif
246 unsigned char *alpn_protos;
247 size_t alpn_protos_len;
248 } PL_SSL;
249
250 typedef struct ssl_instance
251 { PL_SSL *config;
252 SSL *ssl;
253 IOSTREAM *sread; /* wire streams */
254 IOSTREAM *swrite;
255 IOSTREAM *dread; /* data streams */
256 IOSTREAM *dwrite;
257 int close_needed;
258 BOOL fatal_alert;
259 } PL_SSL_INSTANCE;
260
261
262 typedef enum
263 { RSA_MODE, EVP_MODE
264 } crypt_mode_t;
265
266
267 /*******************************
268 * ATOMIC *
269 *******************************/
270
271 #define ATOMIC_ADD(ptr, v) __atomic_add_fetch(ptr, v, __ATOMIC_SEQ_CST)
272 #define ATOMIC_SUB(ptr, v) __atomic_sub_fetch(ptr, v, __ATOMIC_SEQ_CST)
273 #define ATOMIC_INC(ptr) ATOMIC_ADD(ptr, 1) /* ++(*ptr) */
274 #define ATOMIC_DEC(ptr) ATOMIC_SUB(ptr, 1) /* --(*ptr) */
275 #define __COMPARE_AND_SWAP(at, from, to) \
276 __atomic_compare_exchange_n(at, &(from), to, FALSE, \
277 __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST)
278
279 static inline int
COMPARE_AND_SWAP_PTR(void * at,void * from,void * to)280 COMPARE_AND_SWAP_PTR(void *at, void *from, void *to)
281 { void **ptr = at;
282
283 return __COMPARE_AND_SWAP(ptr, from, to);
284 }
285
286
287 /*******************************
288 * MANAGE STRUCT VALUES *
289 *******************************/
290
291 #define set_string(obj, field, str) \
292 attr_set_string(&((obj)->field), str)
293
294 static void
attr_set_string(char ** where,const char * str)295 attr_set_string(char **where, const char *str)
296 { if ( *where )
297 free(*where);
298 if ( str )
299 *where = ssl_strdup(str);
300 }
301
302 static cacert_stack *
new_cacert_stack(void)303 new_cacert_stack(void)
304 { cacert_stack *s = malloc(sizeof(*s));
305
306 if ( s )
307 { s->references = 1;
308 if ( !(s->cacerts=sk_X509_new_null()) )
309 { free(s);
310 s = NULL;
311 }
312 }
313
314 return s;
315 }
316
317 static cacert_stack *
dup_cacert_stack(cacert_stack * s)318 dup_cacert_stack(cacert_stack *s)
319 { if ( s )
320 ATOMIC_INC(&s->references);
321
322 return s;
323 }
324
325 static void
free_cacert_stack(cacert_stack * s)326 free_cacert_stack(cacert_stack *s)
327 { if ( s && ATOMIC_DEC(&s->references) == 0 )
328 { sk_X509_pop_free(s->cacerts, X509_free);
329 free(s);
330 }
331 }
332
333 /*******************************
334 * GET TYPED TERM ARGUMENTS *
335 *******************************/
336
337 static int
get_char_arg(int a,term_t t,char ** s)338 get_char_arg(int a, term_t t, char **s)
339 { term_t t2 = PL_new_term_ref();
340
341 _PL_get_arg(a, t, t2);
342 return PL_get_chars(t2, s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION);
343 }
344
345
346 static int
get_bool_arg(int a,term_t t,int * i)347 get_bool_arg(int a, term_t t, int *i)
348 { term_t t2 = PL_new_term_ref();
349
350 _PL_get_arg(a, t, t2);
351 return PL_get_bool_ex(t2, i);
352 }
353
354
355 static int
get_file_arg(int a,term_t t,char ** f)356 get_file_arg(int a, term_t t, char **f)
357 { term_t t2 = PL_new_term_ref();
358
359 _PL_get_arg(a, t, t2);
360 return PL_get_file_name(t2, f, PL_FILE_EXIST);
361 }
362
363
364 static int
unify_bignum(term_t t,const BIGNUM * bn)365 unify_bignum(term_t t, const BIGNUM *bn)
366 { int rc;
367
368 if ( bn )
369 { char *hex = BN_bn2hex(bn);
370
371 rc = PL_unify_chars(t, PL_STRING|REP_ISO_LATIN_1, (size_t)-1, hex);
372 OPENSSL_free(hex);
373 } else
374 { rc = PL_unify_atom(t, ATOM_minus);
375 }
376
377 return rc;
378 }
379
380
381 static int
unify_bignum_arg(int a,term_t t,const BIGNUM * bn)382 unify_bignum_arg(int a, term_t t, const BIGNUM *bn)
383 { term_t arg;
384
385 if ( (arg = PL_new_term_ref()) &&
386 PL_get_arg(a, t, arg) )
387 { int rc = unify_bignum(arg, bn);
388
389 PL_reset_term_refs(arg);
390 return rc;
391 }
392
393 return FALSE;
394 }
395
396
397 /* Note that while this might seem incredibly hacky, it is
398 essentially the same algorithm used by X509_cmp_time to
399 parse the date. Some
400 Fractional seconds are ignored. This is also largely untested - there
401 may be a lot of edge cases that dont work!
402 */
403 static int
unify_asn1_time(term_t term,const ASN1_TIME * time)404 unify_asn1_time(term_t term, const ASN1_TIME *time)
405 { time_t result = 0;
406 char buffer[24];
407 char* pbuffer = buffer;
408 size_t length = time->length;
409 char * source = (char *)time->data;
410 struct tm time_tm;
411 time_t lSecondsFromUTC;
412
413 if (time->type == V_ASN1_UTCTIME)
414 { if ((length < 11) || (length > 17))
415 { ssl_deb(2, "Unable to parse time - expected either 11 or 17 chars,"
416 " not %d", length);
417 return FALSE;
418 }
419 /* Otherwise just get the first 10 chars - ignore seconds */
420 memcpy(pbuffer, source, 10);
421 pbuffer += 10;
422 source += 10;
423 length -= 10;
424 } else
425 { if (length < 13)
426 { ssl_deb(2, "Unable to parse time - expected at least 13 chars,"
427 " not %d", length);
428 return FALSE;
429 }
430 /* Otherwise just get the first 12 chars - ignore seconds */
431 memcpy(pbuffer, source, 12);
432 pbuffer += 12;
433 source += 12;
434 length -= 12;
435 }
436 /* Next find end of string */
437 if ((*source == 'Z') || (*source == '-') || (*source == '+'))
438 { *(pbuffer++) = '0';
439 *(pbuffer++) = '0';
440 } else
441 { *(pbuffer++) = *(source++);
442 *(pbuffer++) = *(source++);
443 if (*source == '.')
444 { source++;
445 while ((*source >= '0') && (*source <= '9'))
446 source++;
447 }
448 }
449 *(pbuffer++) = 'Z';
450 *(pbuffer++) = '\0';
451
452 /* If not UTC, calculate offset */
453 if (*source == 'Z')
454 { lSecondsFromUTC = 0;
455 } else
456 { if ( length < 6 || (*source != '+' && source[5] != '-') )
457 { ssl_deb(2, "Unable to parse time. Missing UTC offset");
458 return FALSE;
459 }
460 lSecondsFromUTC = ((source[1]-'0') * 10 + (source[2]-'0')) * 60;
461 lSecondsFromUTC += (source[3]-'0') * 10 + (source[4]-'0');
462 if (*source == '-')
463 lSecondsFromUTC = -lSecondsFromUTC;
464 }
465 /* Parse date */
466 time_tm.tm_sec = ((buffer[10] - '0') * 10) + (buffer[11] - '0');
467 time_tm.tm_min = ((buffer[8] - '0') * 10) + (buffer[9] - '0');
468 time_tm.tm_hour = ((buffer[6] - '0') * 10) + (buffer[7] - '0');
469 time_tm.tm_mday = ((buffer[4] - '0') * 10) + (buffer[5] - '0');
470 time_tm.tm_mon = (((buffer[2] - '0') * 10) + (buffer[3] - '0')) - 1;
471 time_tm.tm_year = ((buffer[0] - '0') * 10) + (buffer[1] - '0');
472 if (time_tm.tm_year < 50)
473 time_tm.tm_year += 100; /* according to RFC 2459 */
474 time_tm.tm_wday = 0;
475 time_tm.tm_yday = 0;
476 time_tm.tm_isdst = 0; /* No DST adjustment requested, though */
477 /* mktime might do it anyway */
478
479 #ifdef HAVE_TIMEGM
480 result = timegm(&time_tm);
481 if ((time_t)-1 != result)
482 { result += lSecondsFromUTC;
483 } else
484 { ssl_deb(2, "timegm() failed");
485 return FALSE;
486 }
487 #else
488 result = mktime(&time_tm);
489 /* mktime assumes that the time_tm contains information for localtime. */
490 /* Convert back to UTC: */
491 if ((time_t)-1 != result)
492 { result += lSecondsFromUTC; /* Add in the UTC offset of the original value */
493 result -= timezone; /* Adjust for localtime */
494 } else
495 { ssl_deb(2, "mktime() failed");
496 return FALSE;
497 }
498 #endif
499
500 return PL_unify_int64(term, result);
501 }
502
503 static const EVP_MD *
algorithm_to_type(const ASN1_OBJECT * algorithm,int * nid)504 algorithm_to_type(const ASN1_OBJECT* algorithm, int *nid)
505 { *nid = OBJ_obj2nid(algorithm);
506 /* Annoyingly, EVP_get_digestbynid doesnt work for some of these
507 algorithms. Instead check for them explicitly and set the digest manually
508 */
509 switch (*nid)
510 { case NID_ecdsa_with_SHA1:
511 return EVP_sha1();
512 case NID_ecdsa_with_SHA256:
513 return EVP_sha256();
514 case NID_ecdsa_with_SHA384:
515 return EVP_sha384();
516 #ifdef HAVE_OPENSSL_MD2_H
517 case NID_md2WithRSAEncryption:
518 return EVP_md2();
519 #endif
520 }
521
522 return EVP_get_digestbynid(*nid);
523 }
524
525 #if defined(HAVE_X509_DIGEST) && defined(HAVE_X509_CRL_DIGEST)
526
527 static int
hash_X509_digest_wrapper(const void * data,const EVP_MD * type,unsigned char * md,unsigned int * l)528 hash_X509_digest_wrapper(const void *data, const EVP_MD *type,
529 unsigned char* md, unsigned int *l)
530 { return X509_digest((X509 *) data, type, md, l);
531 }
532
533 static int
hash_X509_crl_digest_wrapper(const void * data,const EVP_MD * type,unsigned char * md,unsigned int * l)534 hash_X509_crl_digest_wrapper(const void *data, const EVP_MD *type,
535 unsigned char* md, unsigned int *l)
536 { return X509_CRL_digest((X509_CRL *) data, type, md, l);
537 }
538
539 static int
unify_hash(term_t hash,const ASN1_OBJECT * algorithm,int (* data_to_digest)(const void *,const EVP_MD *,unsigned char *,unsigned int *),void * data)540 unify_hash(term_t hash, const ASN1_OBJECT* algorithm,
541 int (*data_to_digest)(const void*, const EVP_MD *,
542 unsigned char*, unsigned int*),
543 void *data)
544 { int nid;
545 const EVP_MD *type = algorithm_to_type(algorithm, &nid);
546 unsigned char digest[EVP_MAX_MD_SIZE];
547 unsigned int digest_length;
548
549 if ( type == NULL )
550 return PL_unify_term(hash,
551 PL_FUNCTOR, FUNCTOR_unsupported_hash_algorithm1,
552 PL_INT, nid);
553
554 if ( !data_to_digest(data, type, digest, &digest_length) )
555 return FALSE;
556
557 return unify_bytes_hex(hash, digest_length, digest);
558 }
559
560 #else
561
562 static int
i2d_X509_CRL_INFO_wrapper(void * i,unsigned char ** d)563 i2d_X509_CRL_INFO_wrapper(void* i, unsigned char** d)
564 { return i2d_X509_CRL_INFO(i, d);
565 }
566
567 static int
i2d_X509_CINF_wrapper(void * i,unsigned char ** d)568 i2d_X509_CINF_wrapper(void* i, unsigned char** d)
569 { return i2d_X509_CINF(i, d);
570 }
571
572
573 static int
unify_hash(term_t hash,const ASN1_OBJECT * algorithm,int (* i2d)(void *,unsigned char **),void * data)574 unify_hash(term_t hash, const ASN1_OBJECT* algorithm,
575 int (*i2d)(void*, unsigned char**), void * data)
576 { int nid;
577 const EVP_MD *type = algorithm_to_type(algorithm, &nid);
578 EVP_MD_CTX *ctx = EVP_MD_CTX_new();
579 int digestible_length;
580 unsigned char* digest_buffer;
581 unsigned char digest[EVP_MAX_MD_SIZE];
582 unsigned int digest_length;
583 unsigned char* p;
584 /* Generate hash */
585
586 if ( type == NULL )
587 return PL_unify_term(hash,
588 PL_FUNCTOR, FUNCTOR_unsupported_hash_algorithm1,
589 PL_INT, nid);
590
591 digestible_length=i2d(data,NULL);
592 digest_buffer = PL_malloc(digestible_length);
593 if ( digest_buffer == NULL )
594 return PL_resource_error("memory");
595
596 /* i2d_X509_CINF will change the value of p. We need to pass in a copy */
597 p = digest_buffer;
598 i2d(data,&p);
599 if (!EVP_DigestInit(ctx, type))
600 { EVP_MD_CTX_free(ctx);
601 PL_free(digest_buffer);
602 return raise_ssl_error(ERR_get_error());
603 }
604 if (!EVP_DigestUpdate(ctx, digest_buffer, digestible_length))
605 { EVP_MD_CTX_free(ctx);
606 PL_free(digest_buffer);
607 return raise_ssl_error(ERR_get_error());
608 }
609 if (!EVP_DigestFinal(ctx, digest, &digest_length))
610 { EVP_MD_CTX_free(ctx);
611 PL_free(digest_buffer);
612 return raise_ssl_error(ERR_get_error());
613 }
614 EVP_MD_CTX_free(ctx);
615 PL_free(digest_buffer);
616 return unify_bytes_hex(hash, digest_length, digest);
617 }
618
619 #endif
620
621
622 static int
unify_name(term_t term,X509_NAME * name)623 unify_name(term_t term, X509_NAME* name)
624 { int ni;
625 term_t list = PL_copy_term_ref(term);
626 term_t item = PL_new_term_ref();
627
628 if ( name == NULL )
629 return PL_unify_term(term, PL_CHARS, "<null>");
630
631 for (ni = 0; ni < X509_NAME_entry_count(name); ni++)
632 { X509_NAME_ENTRY* e = X509_NAME_get_entry(name, ni);
633 ASN1_STRING* entry_data = X509_NAME_ENTRY_get_data(e);
634 unsigned char *utf8_data;
635 int rc;
636
637 if ( ASN1_STRING_to_UTF8(&utf8_data, entry_data) < 0 )
638 return PL_resource_error("memory");
639
640 rc = ( PL_unify_list(list, item, list) &&
641 PL_unify_term(
642 item,
643 PL_FUNCTOR, FUNCTOR_equals2,
644 PL_CHARS, OBJ_nid2sn(OBJ_obj2nid(X509_NAME_ENTRY_get_object(e))),
645 PL_UTF8_CHARS, utf8_data)
646 );
647 OPENSSL_free(utf8_data);
648 if ( !rc )
649 return FALSE;
650 }
651
652 return PL_unify_nil(list);
653 }
654
655 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
656 #define X509_REVOKED_get0_serialNumber(R) ((R)->serialNumber)
657 #define X509_REVOKED_get0_revocationDate(R) ((R)->revocationDate)
658 #define EVP_PKEY_base_id(key) ((key)->type)
659 #define X509_CRL_get0_nextUpdate(C) X509_CRL_get_nextUpdate(C)
660 #ifndef HAVE_X509_CRL_GET0_SIGNATURE
661 /* Avoid conflict if the prototype is there, but the function is not */
662 #define X509_CRL_get0_signature my_X509_CRL_get0_signature
663
664 static void
X509_CRL_get0_signature(const X509_CRL * crl,const ASN1_BIT_STRING ** psig,const X509_ALGOR ** palg)665 X509_CRL_get0_signature(const X509_CRL *crl, const ASN1_BIT_STRING **psig,
666 const X509_ALGOR **palg)
667 { *psig = crl->signature;
668 *palg = crl->sig_alg;
669 }
670 #endif
671
672 #ifndef HAVE_X509_GET0_SIGNATURE
673 /* Avoid conflict if the prototype is there, but the function is not */
674 #define X509_get0_signature my_X509_get0_signature
675
676 static void
X509_get0_signature(const ASN1_BIT_STRING ** psig,const X509_ALGOR ** palg,const X509 * data)677 X509_get0_signature(const ASN1_BIT_STRING **psig, const X509_ALGOR **palg,
678 const X509 *data)
679 {
680 *psig = data->signature;
681 *palg = data->sig_alg;
682 }
683 #endif
684 #endif
685
686 static int
unify_crl(term_t term,X509_CRL * crl)687 unify_crl(term_t term, X509_CRL* crl)
688 { const ASN1_BIT_STRING *psig;
689 const X509_ALGOR *palg;
690 STACK_OF(X509_REVOKED) *revoked = X509_CRL_get_REVOKED(crl);
691 int i;
692 term_t item = PL_new_term_ref();
693 term_t hash = PL_new_term_ref();
694 term_t issuer = PL_new_term_ref();
695 term_t revocations = PL_new_term_ref();
696 term_t list = PL_copy_term_ref(revocations);
697 term_t next_update = PL_new_term_ref();
698 term_t signature = PL_new_term_ref();
699
700 int result = 1;
701 long n;
702 unsigned char* p;
703 term_t revocation_date;
704 BIO* mem;
705
706 mem = BIO_new(BIO_s_mem());
707 if (mem == NULL)
708 return PL_resource_error("memory");
709
710 X509_CRL_get0_signature(crl, &psig, &palg);
711 i2a_ASN1_INTEGER(mem, (ASN1_BIT_STRING *) psig);
712 if (!(unify_name(issuer, X509_CRL_get_issuer(crl)) &&
713 #ifdef HAVE_X509_CRL_DIGEST
714 unify_hash(hash, palg->algorithm, hash_X509_crl_digest_wrapper, crl) &&
715 #else
716 unify_hash(hash, palg->algorithm, i2d_X509_CRL_INFO_wrapper, crl->crl) &&
717 #endif
718 unify_asn1_time(next_update, X509_CRL_get0_nextUpdate(crl)) &&
719 unify_bytes_hex(signature, psig->length, psig->data) &&
720 PL_unify_term(term,
721 PL_LIST, 5,
722 PL_FUNCTOR, FUNCTOR_issuername1,
723 PL_TERM, issuer,
724 PL_FUNCTOR, FUNCTOR_signature1,
725 PL_TERM, signature,
726 PL_FUNCTOR, FUNCTOR_hash1,
727 PL_TERM, hash,
728 PL_FUNCTOR, FUNCTOR_next_update1,
729 PL_TERM, next_update,
730 PL_FUNCTOR, FUNCTOR_revocations1,
731 PL_TERM, revocations)))
732 { return FALSE;
733 }
734
735 for (i = 0; i < sk_X509_REVOKED_num(revoked); i++)
736 { X509_REVOKED *r = sk_X509_REVOKED_value(revoked, i);
737
738 (void)BIO_reset(mem);
739 i2a_ASN1_INTEGER(mem, X509_REVOKED_get0_serialNumber(r));
740 result &= (((n = BIO_get_mem_data(mem, &p)) > 0) &&
741 PL_unify_list(list, item, list) &&
742 (revocation_date = PL_new_term_ref()) &&
743 unify_asn1_time(revocation_date, X509_REVOKED_get0_revocationDate(r)) &&
744 PL_unify_term(item,
745 PL_FUNCTOR, FUNCTOR_revoked2,
746 PL_NCHARS, (size_t)n, p,
747 PL_TERM, revocation_date));
748 if ( BIO_reset(mem) != 1 )
749 { BIO_free(mem);
750 // The only reason I can imagine this would fail is out of memory
751 return PL_resource_error("memory");
752 }
753 }
754
755 BIO_free(mem);
756 return result && PL_unify_nil(list);
757 }
758
759
760 static int
unify_rsa(term_t item,RSA * rsa)761 unify_rsa(term_t item, RSA* rsa)
762 {
763 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
764 return ( PL_unify_functor(item, FUNCTOR_rsa8) &&
765 unify_bignum_arg(1, item, rsa->n) &&
766 unify_bignum_arg(2, item, rsa->e) &&
767 unify_bignum_arg(3, item, rsa->d) &&
768 unify_bignum_arg(4, item, rsa->p) &&
769 unify_bignum_arg(5, item, rsa->q) &&
770 unify_bignum_arg(6, item, rsa->dmp1) &&
771 unify_bignum_arg(7, item, rsa->dmq1) &&
772 unify_bignum_arg(8, item, rsa->iqmp)
773 );
774 #else
775 const BIGNUM *n = NULL, *e = NULL, *d = NULL,
776 *p = NULL, *q = NULL,
777 *dmp1 = NULL, *dmq1 = NULL, *iqmp = NULL;
778 RSA_get0_key(rsa, &n, &e, &d);
779 RSA_get0_factors(rsa, &p, &q);
780 RSA_get0_crt_params(rsa, &dmp1, &dmq1, &iqmp);
781 return ( PL_unify_functor(item, FUNCTOR_rsa8) &&
782 unify_bignum_arg(1, item, n) &&
783 unify_bignum_arg(2, item, e) &&
784 unify_bignum_arg(3, item, d) &&
785 unify_bignum_arg(4, item, p) &&
786 unify_bignum_arg(5, item, q) &&
787 unify_bignum_arg(6, item, dmp1) &&
788 unify_bignum_arg(7, item, dmq1) &&
789 unify_bignum_arg(8, item, iqmp)
790 );
791 #endif
792 }
793
794 #ifndef OPENSSL_NO_EC
795 static int
unify_ec(term_t item,EC_KEY * key)796 unify_ec(term_t item, EC_KEY *key)
797 { unsigned char *buf = NULL;
798 int rc, publen;
799 term_t privkey, pubkey;
800
801 publen = i2o_ECPublicKey(key, &buf);
802
803 if ( publen < 0 )
804 return raise_ssl_error(ERR_get_error());
805
806 rc = ( (pubkey = PL_new_term_ref()) &&
807 (privkey = PL_new_term_ref()) &&
808 unify_bignum(privkey, EC_KEY_get0_private_key(key)) &&
809 unify_bytes_hex(pubkey, publen, buf) &&
810 PL_unify_term(item,
811 PL_FUNCTOR, FUNCTOR_ec3,
812 PL_TERM, privkey,
813 PL_TERM, pubkey,
814 PL_CHARS, OBJ_nid2sn(EC_GROUP_get_curve_name(EC_KEY_get0_group(key)))) );
815
816 OPENSSL_free(buf);
817 return rc;
818 }
819 #endif
820
821
822 static int
unify_key(EVP_PKEY * key,functor_t type,term_t item)823 unify_key(EVP_PKEY* key, functor_t type, term_t item)
824 { if ( !PL_unify_functor(item, type) ||
825 !PL_get_arg(1, item, item) )
826 return FALSE;
827
828 /* EVP_PKEY_get1_* returns a copy of the existing key */
829 switch (EVP_PKEY_base_id(key))
830 { int rc;
831 #ifndef OPENSSL_NO_RSA
832 case EVP_PKEY_RSA:
833 { RSA* rsa = EVP_PKEY_get1_RSA(key);
834 rc = unify_rsa(item, rsa);
835 RSA_free(rsa);
836 return rc;
837 }
838 #endif
839 #ifndef OPENSSL_NO_EC
840 case EVP_PKEY_EC:
841 { EC_KEY* ec = EVP_PKEY_get1_EC_KEY(key);
842 rc = unify_ec(item, ec);
843 EC_KEY_free(ec);
844 return rc;
845 }
846 #endif
847 #ifndef OPENSSL_NO_DH
848 case EVP_PKEY_DH:
849 { DH* dh = EVP_PKEY_get1_DH(key);
850 rc = PL_unify_atom_chars(item, "dh_key");
851 DH_free(dh);
852 return rc;
853 }
854 #endif
855 #ifndef OPENSSL_NO_DSA
856 case EVP_PKEY_DSA:
857 { DSA* dsa = EVP_PKEY_get1_DSA(key);
858 rc = PL_unify_atom_chars(item, "dsa_key");
859 DSA_free(dsa);
860 return rc;
861 }
862 #endif
863 default:
864 /* Unknown key type */
865 return PL_representation_error("ssl_key");
866 }
867 return TRUE;
868 }
869
870 static int
unify_public_key(EVP_PKEY * key,term_t item)871 unify_public_key(EVP_PKEY* key, term_t item)
872 { return unify_key(key, FUNCTOR_public_key1, item);
873 }
874
875 static int
unify_private_key(EVP_PKEY * key,term_t item)876 unify_private_key(EVP_PKEY* key, term_t item)
877 { return unify_key(key, FUNCTOR_private_key1, item);
878 }
879
880 #ifndef HAVE_X509_GET0_NOTBEFORE
881 #define X509_get0_notBefore(C) X509_get_notBefore(C)
882 #endif
883 #ifndef HAVE_X509_GET0_NOTAFTER
884 #define X509_get0_notAfter(C) X509_get_notAfter(C)
885 #endif
886
887 #ifndef GET0SIG_CONST_T
888 #define GET0SIG_CONST_T
889 #endif
890
891
892 static int
release_cert(atom_t atom)893 release_cert(atom_t atom)
894 { X509 *cert = PL_blob_data(atom, NULL, NULL);
895 X509_free(cert);
896 return TRUE;
897 }
898
899 static int
write_cert(IOSTREAM * s,atom_t symbol,int flags)900 write_cert(IOSTREAM *s, atom_t symbol, int flags)
901 { X509 *cert = PL_blob_data(symbol, NULL, NULL);
902 Sfprintf(s, "<ssl_certificate>(%p)", cert);
903 return TRUE;
904 }
905
906 static PL_blob_t certificate_type =
907 { PL_BLOB_MAGIC,
908 PL_BLOB_UNIQUE | PL_BLOB_NOCOPY,
909 "ssl_certificate",
910 release_cert,
911 NULL,
912 write_cert,
913 NULL
914 };
915
916 static int
unify_certificate_blob(term_t Cert,X509 * cert)917 unify_certificate_blob(term_t Cert, X509* cert)
918 { term_t blob = PL_new_term_ref();
919 PL_put_blob(blob, cert, sizeof(void*), &certificate_type);
920 return PL_unify(Cert, blob);
921 }
922
923 static int
unify_certificate_blob_copy(term_t Cert,X509 * cert)924 unify_certificate_blob_copy(term_t Cert, X509* cert)
925 { term_t blob = PL_new_term_ref();
926 PL_put_blob(blob, X509_dup(cert), sizeof(void*), &certificate_type);
927 return PL_unify(Cert, blob);
928 }
929
930
931 static int
get_certificate_blob(term_t Cert,X509 ** cert)932 get_certificate_blob(term_t Cert, X509** cert)
933 { PL_blob_t* type;
934 if (PL_get_blob(Cert, (void**)cert, NULL, &type) && type == &certificate_type)
935 return TRUE;
936 return PL_type_error("ssl_certificate", Cert);
937 }
938
939
940 static int
unify_certificate_copies(term_t certs,term_t tail,STACK_OF (X509)* stack)941 unify_certificate_copies(term_t certs, term_t tail, STACK_OF(X509)* stack)
942 { term_t item = PL_new_term_ref();
943 term_t list = PL_copy_term_ref(certs);
944 STACK_OF(X509) *copy = stack ? sk_X509_dup(stack) : NULL;
945 X509* cert = sk_X509_pop(copy);
946 int retval = 1;
947
948 while (cert != NULL && retval == 1)
949 { retval &= PL_unify_list(list, item, list);
950 retval &= unify_certificate_blob_copy(item, cert);
951 cert = sk_X509_pop(copy);
952 if (cert == NULL)
953 { sk_X509_free(copy);
954 return PL_unify(tail, item) && PL_unify_nil(list);
955 }
956 }
957 sk_X509_free(copy);
958 return retval && PL_unify_nil(list);
959 }
960
961 static int
unify_certificate_copies_inorder(term_t certs,STACK_OF (X509)* stack)962 unify_certificate_copies_inorder(term_t certs, STACK_OF(X509)* stack)
963 { term_t item = PL_new_term_ref();
964 term_t list = PL_copy_term_ref(certs);
965 STACK_OF(X509) *copy = stack ? sk_X509_dup(stack) : NULL;
966 X509* cert = sk_X509_shift(copy);
967 int retval = 1;
968
969 while (cert != NULL && retval == 1)
970 { retval &= PL_unify_list(list, item, list);
971 retval &= unify_certificate_blob_copy(item, cert);
972 cert = sk_X509_shift(copy);
973 }
974 sk_X509_free(copy);
975 return retval && PL_unify_nil(list);
976 }
977
978 static int
get_certificate_blobs(term_t Certs,STACK_OF (X509)** certs)979 get_certificate_blobs(term_t Certs, STACK_OF(X509) **certs)
980 { term_t tail = PL_copy_term_ref(Certs);
981 term_t head = PL_new_term_ref();
982 *certs = sk_X509_new_null();
983 int rc = 1;
984
985 while( rc && PL_get_list_ex(tail, head, tail) )
986 {
987 X509* cert;
988 rc &= get_certificate_blob(head, &cert);
989 rc &= sk_X509_push(*certs, cert);
990 }
991 rc &= PL_get_nil_ex(tail);
992 if (!rc)
993 { sk_X509_free(*certs);
994 *certs = NULL;
995 }
996 return rc;
997 }
998
999
1000 static foreign_t
pl_load_public_key(term_t source,term_t key_t)1001 pl_load_public_key(term_t source, term_t key_t)
1002 { EVP_PKEY* key;
1003 BIO* bio;
1004 IOSTREAM* stream;
1005 int c;
1006
1007 if ( !PL_get_stream_handle(source, &stream) )
1008 return FALSE;
1009 bio = BIO_new(bio_read_method());
1010 BIO_set_ex_data(bio, 0, stream);
1011
1012 /* Determine format */
1013 c = Speekcode(stream);
1014 if (c == 0x30) /* ASN.1 sequence, so assume DER */
1015 key = d2i_PUBKEY_bio(bio, NULL);
1016 else
1017 key = PEM_read_bio_PUBKEY(bio, NULL, NULL, NULL);
1018 BIO_free(bio);
1019 PL_release_stream(stream);
1020 if (key == NULL)
1021 return PL_permission_error("read", "key", source);
1022 if (!unify_public_key(key, key_t))
1023 { EVP_PKEY_free(key);
1024 PL_fail;
1025 }
1026 EVP_PKEY_free(key);
1027 PL_succeed;
1028 }
1029
1030
1031 static foreign_t
pl_load_private_key(term_t source,term_t password,term_t key_t)1032 pl_load_private_key(term_t source, term_t password, term_t key_t)
1033 { EVP_PKEY* key;
1034 BIO* bio;
1035 IOSTREAM* stream;
1036 char* password_chars;
1037 int c, rc;
1038
1039 if ( !PL_get_chars(password, &password_chars,
1040 CVT_ATOM|CVT_STRING|CVT_LIST|CVT_EXCEPTION) )
1041 return FALSE;
1042 if ( !PL_get_stream_handle(source, &stream) )
1043 return FALSE;
1044 bio = BIO_new(bio_read_method());
1045 BIO_set_ex_data(bio, 0, stream);
1046
1047 /* Determine format */
1048 c = Speekcode(stream);
1049 if (c == 0x30) /* ASN.1 sequence, so assume DER */
1050 key = d2i_PrivateKey_bio(bio, NULL); /* TBD: Password! */
1051 else
1052 key = PEM_read_bio_PrivateKey(bio, NULL, NULL, (void*)password_chars);
1053 BIO_free(bio);
1054 PL_release_stream(stream);
1055
1056 if ( key == NULL )
1057 return PL_permission_error("read", "key", source);
1058
1059 rc = (unify_private_key(key, key_t) != 0);
1060 EVP_PKEY_free(key);
1061
1062 return rc;
1063 }
1064
1065 static foreign_t
pl_load_crl(term_t source,term_t list)1066 pl_load_crl(term_t source, term_t list)
1067 { X509_CRL* crl;
1068 BIO* bio;
1069 IOSTREAM* stream;
1070 int result;
1071 int c;
1072
1073 if ( !PL_get_stream_handle(source, &stream) )
1074 return FALSE;
1075
1076 bio = BIO_new(bio_read_method());
1077 BIO_set_ex_data(bio, 0, stream);
1078 /* Determine the format of the CRL */
1079 c = Speekcode(stream);
1080 if (c == 0x30) /* ASN.1 sequence, so assume DER */
1081 crl = d2i_X509_CRL_bio(bio, NULL);
1082 else
1083 crl = PEM_read_bio_X509_CRL(bio, NULL, NULL, NULL);
1084 BIO_free(bio);
1085 PL_release_stream(stream);
1086 if (crl == NULL)
1087 { ssl_deb(2, "Failed to load CRL");
1088 PL_fail;
1089 }
1090 result = unify_crl(list, crl);
1091 X509_CRL_free(crl);
1092 return result;
1093 }
1094
1095 static foreign_t
pl_load_certificate(term_t source,term_t cert)1096 pl_load_certificate(term_t source, term_t cert)
1097 { X509* x509;
1098 BIO* bio;
1099 IOSTREAM* stream;
1100 int c = 0;
1101
1102 if ( !PL_get_stream_handle(source, &stream) )
1103 return FALSE;
1104 bio = BIO_new(bio_read_method());
1105 BIO_set_ex_data(bio, 0, stream);
1106 /* Determine format */
1107 c = Speekcode(stream);
1108 if (c == 0x30) /* ASN.1 sequence, so assume DER */
1109 x509 = d2i_X509_bio(bio, NULL);
1110 else
1111 x509 = PEM_read_bio_X509(bio, NULL, 0, NULL);
1112 BIO_free(bio);
1113 PL_release_stream(stream);
1114 if (x509 == NULL)
1115 return raise_ssl_error(ERR_get_error());
1116 return unify_certificate_blob(cert, x509);
1117 }
1118
1119 static foreign_t
load_certificates_from_file(char * filename,STACK_OF (X509)* certs)1120 load_certificates_from_file(char *filename, STACK_OF(X509)* certs)
1121 { X509* cert;
1122 int count = 0;
1123 FILE* fp = fopen(filename, "r");
1124 if (fp == NULL)
1125 return PL_existence_error("file", PL_new_atom(filename));
1126 while ((cert = PEM_read_X509(fp, NULL, NULL, NULL)) != NULL)
1127 { sk_X509_push(certs, cert);
1128 count++;
1129 }
1130 fclose(fp);
1131 return count > 0;
1132 }
1133
1134
1135 typedef struct
1136 {
1137 int index;
1138 int deterministic;
1139 X509* cert;
1140 term_t current_field;
1141 } field_enum;
1142
1143 static foreign_t
fetch_subject(term_t Field,X509 * cert)1144 fetch_subject(term_t Field, X509* cert)
1145 { return unify_name(Field, X509_get_subject_name(cert));
1146 }
1147
1148 static foreign_t
fetch_issuer(term_t Field,X509 * cert)1149 fetch_issuer(term_t Field, X509* cert)
1150 { return unify_name(Field, X509_get_issuer_name(cert));
1151 }
1152
1153
1154 static foreign_t
fetch_version(term_t Field,X509 * cert)1155 fetch_version(term_t Field, X509* cert)
1156 { return PL_unify_integer(Field, X509_get_version(cert));
1157 }
1158
1159 static foreign_t
fetch_serial(term_t Field,X509 * cert)1160 fetch_serial(term_t Field, X509* cert)
1161 { BIO * mem = NULL;
1162 long n;
1163 int rc = 0;
1164 unsigned char *p;
1165
1166 if ((mem = BIO_new(BIO_s_mem())) != NULL)
1167 { i2a_ASN1_INTEGER(mem, X509_get_serialNumber(cert));
1168 if ((n = BIO_get_mem_data(mem, &p)) > 0)
1169 rc = PL_unify_atom_nchars(Field, (size_t)n, (char*)p);
1170 BIO_vfree(mem);
1171 return rc;
1172 }
1173 return FALSE;
1174 }
1175
1176
1177 static foreign_t
fetch_not_before(term_t Field,X509 * cert)1178 fetch_not_before(term_t Field, X509* cert)
1179 { return unify_asn1_time(Field, X509_get0_notBefore(cert));
1180 }
1181
1182 static foreign_t
fetch_not_after(term_t Field,X509 * cert)1183 fetch_not_after(term_t Field, X509* cert)
1184 { return unify_asn1_time(Field, X509_get0_notAfter(cert));
1185 }
1186
1187
1188 static foreign_t
fetch_public_key(term_t Field,X509 * cert)1189 fetch_public_key(term_t Field, X509* cert)
1190 { EVP_PKEY *key;
1191 int rc;
1192 term_t arg = PL_new_term_ref();
1193 key = X509_get_pubkey(cert);
1194 rc = unify_public_key(key, arg);
1195 EVP_PKEY_free(key);
1196 /* Most existing code expects to be able to call memberchk(key(Key), Cert)
1197 and then pass Key to the rsa_* routines. This is a problem for this new
1198 interface, since calling certificate_field(Cert, public_key(Key)) will
1199 bind Key to an rsa/8. This means we have the slightly awkward result
1200 that calling certificate_field(Cert, public_key(Key)) will exit with
1201 binding certificate_field(Cert, public_key(public_key(rsa(....))))
1202 ie with two public_key/1 functors
1203 */
1204 return rc && PL_unify_term(Field, PL_FUNCTOR, FUNCTOR_public_key1, PL_TERM, arg);
1205 }
1206
1207 static foreign_t
fetch_crls(term_t Field,X509 * cert)1208 fetch_crls(term_t Field, X509* cert)
1209 { unsigned int crl_ext_id;
1210 X509_EXTENSION * crl_ext = NULL;
1211
1212 crl_ext_id = X509_get_ext_by_NID(cert, NID_crl_distribution_points, -1);
1213 crl_ext = X509_get_ext(cert, crl_ext_id);
1214 if (crl_ext != NULL)
1215 { STACK_OF(DIST_POINT) * distpoints;
1216 int i, j;
1217 term_t crl;
1218 term_t crl_list;
1219 term_t crl_item;
1220
1221 distpoints = X509_get_ext_d2i(cert, NID_crl_distribution_points, NULL, NULL);
1222 /* Loop through the CRL points, putting them into a list */
1223 crl = PL_new_term_ref();
1224 crl_list = PL_copy_term_ref(crl);
1225 crl_item = PL_new_term_ref();
1226
1227 for (i = 0; i < sk_DIST_POINT_num(distpoints); i++)
1228 { DIST_POINT *point;
1229 GENERAL_NAME *name;
1230 point = sk_DIST_POINT_value(distpoints, i);
1231 if (point->distpoint != NULL)
1232 { /* Each point may have several names? May as well put them all in */
1233 for (j = 0; j < sk_GENERAL_NAME_num(point->distpoint->name.fullname); j++)
1234 { name = sk_GENERAL_NAME_value(point->distpoint->name.fullname, j);
1235 if (name != NULL && name->type == GEN_URI)
1236 { if (!(PL_unify_list(crl_list, crl_item, crl_list) &&
1237 PL_unify_atom_chars(crl_item, (const char *)name->d.ia5->data)))
1238 {
1239 CRL_DIST_POINTS_free(distpoints);
1240 return FALSE;
1241 }
1242 }
1243 }
1244 }
1245 }
1246 CRL_DIST_POINTS_free(distpoints);
1247 return PL_unify_nil(crl_list) && PL_unify(Field, crl);
1248 }
1249 else
1250 { /* No CRL */
1251 return PL_unify_nil(Field);
1252 }
1253 }
1254
1255 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
1256 #define ASN1_STRING_get0_data(D) ASN1_STRING_data(D)
1257 #define X509_STORE_CTX_get0_cert(C) ((C)->cert)
1258 #endif
1259
1260
1261 static foreign_t
fetch_sans(term_t Field,X509 * cert)1262 fetch_sans(term_t Field, X509* cert)
1263 { unsigned int san_ext_id;
1264 X509_EXTENSION * san_ext = NULL;
1265
1266 san_ext_id = X509_get_ext_by_NID(cert, NID_subject_alt_name, -1);
1267 san_ext = X509_get_ext(cert, san_ext_id);
1268 if (san_ext != NULL)
1269 { STACK_OF(GENERAL_NAME) *san_names = NULL;
1270 GENERAL_NAME *name;
1271 term_t san, san_list, san_item;
1272 int i;
1273
1274 san_names = X509_get_ext_d2i(cert, NID_subject_alt_name, NULL, NULL);
1275 /* Loop through the SANs, putting them into a list */
1276 san = PL_new_term_ref();
1277 san_list = PL_copy_term_ref(san);
1278 san_item = PL_new_term_ref();
1279 for (i = 0; i < sk_GENERAL_NAME_num(san_names); i++)
1280 { name = sk_GENERAL_NAME_value(san_names, i);
1281 if (name != NULL && name->type == GEN_DNS)
1282 { if (!(PL_unify_list(san_list, san_item, san_list) &&
1283 PL_unify_atom_chars(san_item, (char*)ASN1_STRING_get0_data(name->d.dNSName))))
1284 { sk_GENERAL_NAME_pop_free(san_names, GENERAL_NAME_free);
1285 return FALSE;
1286 }
1287 }
1288 }
1289 sk_GENERAL_NAME_pop_free(san_names, GENERAL_NAME_free);
1290 return PL_unify_nil(san_list) && PL_unify(Field, san);
1291 }
1292 else
1293 { /* No SAN */
1294 return PL_unify_nil(Field);
1295 }
1296 }
1297
1298 static foreign_t
fetch_signature(term_t Field,X509 * cert)1299 fetch_signature(term_t Field, X509* cert)
1300 { GET0SIG_CONST_T ASN1_BIT_STRING *psig;
1301 GET0SIG_CONST_T X509_ALGOR *palg;
1302 X509_get0_signature(&psig, &palg, cert);
1303 return unify_bytes_hex(Field, psig->length, psig->data);
1304 }
1305
1306
1307 static foreign_t
fetch_signature_algorithm(term_t Field,X509 * cert)1308 fetch_signature_algorithm(term_t Field, X509* cert)
1309 { GET0SIG_CONST_T ASN1_BIT_STRING *psig;
1310 GET0SIG_CONST_T X509_ALGOR *palg;
1311 const char *salgorithm;
1312
1313 X509_get0_signature(&psig, &palg, cert);
1314 if ((salgorithm = OBJ_nid2sn(OBJ_obj2nid(palg->algorithm))) != NULL)
1315 { return PL_unify_chars(Field, PL_ATOM|REP_UTF8, strlen(salgorithm), salgorithm);
1316 }
1317 return FALSE;
1318 }
1319
1320 static foreign_t
fetch_hash(term_t Field,X509 * cert)1321 fetch_hash(term_t Field, X509* cert)
1322 { GET0SIG_CONST_T ASN1_BIT_STRING *psig;
1323 GET0SIG_CONST_T X509_ALGOR *palg;
1324
1325 X509_get0_signature(&psig, &palg, cert);
1326 #ifdef HAVE_X509_DIGEST
1327 return unify_hash(Field, palg->algorithm, hash_X509_digest_wrapper, cert);
1328 #else
1329 return unify_hash(Field, palg->algorithm, i2d_X509_CINF_wrapper, cert->cert_info);
1330 #endif
1331 }
1332
1333
1334
1335 #ifdef HAVE_I2D_RE_X509_TBS
1336 static foreign_t
fetch_to_be_signed(term_t Field,X509 * cert)1337 fetch_to_be_signed(term_t Field, X509* cert)
1338 { unsigned char *tbs = NULL;
1339 int tbs_len = i2d_re_X509_tbs(cert, &tbs);
1340 int rc = 0;
1341 if (tbs_len >= 0)
1342 rc = unify_bytes_hex(Field, tbs_len, tbs);
1343 OPENSSL_free(tbs);
1344 return rc;
1345 }
1346 #endif
1347
1348
1349 struct
1350 {
1351 const char* name;
1352 foreign_t (*fetch)(term_t, X509*);
1353 } certificate_fields[] = {{"subject", fetch_subject},
1354 {"issuer", fetch_issuer},
1355 {"not_before", fetch_not_before},
1356 {"not_after", fetch_not_after},
1357 {"version", fetch_version},
1358 {"serial", fetch_serial},
1359 {"public_key", fetch_public_key},
1360 {"crls", fetch_crls},
1361 {"sans", fetch_sans},
1362 {"signature", fetch_signature},
1363 {"signature_algorithm", fetch_signature_algorithm},
1364 {"hash", fetch_hash},
1365 #ifdef HAVE_I2D_RE_X509_TBS
1366 {"to_be_signed", fetch_to_be_signed},
1367 #endif
1368 {NULL, NULL}};
1369
1370
fetch_field(field_enum * state)1371 static int fetch_field(field_enum *state)
1372 { if (certificate_fields[state->index].name != 0)
1373 { term_t arg = PL_new_term_ref();
1374 int rc = certificate_fields[state->index].fetch(arg, state->cert);
1375 state->current_field = PL_new_term_ref();
1376 return rc && PL_unify_term(state->current_field,
1377 PL_FUNCTOR_CHARS, certificate_fields[state->index].name, 1,
1378 PL_TERM, arg);
1379 }
1380 return 0;
1381 }
1382
1383 static
pl_certificate_field(term_t Certificate,term_t Field,control_t handle)1384 foreign_t pl_certificate_field(term_t Certificate, term_t Field, control_t handle)
1385 { field_enum *state;
1386 switch(PL_foreign_control(handle))
1387 { case PL_FIRST_CALL:
1388 state = PL_malloc(sizeof(field_enum));
1389 memset(state, 0, sizeof(field_enum));
1390 if ( !get_certificate_blob(Certificate, &state->cert) )
1391 { PL_free(state);
1392 return FALSE;
1393 }
1394 if (!PL_is_variable(Field)) /* deterministic case */
1395 { atom_t name;
1396 size_t arity;
1397 const char* namec;
1398 if (!PL_get_name_arity(Field, &name, &arity) || arity != 1)
1399 { PL_free(state);
1400 return PL_type_error("field", Field);
1401 }
1402 namec = PL_atom_chars(name);
1403 while (certificate_fields[state->index].name != NULL)
1404 { if (strcmp(certificate_fields[state->index].name, namec) == 0)
1405 { state->deterministic = 1;
1406 break;
1407 }
1408 state->index++;
1409 }
1410 if (certificate_fields[state->index].name == 0)
1411 { PL_free(state);
1412 return PL_existence_error("field", Field);
1413 }
1414 }
1415 if (!fetch_field(state))
1416 { PL_free(state);
1417 PL_fail;
1418 }
1419 break;
1420 case PL_REDO:
1421 state = PL_foreign_context_address(handle);
1422 if (!fetch_field(state))
1423 { PL_free(state);
1424 PL_fail;
1425 }
1426 break;
1427 case PL_CUTTED:
1428 state = PL_foreign_context_address(handle);
1429 PL_free(state);
1430 PL_succeed;
1431 break;
1432 default:
1433 return FALSE;
1434 }
1435 if (PL_unify(Field, state->current_field))
1436 { if (state->deterministic)
1437 { PL_free(state);
1438 PL_succeed;
1439 }
1440 else
1441 { state->index++;
1442 PL_retry_address(state);
1443 }
1444 }
1445 else
1446 { PL_free(state);
1447 PL_fail;
1448 }
1449 }
1450
1451
1452 static foreign_t
pl_verify_certificate_issuer(term_t Certificate,term_t IssuerCertificate)1453 pl_verify_certificate_issuer(term_t Certificate, term_t IssuerCertificate)
1454 { X509* cert, *issuer_cert;
1455 if ( !get_certificate_blob(Certificate, &cert) )
1456 return FALSE;
1457 if ( !get_certificate_blob(IssuerCertificate, &issuer_cert) )
1458 return FALSE;
1459 return X509_check_issued(issuer_cert, cert) == X509_V_OK;
1460 }
1461
1462 static foreign_t
pl_same_certificate(term_t A,term_t B)1463 pl_same_certificate(term_t A, term_t B)
1464 { X509* a, *b;
1465 if ( !get_certificate_blob(A, &a) )
1466 return FALSE;
1467 if ( !get_certificate_blob(B, &b) )
1468 return FALSE;
1469 return X509_cmp(a, b) == 0;
1470 }
1471
1472 static foreign_t
pl_write_certificate(term_t Sink,term_t Cert,term_t Options)1473 pl_write_certificate(term_t Sink, term_t Cert, term_t Options)
1474 { X509* x509;
1475 BIO* bio;
1476 IOSTREAM* stream;
1477 int rc;
1478
1479 if ( !get_certificate_blob(Cert, &x509) )
1480 return FALSE;
1481 if ( !PL_get_stream_handle(Sink, &stream) )
1482 return FALSE;
1483
1484 bio = BIO_new(bio_write_text_method());
1485 BIO_set_ex_data(bio, 0, stream);
1486 rc = PEM_write_bio_X509(bio, x509);
1487 BIO_free(bio);
1488 PL_release_stream(stream);
1489 return rc;
1490 }
1491
1492
1493 static inline PL_SSL*
symbol_ssl(atom_t symbol)1494 symbol_ssl(atom_t symbol)
1495 { PL_SSL **confp = PL_blob_data(symbol, NULL, NULL);
1496 return *confp;
1497 }
1498
1499 static void
acquire_ssl(atom_t atom)1500 acquire_ssl(atom_t atom)
1501 { PL_SSL *conf = symbol_ssl(atom);
1502 conf->atom = atom;
1503 }
1504
1505 /*
1506 * Clean up all allocated resources.
1507 */
1508 static void
ssl_exit(PL_SSL * config)1509 ssl_exit(PL_SSL *config)
1510 { if ( config )
1511 { if (config->ctx)
1512 { ssl_deb(1, "Calling SSL_CTX_free()\n");
1513 SSL_CTX_free(config->ctx); /* doesn't call free hook? */
1514 } else
1515 { ssl_deb(1, "config without CTX encountered\n");
1516 }
1517 }
1518
1519 ssl_deb(1, "Controlled exit\n");
1520 }
1521
1522
1523 static int
release_ssl(atom_t atom)1524 release_ssl(atom_t atom)
1525 { PL_SSL *conf = symbol_ssl(atom);
1526 ssl_exit(conf); /* conf is freed by an internal call from OpenSSL
1527 via ssl_config_free() */
1528 return TRUE;
1529 }
1530
1531 static int
compare_ssl(atom_t a,atom_t b)1532 compare_ssl(atom_t a, atom_t b)
1533 { PL_SSL *ssla = symbol_ssl(a);
1534 PL_SSL *sslb = symbol_ssl(b);
1535
1536 return ( ssla > sslb ? 1 :
1537 ssla < sslb ? -1 : 0
1538 );
1539 }
1540
1541 static int
write_ssl(IOSTREAM * s,atom_t symbol,int flags)1542 write_ssl(IOSTREAM *s, atom_t symbol, int flags)
1543 { PL_SSL *ssl = symbol_ssl(symbol);
1544
1545 Sfprintf(s, "<ssl_context>(%p)", ssl);
1546
1547 return TRUE;
1548 }
1549
1550 static PL_blob_t ssl_context_type =
1551 { PL_BLOB_MAGIC,
1552 PL_BLOB_UNIQUE,
1553 "ssl_context",
1554 release_ssl,
1555 compare_ssl,
1556 write_ssl,
1557 acquire_ssl
1558 };
1559
1560
1561 static int
unify_conf(term_t config,PL_SSL * conf)1562 unify_conf(term_t config, PL_SSL *conf)
1563 { if ( PL_unify_blob(config, &conf, sizeof(conf), &ssl_context_type) )
1564 return TRUE;
1565
1566 ssl_exit(conf);
1567 if ( !PL_exception(0) )
1568 return PL_uninstantiation_error(config);
1569
1570 return FALSE;
1571 }
1572
1573
1574 static int
get_conf(term_t config,PL_SSL ** conf)1575 get_conf(term_t config, PL_SSL **conf)
1576 { PL_blob_t *type;
1577 void *data;
1578
1579 if ( PL_get_blob(config, &data, NULL, &type) && type == &ssl_context_type )
1580 { PL_SSL **sslp = data;
1581 PL_SSL *ssl = *sslp;
1582
1583 assert(ssl->magic == SSL_CONFIG_MAGIC);
1584 *conf = ssl;
1585
1586 return TRUE;
1587 }
1588
1589 return PL_type_error("ssl_context", config);
1590 }
1591
1592
1593 /*******************************
1594 * CALLBACK *
1595 *******************************/
1596
1597
1598 static char *
pl_pem_passwd_hook(PL_SSL * config,char * buf,int size)1599 pl_pem_passwd_hook(PL_SSL *config, char *buf, int size)
1600 { fid_t fid = PL_open_foreign_frame();
1601 term_t av = PL_new_term_refs(3);
1602 predicate_t call3 = PL_predicate("call", 3, NULL);
1603 char *passwd = NULL;
1604 size_t len;
1605
1606 /*
1607 * call(CB, +SSL, -Passwd)
1608 */
1609 PL_recorded(config->cb_pem_passwd.goal, av+0);
1610
1611 PL_put_atom(av+1, config->atom);
1612 if ( PL_call_predicate(config->cb_pem_passwd.module, PL_Q_PASS_EXCEPTION, call3, av) )
1613 { if ( PL_get_nchars(av+2, &len, &passwd, CVT_ALL) )
1614 { if ( len >= (unsigned int)size )
1615 { PL_warning("pem_passwd too long");
1616 } else
1617 { memcpy(buf, passwd, len+1);
1618 passwd = buf;
1619 }
1620 } else
1621 PL_warning("pem_passwd_hook returned wrong type");
1622 }
1623
1624 PL_close_foreign_frame(fid);
1625
1626 return passwd;
1627 }
1628
1629 static PL_SSL *
pl_sni_hook(PL_SSL * config,const char * host)1630 pl_sni_hook(PL_SSL *config, const char *host)
1631 { fid_t fid = PL_open_foreign_frame();
1632 term_t av = PL_new_term_refs(4);
1633
1634 predicate_t call4 = PL_predicate("call", 4, NULL);
1635 PL_SSL *new_config = NULL;
1636
1637 /*
1638 * call(CB, +SSL0, +Hostname, -SSL)
1639 */
1640 PL_recorded(config->cb_sni.goal, av+0);
1641 PL_put_atom(av+1, config->atom);
1642 if ( PL_unify_chars(av+2, PL_ATOM|REP_UTF8, strlen(host), host)
1643 && PL_call_predicate(config->cb_sni.module,
1644 PL_Q_PASS_EXCEPTION, call4, av) )
1645 if ( !get_conf(av+3, &new_config) )
1646 PL_warning("sni_hook returned wrong type");
1647
1648 PL_close_foreign_frame(fid);
1649 return new_config;
1650 }
1651
1652 #ifndef HAVE_X509_STORE_CTX_GET0_CHAIN
1653 #define X509_STORE_CTX_get0_chain(c) X509_STORE_CTX_get_chain(c)
1654 #endif
1655
1656 static BOOL
pl_cert_verify_hook(PL_SSL * config,X509 * cert,X509_STORE_CTX * ctx,const char * error,int error_unknown)1657 pl_cert_verify_hook(PL_SSL *config,
1658 X509 * cert,
1659 X509_STORE_CTX * ctx,
1660 const char *error,
1661 int error_unknown)
1662 { fid_t fid = PL_open_foreign_frame();
1663 term_t av = PL_new_term_refs(6);
1664 term_t error_term = PL_new_term_ref();
1665 predicate_t call6 = PL_predicate("call", 6, NULL);
1666 int val;
1667 STACK_OF(X509)* stack = X509_STORE_CTX_get0_chain(ctx);
1668
1669 PL_recorded(config->cb_cert_verify.goal, av+0);
1670
1671 /*
1672 * call(CB, +SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
1673 */
1674
1675 PL_put_atom(av+1, config->atom);
1676 if ( error_unknown )
1677 val = PL_unify_term(error_term,
1678 PL_FUNCTOR, FUNCTOR_unknown1,
1679 PL_CHARS, error);
1680 else
1681 val = PL_unify_atom_chars(error_term, error);
1682 /*Sdprintf("\n---Certificate:'%s'---\n", certificate);*/
1683 val &= ( unify_certificate_blob_copy(av+2, cert) &&
1684 unify_certificate_copies(av+3, av+4, stack) &&
1685 PL_unify(av+5, error_term) &&
1686 PL_call_predicate(config->cb_cert_verify.module,
1687 PL_Q_PASS_EXCEPTION, call6, av) );
1688
1689 PL_close_foreign_frame(fid);
1690
1691 return val;
1692 }
1693
1694
1695 /**
1696 * Raise syscall_error(id, string)
1697 * This should move to the kernel error system
1698 */
1699 static term_t
syscall_error(const char * op,int e)1700 syscall_error(const char *op, int e)
1701 { term_t ex;
1702
1703 if ( (ex = PL_new_term_ref()) &&
1704 PL_unify_term(ex,
1705 PL_FUNCTOR, FUNCTOR_error2,
1706 PL_FUNCTOR, FUNCTOR_ssl_error4,
1707 PL_CHARS, "syscall",
1708 PL_CHARS, op,
1709 PL_INT, e,
1710 PL_CHARS, strerror(e),
1711 PL_VARIABLE) )
1712 return ex;
1713
1714 return PL_exception(0);
1715 }
1716
1717 static term_t
unexpected_eof(PL_SSL_INSTANCE * instance)1718 unexpected_eof(PL_SSL_INSTANCE *instance)
1719 { term_t ex;
1720
1721 if ( (ex = PL_new_term_ref()) &&
1722 PL_unify_term(ex,
1723 PL_FUNCTOR, FUNCTOR_error2,
1724 PL_FUNCTOR, FUNCTOR_ssl_error4,
1725 PL_CHARS, "SSL_eof",
1726 PL_CHARS, "ssl",
1727 PL_CHARS, "negotiate",
1728 PL_CHARS, "Unexpected end-of-file",
1729 PL_VARIABLE) )
1730
1731 return ex;
1732
1733 return PL_exception(0);
1734 }
1735
1736
1737 /**
1738 * Inspect the error status. If an error occurs we want to pass this to
1739 * the Prolog layer. This is called from
1740 *
1741 * - ssl_ssl_bio(), which is called from ssl_negotiate/5. If an error
1742 * occurs we must call PL_raise_exception() or another exception
1743 * raising function.
1744 * - ssl_read() and ssl_write(). If an error occurs, we must set this
1745 * error on the filtered streams using Sseterr() or Sset_exception()
1746 */
1747
1748 typedef enum
1749 { STAT_NEGOTIATE,
1750 STAT_READ,
1751 STAT_WRITE
1752 } status_role;
1753
1754 static SSL_PL_STATUS
ssl_inspect_status(PL_SSL_INSTANCE * instance,int ssl_ret,status_role role)1755 ssl_inspect_status(PL_SSL_INSTANCE *instance, int ssl_ret, status_role role)
1756 { int code;
1757 int error;
1758
1759 if ( ssl_ret > 0 )
1760 return SSL_PL_OK;
1761
1762 code = SSL_get_error(instance->ssl, ssl_ret);
1763
1764 switch (code)
1765 { /* I am not sure what to do here - specifically, I am not sure if our
1766 underlying BIO will block if there is not enough data to complete
1767 a handshake. If it will, we should never get these return values.
1768 If it wont, then we presumably need to simply try again which is
1769 why I am returning SSL_PL_RETRY
1770 */
1771 case SSL_ERROR_WANT_READ:
1772 return SSL_PL_RETRY;
1773
1774 case SSL_ERROR_WANT_WRITE:
1775 return SSL_PL_RETRY;
1776
1777 #ifdef SSL_ERROR_WANT_CONNECT
1778 case SSL_ERROR_WANT_CONNECT:
1779 return SSL_PL_RETRY;
1780 #endif
1781
1782 #ifdef SSL_ERROR_WANT_ACCEPT
1783 case SSL_ERROR_WANT_ACCEPT:
1784 return SSL_PL_RETRY;
1785 #endif
1786
1787 case SSL_ERROR_ZERO_RETURN:
1788 return SSL_PL_OK;
1789
1790 case SSL_ERROR_SSL:
1791 instance->fatal_alert = TRUE;
1792 break;
1793
1794 default:
1795 break;
1796 }
1797
1798 /*
1799 It is hard to handle all possible cases correctly across
1800 different OpenSSL versions and for all BIO types.
1801
1802 For many releases, the OpenSSL documentation contained
1803 contradicting and wrong information. In OpenSSL 1.1.0c, the API
1804 changed (without notice) to return -1 when hitting EOF in
1805 SSL_read(). This change was later reverted.
1806
1807 The best description was given by Matt Caswell in:
1808
1809 https://github.com/openssl/openssl/issues/1903
1810
1811 "I should add that you can also use SSL_get_shutdown() to
1812 explicitly test whether a connection has been cleanly shutdown or
1813 not. This actually tells you slightly different information to
1814 SSL_get_error(), i.e. it tells you whether a shutdown alert has
1815 been received (i.e. a close_notify or a fatal error alert), or
1816 whether we have sent a close_notify ourselves. A connection is
1817 only fully and cleanly closed if we have both sent and received a
1818 close_notify.
1819
1820 "SSL_get_error() will tell you whether a close_notify has been
1821 received through SSL_ERROR_RETURN_ZERO. Receipt of a fatal alert
1822 will appear as SSL_ERROR_SSL from SSL_get_error() - although it
1823 could also mean some other kind of internal error has happened. A
1824 SSL_ERROR_SYSCALL return will tell you that some unknown error
1825 has occurred in a system call. This could be caused by an unclean
1826 shutdown.
1827
1828 "So, in summary, if you get a 0 or -1 return from
1829 SSL_read()/SSL_write(), you should call SSL_get_error():
1830
1831 "If you get back SSL_ERROR_RETURN_ZERO then you know the
1832 connection has been cleanly shutdown by the peer. To fully close
1833 the connection you may choose to call SSL_shutdown() to send a
1834 close_notify back. If you get back SSL_ERROR_SSL then some kind
1835 of internal or protocol error has occurred. More details will be
1836 on the SSL error queue. You can also call SSL_get_shutdown(). If
1837 this indicates a state of SSL_RECEIVED_SHUTDOWN then you know a
1838 fatal alert has been received from the peer (if it had been a
1839 close_notify then SSL_get_error() would have returned
1840 SSL_ERROR_RETURN_ZERO). SSL_ERROR_SSL is considered fatal - you
1841 should not call SSL_shutdown() in this case.
1842
1843 "If you get back SSL_ERROR_SYSCALL then some kind of fatal
1844 (i.e. non-retryable) error has occurred in a system call. You may
1845 be able to get more information from the SSL error queue or you
1846 might not. The fatal error could be because the underlying
1847 transport has been shutdown unexpectedly (no alert received) or
1848 just some other unknown system call error occurred. Calling
1849 BIO_eof() at this point will tell you whether the underlying
1850 transport has hit EOF (i.e. for a socket BIO the connection has
1851 been closed)."
1852
1853 Other things I found out:
1854
1855 -) BIO_eof() may return true even if data can still be read.
1856 -) How this all interacts with timeouts does not follow
1857 from the description above. It is not enough to check
1858 for EOF, even if one manages to do it correctly.
1859 */
1860
1861 error = ERR_get_error();
1862
1863 if ( code == SSL_ERROR_SYSCALL )
1864 { instance->fatal_alert = TRUE;
1865
1866 if ( (role == STAT_READ && Sferror(instance->dread)) ||
1867 (role == STAT_WRITE && Sferror(instance->dwrite)) )
1868 return SSL_PL_ERROR;
1869
1870 if ( role == STAT_READ && BIO_eof(SSL_get_rbio(instance->ssl)) )
1871 { if ( !instance->config->close_notify )
1872 return SSL_PL_OK;
1873 Sseterr(instance->dread, SIO_FERR, "SSL: unexpected end-of-file");
1874 } else if ( role == STAT_WRITE && BIO_eof(SSL_get_wbio(instance->ssl)) )
1875 { Sseterr(instance->dwrite, SIO_FERR, "SSL: unexpected end-of-file");
1876 } else if ( role == STAT_NEGOTIATE )
1877 { PL_raise_exception(error == 0 ? unexpected_eof(instance)
1878 : syscall_error("ssl_negotiate", errno));
1879 }
1880
1881 return SSL_PL_ERROR;
1882 }
1883
1884 switch(role)
1885 { case STAT_NEGOTIATE:
1886 raise_ssl_error(error);
1887 break;
1888 case STAT_READ:
1889 Sset_exception(instance->dread, ssl_error_term(error));
1890 break;
1891 case STAT_WRITE:
1892 Sset_exception(instance->dwrite, ssl_error_term(error));
1893 break;
1894 }
1895
1896 return SSL_PL_ERROR;
1897 }
1898
1899 static PL_SSL *
ssl_new(void)1900 ssl_new(void)
1901 /*
1902 * Allocate new state and configuration storage for an SSL session from PL
1903 */
1904 {
1905 PL_SSL *new = NULL;
1906 int i = 0;
1907
1908 if ((new = malloc(sizeof(*new))) != NULL) {
1909 new->role = PL_SSL_NONE;
1910
1911 new->close_parent = FALSE;
1912 new->atom = 0;
1913 new->close_notify = FALSE;
1914
1915 new->peer_cert = NULL;
1916 new->ctx = NULL;
1917 new->idx = -1;
1918 new->password = NULL;
1919
1920 new->min_protocol.is_set = FALSE;
1921 new->max_protocol.is_set = FALSE;
1922
1923 new->host = NULL;
1924
1925 new->cacerts = NULL;
1926 new->certificate_file = NULL;
1927 new->num_cert_key_pairs = 0;
1928 for (i = 0; i < SSL_MAX_CERT_KEY_PAIRS; i++)
1929 { new->cert_key_pairs[i].certificate_X509 = NULL;
1930 new->cert_key_pairs[i].key = NULL;
1931 new->cert_key_pairs[i].certificate = NULL;
1932 }
1933
1934 new->key_file = NULL;
1935 new->cipher_list = NULL;
1936 new->ecdh_curve = NULL;
1937 new->crl_list = NULL;
1938 new->peer_cert_required = FALSE;
1939 new->crl_required = FALSE;
1940 new->cb_sni.goal = NULL;
1941 new->cb_cert_verify.goal = NULL;
1942 new->cb_pem_passwd.goal = NULL;
1943 new->cb_alpn_proto.goal = NULL;
1944 #ifndef HAVE_X509_CHECK_HOST
1945 new->hostname_check_status = 0;
1946 #endif
1947 new->alpn_protos = NULL;
1948 new->alpn_protos_len = 0;
1949 new->magic = SSL_CONFIG_MAGIC;
1950 }
1951 ssl_deb(1, "Allocated config structure\n");
1952
1953 return new;
1954 }
1955
1956 /*
1957 * Free resources allocated to store the state and config parameters.
1958 */
1959 static void
ssl_free(PL_SSL * config)1960 ssl_free(PL_SSL *config)
1961 { if ( config )
1962 { int i;
1963 assert(config->magic == SSL_CONFIG_MAGIC);
1964 config->magic = 0;
1965 free(config->host);
1966 free_cacert_stack(config->cacerts);
1967 free(config->certificate_file);
1968 free(config->key_file);
1969 free(config->cipher_list);
1970 free(config->ecdh_curve);
1971 if ( config->crl_list )
1972 sk_X509_CRL_pop_free(config->crl_list, X509_CRL_free);
1973 for (i = 0; i < config->num_cert_key_pairs; i++)
1974 { X509_free(config->cert_key_pairs[i].certificate_X509);
1975 free(config->cert_key_pairs[i].certificate);
1976 free(config->cert_key_pairs[i].key);
1977 }
1978 free(config->password);
1979 X509_free(config->peer_cert);
1980
1981 if (config->cb_sni.goal) PL_erase(config->cb_sni.goal);
1982 if (config->cb_pem_passwd.goal) PL_erase(config->cb_pem_passwd.goal);
1983 if (config->cb_cert_verify.goal) PL_erase(config->cb_cert_verify.goal);
1984 if (config->cb_alpn_proto.goal) PL_erase(config->cb_alpn_proto.goal);
1985 if (config->alpn_protos) free(config->alpn_protos);
1986
1987 free(config);
1988 ssl_deb(1, "Released config structure\n");
1989 } else
1990 { ssl_deb(1, "No config structure to release\n");
1991 }
1992 }
1993
1994 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
1995 static int
1996 #else
1997 static void
1998 #endif
ssl_config_new(void * ctx,void * pl_ssl,CRYPTO_EX_DATA * parent_ctx,int parent_ctx_idx,long argl,void * argp)1999 ssl_config_new ( void * ctx
2000 , void * pl_ssl
2001 , CRYPTO_EX_DATA * parent_ctx
2002 , int parent_ctx_idx
2003 , long argl
2004 , void *argp
2005 )
2006 /*
2007 * Called when a new CTX is allocated
2008 */
2009 {
2010 PL_SSL *config = NULL;
2011
2012 if ((config = ssl_new()) != NULL) {
2013 if (SSL_CTX_set_ex_data( ctx
2014 , ctx_idx
2015 , config) == 0) {
2016 ssl_err("Cannot save application data\n");
2017 ssl_free(config);
2018 config = NULL;
2019 }
2020 }
2021
2022 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
2023 /*
2024 * 1 = success
2025 * 0 = failure
2026 */
2027 return (config != NULL);
2028 #endif
2029 }
2030
2031 static int
ssl_config_dup(CRYPTO_EX_DATA * to,CRYPTO_EX_DATA * from,void * pl_ssl,int parent_ctx_idx,long argl,void * argp)2032 ssl_config_dup(CRYPTO_EX_DATA *to,
2033 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
2034 CRYPTO_EX_DATA *from,
2035 #else
2036 const CRYPTO_EX_DATA *from,
2037 #endif
2038 void *pl_ssl,
2039 int parent_ctx_idx,
2040 long argl,
2041 void *argp)
2042 { return 1;
2043 }
2044
2045 static void
ssl_config_free(void * ctx,void * pl_ssl,CRYPTO_EX_DATA * parent_ctx,int parent_ctx_idx,long argl,void * argp)2046 ssl_config_free(void *ctx,
2047 void *pl_ssl,
2048 CRYPTO_EX_DATA *parent_ctx,
2049 int parent_ctx_idx,
2050 long argl,
2051 void *argp)
2052 { PL_SSL *config = NULL;
2053
2054 ssl_deb(1, "calling ssl_config_free()\n");
2055 if ( (config=SSL_CTX_get_ex_data(ctx, ctx_idx)))
2056 { assert(config->magic == SSL_CONFIG_MAGIC);
2057 ssl_free(config);
2058 }
2059 }
2060
2061
2062 /*
2063 * Function handling certificate verification
2064 */
2065
2066 static int
ssl_cb_cert_verify(int preverify_ok,X509_STORE_CTX * ctx)2067 ssl_cb_cert_verify(int preverify_ok, X509_STORE_CTX *ctx)
2068 { SSL *ssl = NULL;
2069 PL_SSL *config = NULL;
2070 /*
2071 * Get our config data
2072 */
2073 ssl = X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx());
2074 config = SSL_get_ex_data(ssl, ssl_idx);
2075
2076 ssl_deb(1, " ---- INIT Handling certificate verification\n");
2077 ssl_deb(1, " Certificate preverified %sok\n", preverify_ok ? "" : "NOT ");
2078 #ifndef HAVE_X509_CHECK_HOST
2079 /* If OpenSSL does not have X509_check_host() then the hostname has not yet been verified.
2080 Note that we only want to check the hostname of the FIRST certificate. There appears to be no easy way of
2081 telling which certificate we are up to. To try and manage this, state about hostname verification is stored
2082 in the PL_SSL object if X509_check_host() is not available.
2083
2084 We want to call the hook (if present - if not, we want to reject the whole certificate chain!) with this error
2085 and then proceed to the next error (if there is one). This means that behaviour will be consistent after
2086 upgrading to OpenSSL 1.0.2
2087 */
2088 if ( config->hostname_check_status == 0 && config->role == PL_SSL_CLIENT ) /* Not yet checked, and is a client - do not check for server */
2089 {
2090 /* This is a vastly simplified version. All we do is:
2091 1) For each alt subject name: If it is the same length as the hostname and strcmp() matches, then PASS
2092 2) : If it begins "*." and the hostname contains at least one ., and strcmp()
2093 matches from the first . in both expressions, AND the SAN contains no embedded
2094 NULLs, then PASS.
2095 3) Get the subject name. If it is the same length as the hostname and strcmp() matches, then PASS
2096 4) Otherwise, FAIL.
2097 */
2098 int i;
2099 X509 *cert = X509_STORE_CTX_get0_cert(ctx);
2100
2101 STACK_OF(GENERAL_NAME) *alt_names = X509_get_ext_d2i((X509 *)cert, NID_subject_alt_name, NULL, NULL);
2102 int alt_names_count = 0;
2103
2104 /* First, set status to 1 (invalid) */
2105 config->hostname_check_status = 1;
2106 if ( config->host != NULL)
2107 { if (alt_names != NULL)
2108 { alt_names_count = sk_GENERAL_NAME_num(alt_names);
2109 for (i = 0; i < alt_names_count && config->hostname_check_status != 2; i++)
2110 { const GENERAL_NAME *name = sk_GENERAL_NAME_value(alt_names, i);
2111 /* We are only interested in DNS names. We may also want to do IP addresses in future, by extending
2112 the type of config->host
2113 */
2114 if (name->type == GEN_DNS)
2115 { const char* hostname = (const char*)ASN1_STRING_get0_data(name->d.dNSName);
2116 size_t hostlen = ASN1_STRING_length(name->d.dNSName);
2117 if (hostlen == strlen(config->host) &&
2118 strcmp(config->host, hostname) == 0)
2119 { config->hostname_check_status = 2;
2120 ssl_deb(3, "Host that matches found in SAN %d: %s\n", i, ASN1_STRING_get0_data(name->d.dNSName));
2121 } else if (hostlen > 2 && hostname[0] == '*' && hostname[1] == '.' && strlen(hostname) == hostlen)
2122 { char* subdomain = strchr(config->host, '.');
2123 if (subdomain != NULL && strcmp(&hostname[1], subdomain) == 0)
2124 { config->hostname_check_status = 2;
2125 ssl_deb(3, "Host that matches with wildcard found in SAN %d: %s\n", i, hostname);
2126 }
2127 }
2128 else
2129 ssl_deb(3, "Host does not match SAN %d: %s\n", i, ASN1_STRING_get0_data(name->d.dNSName));
2130 }
2131 }
2132 }
2133 else
2134 ssl_deb(3, "Certificate has no SANs\n");
2135
2136
2137 /* If that didnt work, try the subject name itself. Naturally this has a completely different API */
2138 if ( config->hostname_check_status == 1 )
2139 { X509_NAME_ENTRY *common_name_entry;
2140 X509_NAME* subject_name = X509_get_subject_name((X509 *)cert);
2141 int common_name_index = X509_NAME_get_index_by_NID(subject_name, NID_commonName, -1);
2142 if (common_name_index != -1)
2143 { common_name_entry = X509_NAME_get_entry(subject_name, common_name_index);
2144 if (common_name_entry != NULL)
2145 { ASN1_STRING *common_name_asn1 = X509_NAME_ENTRY_get_data(common_name_entry);
2146 if (common_name_asn1 != NULL)
2147 { if (ASN1_STRING_length(common_name_asn1) == strlen(config->host) &&
2148 strcmp(config->host, (const char*)ASN1_STRING_get0_data(common_name_asn1)) == 0)
2149 { config->hostname_check_status = 2;
2150 ssl_deb(3, "Hostname in SN matches: %s\n", ASN1_STRING_get0_data(common_name_asn1));
2151 }
2152 else
2153 ssl_deb(3, "Hostname in SN does not match: %s vs %s\n", ASN1_STRING_get0_data(common_name_asn1), config->host);
2154 }
2155 }
2156 }
2157 }
2158 }
2159 if ( config->hostname_check_status == 1 )
2160 { ssl_deb(3, "Hostname could not be verified!\n");
2161 if ( config->cb_cert_verify.goal != NULL )
2162 { X509 *cert = X509_STORE_CTX_get_current_cert(ctx);
2163 preverify_ok = (pl_cert_verify_hook(config, cert, ctx, "hostname_mismatch", 0) != 0);
2164 }
2165 else
2166 /* Reject the whole chain if the hostname verification fails and there is no hook to override it */
2167 preverify_ok = 0;
2168 }
2169 }
2170 #endif
2171
2172 if ( !preverify_ok || config->cb_cert_verify.goal != NULL ) {
2173 X509 *cert = NULL;
2174 const char *error;
2175 int err;
2176 int error_unknown = 0;
2177 /*
2178 * Get certificate
2179 */
2180 cert = X509_STORE_CTX_get_current_cert(ctx);
2181
2182
2183 /*
2184 * Get error specification
2185 */
2186 if ( preverify_ok )
2187 { error = "verified";
2188 } else
2189 { err = X509_STORE_CTX_get_error(ctx);
2190 switch(err)
2191 {
2192 case X509_V_ERR_CERT_UNTRUSTED:
2193 error = "not_trusted";
2194 break;
2195 case X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT:
2196 case X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY:
2197 case X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE:
2198 error = "unknown_issuer";
2199 break;
2200 case X509_V_ERR_UNABLE_TO_GET_CRL:
2201 error = "unknown_crl";
2202 break;
2203 case X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE:
2204 case X509_V_ERR_CRL_SIGNATURE_FAILURE:
2205 error = "bad_crl_signature";
2206 break;
2207 case X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY:
2208 error = "bad_issuer_key";
2209 break;
2210 case X509_V_ERR_CERT_SIGNATURE_FAILURE:
2211 case X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE:
2212 error = "bad_signature";
2213 break;
2214 case X509_V_ERR_CERT_NOT_YET_VALID:
2215 error = "not_yet_valid";
2216 break;
2217 case X509_V_ERR_CERT_HAS_EXPIRED:
2218 error = "expired";
2219 break;
2220 case X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD:
2221 case X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD:
2222 case X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD:
2223 case X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD:
2224 error = "bad_time";
2225 break;
2226 case X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT:
2227 case X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN:
2228 error = "self_signed_cert";
2229 break;
2230 case X509_V_ERR_CERT_REVOKED:
2231 error = "revoked";
2232 break;
2233 case X509_V_ERR_INVALID_CA:
2234 error = "invalid_ca";
2235 break;
2236 case X509_V_ERR_KEYUSAGE_NO_CRL_SIGN:
2237 case X509_V_ERR_INVALID_PURPOSE:
2238 error = "bad_certificate_use";
2239 break;
2240 #ifdef X509_V_ERR_HOSTNAME_MISMATCH
2241 case X509_V_ERR_HOSTNAME_MISMATCH:
2242 error = "hostname_mismatch";
2243 break;
2244 #endif
2245 default:
2246 error_unknown = 1;
2247 error = X509_verify_cert_error_string(err);
2248 }
2249 }
2250
2251 if (config->cb_cert_verify.goal) {
2252 preverify_ok = (pl_cert_verify_hook(config, cert, ctx, error, error_unknown) != 0);
2253 } else {
2254 char subject[256];
2255 char issuer [256];
2256 int depth;
2257
2258 depth = X509_STORE_CTX_get_error_depth(ctx);
2259 X509_NAME_oneline(X509_get_subject_name(cert),
2260 subject, sizeof(subject));
2261 X509_NAME_oneline(X509_get_issuer_name (cert),
2262 issuer, sizeof(issuer));
2263 ssl_deb(1, "depth:%d\n", depth);
2264 ssl_deb(1, "error:%s\n", error);
2265 ssl_deb(1, "subject:%s\n", subject);
2266 ssl_deb(1, "issuer:%s\n", issuer);
2267 }
2268 }
2269 ssl_deb(1, " ---- EXIT Handling certificate verification (%saccepted)\n",
2270 preverify_ok ? "" : "NOT ");
2271
2272 return preverify_ok;
2273 }
2274
2275 /*
2276 * We're called since the OpenSSL library needs a password to access
2277 * the private key. The method to require the password is defined in
2278 * this function. Either interactive or automated.
2279 * Fill the supplied buffer with the password and return its length
2280 * or 0 on failure.
2281 */
2282
2283 static int
ssl_cb_pem_passwd(char * buf,int size,int rwflag,void * userdata)2284 ssl_cb_pem_passwd(char *buf, int size, int rwflag, void *userdata)
2285 { PL_SSL *config = userdata;
2286 char *passwd = NULL;
2287 int len = 0;
2288
2289 if ( config->cb_pem_passwd.goal )
2290 { passwd = pl_pem_passwd_hook(config, buf, size);
2291 } else if (config->password)
2292 { passwd = config->password;
2293 }
2294
2295 if ( passwd )
2296 { if ( (len = (int)strlen(passwd)) < size )
2297 strcpy(buf, passwd);
2298 else
2299 len = 0;
2300 }
2301
2302 return len;
2303 }
2304
2305
2306 #ifndef OPENSSL_NO_TLSEXT
2307 static int
ssl_cb_sni(SSL * s,int * ad,void * arg)2308 ssl_cb_sni(SSL *s, int *ad, void *arg)
2309 { PL_SSL *config = arg;
2310 PL_SSL *new_config = NULL;
2311 const char *servername;
2312
2313 if ( (servername = SSL_get_servername(s, TLSEXT_NAMETYPE_host_name)) )
2314 new_config = pl_sni_hook(config, servername);
2315
2316 if ( new_config == NULL &&
2317 config->certificate_file == NULL &&
2318 config->num_cert_key_pairs == 0 )
2319 return SSL_TLSEXT_ERR_NOACK;
2320
2321 SSL_set_SSL_CTX(s, new_config ? new_config->ctx : config->ctx );
2322
2323 return SSL_TLSEXT_ERR_OK;
2324 }
2325 #endif
2326
2327
2328 static int
ssl_close(PL_SSL_INSTANCE * instance)2329 ssl_close(PL_SSL_INSTANCE *instance)
2330 { int ret = 0;
2331
2332 if ( instance )
2333 { if ( (instance->config->role != PL_SSL_SERVER) ||
2334 instance->config->close_notify )
2335 { /* Send SSL/TLS close_notify, if no fatal alert has occurred. */
2336 if ( !instance->fatal_alert )
2337 { switch(SSL_shutdown(instance->ssl))
2338 { case 1: break; /* ok */
2339 case 2: break; /* TBD: not yet completed */
2340 case 3: break; /* TBD: undocumented */
2341 case -1: ret = -1; /* I/O error */
2342 }
2343 }
2344 }
2345
2346 if ( instance->ssl )
2347 SSL_free(instance->ssl);
2348
2349 if ( instance->swrite )
2350 Sset_filter(instance->swrite, NULL);
2351 if ( instance->sread )
2352 Sset_filter(instance->sread, NULL);
2353
2354 if ( instance->config->close_parent )
2355 { if ( instance->swrite )
2356 ret += Sclose(instance->swrite);
2357 if ( instance->sread )
2358 ret += Sclose(instance->sread);
2359 }
2360
2361 ssl_deb(4, "Decreasing atom count on %d\n", instance->config->atom);
2362 PL_unregister_atom(instance->config->atom);
2363
2364 free(instance);
2365 }
2366 #if OPENSSL_VERSION_NUMBER < 0x10100000L
2367 ERR_free_strings();
2368 #endif
2369
2370 ssl_deb(1, "Controlled close: %d\n", ret);
2371 return ret == 0 ? 0 : -1;
2372 }
2373
2374
2375
2376 static X509 *
ssl_peer_certificate(PL_SSL_INSTANCE * instance)2377 ssl_peer_certificate(PL_SSL_INSTANCE *instance)
2378 { if ( !instance->config->peer_cert )
2379 instance->config->peer_cert = SSL_get_peer_certificate(instance->ssl);
2380
2381 return instance->config->peer_cert;
2382 }
2383
2384
2385 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2386 ERR_print_errors_pl() is like ERR_print_errors_fp(stderr), but deals
2387 with the fact that on Windows stderr is generally lost, so we use Prolog
2388 I/O for portability.
2389 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2390
2391 static void
ERR_print_errors_pl()2392 ERR_print_errors_pl()
2393 { char errmsg[1024];
2394
2395 ERR_error_string_n(ERR_get_error(), errmsg, sizeof(errmsg));
2396 Sdprintf("%s\n", errmsg);
2397 }
2398
2399
2400 /*
2401 * Allocate the holder for our parameters which will specify the
2402 * configuration parameters and any other statefull parameter.
2403 * Load the OpenSSL error_strings for error reporting.
2404 * Define method for SSL layer depending on whether we're server or client.
2405 * Create SSL context.
2406 */
2407
2408 static PL_SSL *
ssl_init(PL_SSL_ROLE role,const SSL_METHOD * ssl_method)2409 ssl_init(PL_SSL_ROLE role, const SSL_METHOD *ssl_method)
2410 { PL_SSL *config = NULL;
2411 SSL_CTX *ssl_ctx = NULL;
2412
2413 ssl_ctx = SSL_CTX_new(ssl_method);
2414 if ( !ssl_ctx )
2415 { ERR_print_errors_pl();
2416 } else
2417 { long ctx_mode = 0L;
2418
2419 if ( !(config=SSL_CTX_get_ex_data(ssl_ctx, ctx_idx)) )
2420 { ssl_err("Cannot read back application data\n");
2421 SSL_CTX_free(ssl_ctx);
2422 return NULL;
2423 }
2424
2425 assert(config->magic == SSL_CONFIG_MAGIC);
2426 config->ctx = ssl_ctx;
2427 config->role = role;
2428 config->peer_cert_required = (role != PL_SSL_SERVER);
2429
2430 /*
2431 * Set SSL_{read,write} behaviour when a renegotiation takes place
2432 * in a blocking transport layer.
2433 */
2434 ctx_mode = SSL_CTX_get_mode(ssl_ctx);
2435 ctx_mode |= SSL_MODE_AUTO_RETRY;
2436 ctx_mode = SSL_CTX_set_mode(ssl_ctx, ctx_mode);
2437 }
2438
2439 ssl_deb(1, "Initialized\n");
2440
2441 return config;
2442 }
2443
2444
2445 #if !defined(__WINDOWS__) && !defined(HAVE_SECURITY_SECURITY_H)
2446 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2447 Extract the system certificate file from the Prolog flag
2448 system_cacert_filename
2449 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2450
2451 static const char *
system_cacert_filename(void)2452 system_cacert_filename(void)
2453 { fid_t fid;
2454 static char *cacert_filename = NULL;
2455
2456 if ( !cacert_filename )
2457 { if ( (fid = PL_open_foreign_frame()) )
2458 { term_t av = PL_new_term_refs(2);
2459 PL_put_atom_chars(av+0, "system_cacert_filename");
2460
2461 if ( PL_call_predicate(NULL, PL_Q_NORMAL,
2462 PL_predicate("current_prolog_flag", 2, "system"),
2463 av) )
2464 { char *s;
2465
2466 if ( PL_get_atom_chars(av+1, &s) )
2467 { char *old = cacert_filename;
2468 cacert_filename = strdup(s);
2469 free(old);
2470 }
2471 }
2472
2473 PL_close_foreign_frame(fid);
2474 }
2475 }
2476
2477 return cacert_filename;
2478 }
2479 #endif
2480
2481 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2482 ssl_system_verify_locations() adds trusted root certificates from OS
2483 dependent locations if cacert_file(system(root_certificates)) is passed.
2484
2485 The code is written after this StackOverflow message
2486 http://stackoverflow.com/questions/10095676/openssl-reasonable-default-for-trusted-ca-certificates
2487 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2488
STACK_OF(X509)2489 static STACK_OF(X509) *
2490 ssl_system_verify_locations(void)
2491 { STACK_OF(X509) *system_certs = sk_X509_new_null();
2492 int ok = TRUE;
2493
2494 if (!system_certs) return NULL;
2495
2496 #ifdef __WINDOWS__
2497 HCERTSTORE hSystemStore;
2498
2499 if ( (hSystemStore = CertOpenSystemStore(0, "ROOT")) )
2500 { PCCERT_CONTEXT pCertCtx = NULL;
2501
2502 while( (pCertCtx=CertEnumCertificatesInStore(hSystemStore, pCertCtx)) )
2503 { const unsigned char *ce = (unsigned char*)pCertCtx->pbCertEncoded;
2504
2505 X509 *cert = d2i_X509(NULL, &ce, (int)pCertCtx->cbCertEncoded);
2506 if ( cert )
2507 { if ( !sk_X509_push(system_certs, cert) )
2508 { ok = FALSE;
2509 break;
2510 }
2511 }
2512 }
2513
2514 CertCloseStore(hSystemStore, 0);
2515 }
2516 #elif defined(HAVE_SECURITY_SECURITY_H) /* __APPLE__ */
2517 SecKeychainRef keychain = NULL;
2518 OSStatus status;
2519 const char* keystoreLocations[] = {"/System/Library/Keychains/SystemRootCertificates.keychain",
2520 "/Library/Keychains/System.keychain",
2521 NULL};
2522 for (const char** keystoreLocation = keystoreLocations; *keystoreLocation; keystoreLocation++)
2523 { status = SecKeychainOpen(*keystoreLocation, &keychain);
2524 if ( status == errSecSuccess )
2525 { CFDictionaryRef query = NULL;
2526 CFArrayRef certs = NULL;
2527 CFArrayRef keychainSingleton = CFArrayCreate(NULL, (const void **)&keychain, 1, &kCFTypeArrayCallBacks);
2528 const void *keys[] = {kSecClass, kSecMatchSearchList, kSecMatchTrustedOnly, kSecReturnRef, kSecMatchLimit, kSecMatchValidOnDate};
2529 const void *values[] = {kSecClassCertificate, keychainSingleton, kCFBooleanTrue, kCFBooleanTrue, kSecMatchLimitAll, kCFNull};
2530 CFIndex i;
2531 CFIndex count;
2532 query = CFDictionaryCreate(NULL,
2533 keys,
2534 values,
2535 6,
2536 &kCFTypeDictionaryKeyCallBacks,
2537 &kCFTypeDictionaryValueCallBacks);
2538 status = SecItemCopyMatching(query, (CFTypeRef *)&certs);
2539 if (status == errSecSuccess)
2540 { count = CFArrayGetCount(certs);
2541 for (i = 0; i < count; i++)
2542 { const void *cert = CFArrayGetValueAtIndex(certs, i);
2543 CFDataRef cert_data = NULL;
2544 const unsigned char *der;
2545 unsigned long cert_data_length;
2546 X509 *x509 = NULL;
2547
2548 cert_data = SecCertificateCopyData((SecCertificateRef)cert);
2549 der = CFDataGetBytePtr(cert_data);
2550 cert_data_length = CFDataGetLength(cert_data);
2551 x509 = d2i_X509(NULL, &der, cert_data_length);
2552 CFRelease(cert_data);
2553 if ( x509 )
2554 { if ( !sk_X509_push(system_certs, x509) )
2555 { ok = FALSE;
2556 break;
2557 }
2558 }
2559 }
2560 CFRelease(certs);
2561 }
2562 CFRelease(query);
2563 CFRelease(keychainSingleton);
2564 CFRelease(keychain);
2565 }
2566 }
2567 #else
2568 { const char *cacert_filename;
2569 if ( (cacert_filename = system_cacert_filename()) )
2570 { X509 *cert = NULL;
2571 FILE *cafile = fopen(cacert_filename, "rb");
2572
2573 ssl_deb(1, "cacert_filename = %s\n", cacert_filename);
2574
2575 if ( cafile != NULL )
2576 { while ((cert = PEM_read_X509(cafile, NULL, NULL, NULL)) != NULL)
2577 { if ( !sk_X509_push(system_certs, cert) )
2578 { ok = FALSE;
2579 break;
2580 }
2581 }
2582 fclose(cafile);
2583 }
2584 }
2585 }
2586 #endif
2587
2588 if ( ok )
2589 { return system_certs;
2590 } else
2591 { sk_X509_pop_free(system_certs, X509_free);
2592 return NULL; /* no memory */
2593 }
2594 }
2595
2596
STACK_OF(X509)2597 static STACK_OF(X509) *
2598 system_root_certificates(void)
2599 { pthread_mutex_lock(&root_store_lock);
2600 if ( !system_root_store_fetched )
2601 { system_root_store_fetched = TRUE;
2602 system_root_store = ssl_system_verify_locations();
2603 }
2604 pthread_mutex_unlock(&root_store_lock);
2605
2606 return system_root_store;
2607 }
2608
2609
2610 static void
ssl_init_verify_locations(PL_SSL * config)2611 ssl_init_verify_locations(PL_SSL *config)
2612 { if ( config->cacerts )
2613 { X509_STORE *store = X509_STORE_new();
2614
2615 if ( store )
2616 { int index = 0;
2617 STACK_OF(X509) *cacerts = config->cacerts->cacerts;
2618
2619 while( index < sk_X509_num(cacerts) )
2620 { X509_STORE_add_cert(store, sk_X509_value(cacerts, index++));
2621 }
2622 SSL_CTX_set_cert_store(config->ctx, store);
2623 }
2624 ssl_deb(1, "certificate authority(s) installed from certificates\n");
2625 }
2626
2627 if ( config->crl_list )
2628 { X509_STORE *store = SSL_CTX_get_cert_store(config->ctx);
2629 int i = 0;
2630
2631 while (i < sk_X509_CRL_num(config->crl_list))
2632 { X509_STORE_add_crl(store, sk_X509_CRL_value(config->crl_list, i));
2633 i++;
2634 }
2635 }
2636 }
2637
2638 /* The following keys were generated with:
2639 $ openssl dhparam -C 2048
2640 (OpenSSL 1.0.1k 8 Jan 2015)
2641 */
2642
2643 #ifndef HEADER_DH_H
2644 #include <openssl/dh.h>
2645 #endif
2646 static DH *
get_dh2048(void)2647 get_dh2048(void)
2648 {
2649 static unsigned char dhp_2048[]={
2650 0xF9,0xE7,0xCF,0x81,0x2D,0xA6,0xA8,0x54,0x72,0xB3,0x6E,0x79,
2651 0x71,0x10,0x3C,0x46,0x8F,0xFF,0x79,0xDE,0xEA,0x2D,0xFD,0xD8,
2652 0x89,0xEB,0x17,0x0A,0x36,0x60,0x36,0x5C,0xB8,0xD7,0x57,0xB6,
2653 0x32,0x8C,0x05,0x35,0x29,0x66,0x11,0x74,0x57,0xFB,0x94,0xD9,
2654 0xF0,0x5E,0x7C,0x52,0xE5,0x15,0x88,0x41,0x80,0x3C,0x57,0x54,
2655 0x62,0xF3,0x5B,0x28,0x1C,0x3B,0x84,0x24,0x12,0xC7,0x9F,0x9B,
2656 0x07,0xE1,0xE8,0x42,0x00,0x28,0xD5,0x00,0xD7,0x59,0xC2,0x4B,
2657 0x4D,0xE9,0xAD,0xB2,0xBE,0x58,0xC2,0x95,0xB4,0xD0,0x27,0x80,
2658 0x9A,0x45,0x85,0xF2,0x6C,0xB1,0x99,0x40,0xB1,0x2E,0x57,0xB7,
2659 0xAF,0xAB,0xC2,0x47,0xC1,0xD1,0xA6,0x1D,0x98,0x0C,0x99,0x7C,
2660 0x13,0xDD,0x95,0xA4,0x8C,0xB0,0xBA,0x28,0xF3,0x2C,0xA7,0xAE,
2661 0x41,0x58,0x34,0x99,0xD7,0x2D,0x4C,0xB4,0x0B,0xC0,0xDE,0xAC,
2662 0x34,0xDD,0x63,0x8A,0x7E,0x51,0x0A,0x4A,0xB8,0x95,0xF2,0x0E,
2663 0xC9,0xF9,0xF5,0x23,0x99,0xF7,0xE0,0xC1,0x6B,0xE6,0xBD,0x8A,
2664 0xD5,0x3E,0xF8,0x87,0x56,0x9B,0xD0,0x00,0x5A,0x9C,0x60,0x56,
2665 0xFE,0x74,0x8D,0x42,0x4A,0x9E,0x6A,0xAC,0x74,0xE6,0x7D,0x12,
2666 0x66,0xCC,0x36,0x30,0x1B,0xC4,0xD7,0xBC,0x19,0xE0,0xAF,0x2B,
2667 0xE3,0x72,0x13,0x18,0xE7,0x29,0x89,0x82,0xC9,0xE4,0x30,0x1E,
2668 0x4F,0xE8,0xB0,0xBE,0x22,0x73,0x69,0x94,0x44,0x86,0x96,0xF7,
2669 0x77,0xD8,0xDB,0x68,0xB2,0x4E,0xFF,0xBA,0x35,0x69,0xD4,0x65,
2670 0xF3,0xAE,0xAB,0x88,0x2F,0x7A,0xD7,0x5E,0x98,0xFC,0xF5,0xCA,
2671 0xD4,0x43,0xB4,0xAB,
2672 };
2673 static unsigned char dhg_2048[]={
2674 0x02,
2675 };
2676
2677 DH *dh = DH_new();
2678 if (dh == NULL) return NULL;
2679
2680 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
2681 dh->p=BN_bin2bn(dhp_2048,sizeof(dhp_2048),NULL);
2682 dh->g=BN_bin2bn(dhg_2048,sizeof(dhg_2048),NULL);
2683 if ((dh->p == NULL) || (dh->g == NULL))
2684 { DH_free(dh); return(NULL); }
2685 #else
2686 BIGNUM *dhp_bn, *dhg_bn;
2687
2688 dhp_bn = BN_bin2bn(dhp_2048, sizeof (dhp_2048), NULL);
2689 dhg_bn = BN_bin2bn(dhg_2048, sizeof (dhg_2048), NULL);
2690 if (dhp_bn == NULL || dhg_bn == NULL
2691 || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) {
2692 DH_free(dh);
2693 BN_free(dhp_bn);
2694 BN_free(dhg_bn);
2695 return NULL;
2696 }
2697 #endif
2698 return dh;
2699 }
2700
2701
2702 #ifndef SSL_CTX_add0_chain_cert
2703 #define SSL_CTX_add0_chain_cert(CTX, C) SSL_CTX_add_extra_chain_cert(CTX, C)
2704 #endif
2705
2706 static int
ssl_use_certificate(PL_SSL * config,char * certificate,X509 ** ret)2707 ssl_use_certificate(PL_SSL *config, char *certificate, X509 **ret)
2708 {
2709 X509 *certX509;
2710
2711 BIO *bio = BIO_new_mem_buf(certificate, -1);
2712
2713 if ( !bio )
2714 return PL_resource_error("memory");
2715
2716 certX509 = PEM_read_bio_X509(bio, NULL, NULL, NULL);
2717 if ( !certX509 )
2718 return raise_ssl_error(ERR_get_error());
2719 *ret = certX509;
2720
2721 if ( SSL_CTX_use_certificate(config->ctx, certX509) <= 0 )
2722 return raise_ssl_error(ERR_get_error());
2723
2724 #ifdef SSL_CTX_clear_chain_certs
2725 if ( SSL_CTX_clear_chain_certs(config->ctx) <= 0 )
2726 return raise_ssl_error(ERR_get_error());
2727 #endif
2728
2729 while ( (certX509 = PEM_read_bio_X509(bio, NULL, NULL, NULL)) != NULL )
2730 { if ( SSL_CTX_add0_chain_cert(config->ctx, certX509) <= 0 )
2731 return raise_ssl_error(ERR_get_error());
2732 }
2733 ERR_clear_error(); /* clear error from "no further certificate" */
2734
2735 BIO_free(bio);
2736
2737 return TRUE;
2738 }
2739
2740 static int
ssl_use_key(PL_SSL * config,char * key)2741 ssl_use_key(PL_SSL *config, char *key)
2742 {
2743 BIO* bio = BIO_new_mem_buf(key, -1);
2744 EVP_PKEY *pkey;
2745 int r;
2746
2747 if ( !bio )
2748 return PL_resource_error("memory");
2749
2750 pkey = PEM_read_bio_PrivateKey(bio, NULL, ssl_cb_pem_passwd, config);
2751 BIO_free(bio);
2752
2753 if ( !pkey )
2754 return raise_ssl_error(ERR_get_error());
2755
2756 r = SSL_CTX_use_PrivateKey(config->ctx, pkey);
2757 EVP_PKEY_free(pkey);
2758
2759 if ( r <= 0 )
2760 return raise_ssl_error(ERR_get_error());
2761 return TRUE;
2762 }
2763
2764 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2765 Certificates and keys can be specified as files or via
2766 certificate_key_pairs/1.
2767 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2768
2769 static int
ssl_use_certificates(PL_SSL * config)2770 ssl_use_certificates(PL_SSL *config)
2771 {
2772 int cert_idx;
2773
2774 if ( config->certificate_file &&
2775 SSL_CTX_use_certificate_chain_file(config->ctx,
2776 config->certificate_file) <= 0 )
2777 return raise_ssl_error(ERR_get_error());
2778
2779 if ( config->key_file &&
2780 SSL_CTX_use_PrivateKey_file(config->ctx,
2781 config->key_file,
2782 SSL_FILETYPE_PEM) <= 0 )
2783 return raise_ssl_error(ERR_get_error());
2784
2785 if ( ( config->key_file || config->certificate_file ) &&
2786 ( SSL_CTX_check_private_key(config->ctx) <= 0 ) )
2787 { ssl_deb(1, "Private key does not match certificate public key\n");
2788 return raise_ssl_error(ERR_get_error());
2789 }
2790
2791
2792 for (cert_idx = 0; cert_idx < config->num_cert_key_pairs; cert_idx++)
2793 { X509 *cert_x509;
2794 if ( !ssl_use_certificate(config, config->cert_key_pairs[cert_idx].certificate, &cert_x509) ||
2795 !ssl_use_key(config, config->cert_key_pairs[cert_idx].key) )
2796 return FALSE;
2797 config->cert_key_pairs[cert_idx].certificate_X509 = cert_x509;
2798 }
2799 return TRUE;
2800 }
2801
2802 static void
ssl_init_sni(PL_SSL * config)2803 ssl_init_sni(PL_SSL *config)
2804 {
2805 #ifndef OPENSSL_NO_TLSEXT
2806 if ( config->role == PL_SSL_SERVER &&
2807 config->cb_sni.goal ) {
2808 SSL_CTX_set_tlsext_servername_callback(config->ctx, ssl_cb_sni);
2809 SSL_CTX_set_tlsext_servername_arg(config->ctx, config);
2810 ssl_deb(1, "installed SNI callback\n");
2811 }
2812 #endif
2813 }
2814
2815 static void
ssl_init_min_max_protocol(PL_SSL * config)2816 ssl_init_min_max_protocol(PL_SSL *config)
2817 {
2818 #ifdef SSL_CTX_set_min_proto_version
2819 if (config->min_protocol.is_set)
2820 SSL_CTX_set_min_proto_version(config->ctx, config->min_protocol.version);
2821 #endif
2822 #ifdef SSL_CTX_set_max_proto_version
2823 if (config->max_protocol.is_set)
2824 SSL_CTX_set_max_proto_version(config->ctx, config->max_protocol.version);
2825 #endif
2826 }
2827
2828
2829 #ifdef HAVE_SSL_CTX_SET_ALPN_PROTOS
2830
2831 static int
ssl_server_alpn_select_cb(SSL * ssl,const unsigned char ** out,unsigned char * outlen,const unsigned char * in,unsigned int inlen,void * arg)2832 ssl_server_alpn_select_cb(SSL *ssl,
2833 const unsigned char **out, unsigned char *outlen,
2834 const unsigned char *in, unsigned int inlen,
2835 void *arg)
2836 { PL_SSL *config = (PL_SSL*)arg;
2837
2838 if ( config->cb_alpn_proto.goal )
2839 { fid_t fid;
2840 int ret = SSL_TLSEXT_ERR_ALERT_FATAL;
2841
2842 if ( (fid = PL_open_foreign_frame()) )
2843 { term_t av, protos_list, protos_list_tail, head;
2844 unsigned int in_pos = 0;
2845
2846 if ( !(av = PL_new_term_refs(5)) ||
2847 !(protos_list = PL_new_term_ref()) ||
2848 !(protos_list_tail = PL_copy_term_ref(protos_list)) ||\
2849 !(head = PL_new_term_ref()) ||
2850 !PL_put_list(protos_list) )
2851 goto out;
2852
2853 while (in_pos < inlen)
2854 { unsigned char proto_len = in[in_pos];
2855 const unsigned char* proto = in + in_pos + 1;
2856
2857 if ( !PL_unify_list_ex(protos_list_tail, head, protos_list_tail) ||
2858 !PL_unify_chars(head, PL_ATOM|REP_UTF8, proto_len, (char*)proto) )
2859 goto out;
2860 in_pos += proto_len + 1;
2861 }
2862 if ( !PL_unify_nil(protos_list_tail) )
2863 goto out;
2864
2865 predicate_t call5 = PL_predicate("call", 5, "system");
2866
2867 /*
2868 * call(CB, +SSL0, +ClientProtos, -SSL1, -SelectedProtocol)
2869 */
2870 if ( !PL_recorded(config->cb_alpn_proto.goal, av+0) ||
2871 !PL_put_atom(av+1, config->atom) ||
2872 !PL_unify(av+2, protos_list) )
2873 goto out;
2874
2875 if ( !PL_call_predicate(config->cb_alpn_proto.module,
2876 PL_Q_PASS_EXCEPTION, call5, av) )
2877 goto out;
2878
2879 PL_SSL *new_config = NULL;
2880 if ( !get_conf(av+3, &new_config) )
2881 { PL_warning("alpn_protocol_hook return wrong type");
2882 goto out;
2883 }
2884 SSL_set_SSL_CTX(ssl, new_config ? new_config->ctx : config->ctx);
2885
2886 char *str;
2887 size_t olen;
2888 if ( PL_get_nchars(av+4, &olen, &str,
2889 CVT_ATOM|CVT_STRING|REP_UTF8|CVT_EXCEPTION) )
2890 { unsigned int i = 0;
2891
2892 while (i < inlen)
2893 { unsigned char plen = in[i];
2894 const unsigned char *pstr = in + i + 1;
2895 if ( plen == olen && strncmp(str, (const char*)pstr, plen) == 0 )
2896 { *out = pstr;
2897 *outlen = plen;
2898 ret = SSL_TLSEXT_ERR_OK;
2899 goto out;
2900 }
2901 i += plen + 1;
2902 }
2903 } else
2904 { PL_domain_error("alpn protocol", av+4);
2905 }
2906
2907 out:
2908 PL_close_foreign_frame(fid);
2909 }
2910
2911 return ret;
2912 } else
2913 { int ret = SSL_select_next_proto((unsigned char**)out, outlen,
2914 config->alpn_protos, config->alpn_protos_len,
2915 in, inlen);
2916 if ( ret == OPENSSL_NPN_NEGOTIATED )
2917 return SSL_TLSEXT_ERR_OK;
2918 else
2919 return SSL_TLSEXT_ERR_ALERT_FATAL;
2920 }
2921 }
2922
2923 static void
ssl_init_alpn_protos(PL_SSL * config)2924 ssl_init_alpn_protos(PL_SSL *config)
2925 {
2926 if ( config->alpn_protos ||
2927 ( config->role == PL_SSL_SERVER && config->cb_alpn_proto.goal ) ) {
2928 if ( config->role == PL_SSL_CLIENT ) {
2929 SSL_CTX_set_alpn_protos(config->ctx, config->alpn_protos, config->alpn_protos_len);
2930 } else if ( config->role == PL_SSL_SERVER ) {
2931 SSL_CTX_set_alpn_select_cb(config->ctx, &ssl_server_alpn_select_cb, config);
2932 }
2933 }
2934 }
2935
2936 #endif /*HAVE_SSL_CTX_SET_ALPN_PROTOS*/
2937
2938 static int
set_malleable_options(PL_SSL * config)2939 set_malleable_options(PL_SSL *config)
2940 {
2941
2942 #ifndef OPENSSL_NO_EC
2943 EC_KEY *ecdh;
2944 int nid;
2945 #if OPENSSL_VERSION_NUMBER < 0x10100000L
2946 char *curve = "prime256v1";
2947 #else
2948 /* In OpenSSL >= 1.1.0, ECDH support is always enabled. Therefore,
2949 * if ecdh_curve/1 is not specified, we use the existing defaults.
2950 *
2951 * In fact, OpenSSL 1.1.0 provides the new function
2952 * SSL_CTX_set1_groups, which generalizes SSL_CTX_set_tmp_ecdh in
2953 * that it lets us specify a *set* of curves and other groups.
2954 * We should provide a binding for the more general function.
2955 */
2956 char *curve = NULL;
2957 #endif
2958
2959 if (config->ecdh_curve)
2960 curve = config->ecdh_curve;
2961
2962 if (curve)
2963 { nid = OBJ_sn2nid(curve);
2964 if ( !(ecdh = EC_KEY_new_by_curve_name(nid)) )
2965 return raise_ssl_error(ERR_get_error());
2966 if ( !SSL_CTX_set_tmp_ecdh(config->ctx, ecdh) )
2967 return raise_ssl_error(ERR_get_error());
2968 EC_KEY_free(ecdh); /* Safe because of reference counts */
2969 }
2970 #endif
2971
2972 if ( config->cipher_list &&
2973 !SSL_CTX_set_cipher_list(config->ctx, config->cipher_list))
2974 return raise_ssl_error(ERR_get_error());
2975
2976 (void) SSL_CTX_set_verify(config->ctx,
2977 config->peer_cert_required ?
2978 SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT :
2979 SSL_VERIFY_NONE,
2980 ssl_cb_cert_verify);
2981 ssl_deb(1, "installed certificate verification handler\n");
2982
2983 ssl_init_sni(config);
2984 ssl_init_min_max_protocol(config);
2985 #ifdef HAVE_SSL_CTX_SET_ALPN_PROTOS
2986 ssl_init_alpn_protos(config);
2987 #endif
2988
2989 return TRUE;
2990 }
2991
2992
2993 static int
ssl_config(PL_SSL * config)2994 ssl_config(PL_SSL *config)
2995 /*
2996 * Initialize various SSL layer parameters using the supplied
2997 * config parameters.
2998 */
2999 { static DH *dh_2048 = NULL;
3000
3001 ssl_init_verify_locations(config);
3002
3003 SSL_CTX_set_default_passwd_cb_userdata(config->ctx, config);
3004 SSL_CTX_set_default_passwd_cb(config->ctx, ssl_cb_pem_passwd);
3005 ssl_deb(1, "password handler installed\n");
3006
3007 if ( config->certificate_file ||
3008 config->key_file ||
3009 ( config->num_cert_key_pairs > 0 ) )
3010 { if ( !ssl_use_certificates(config) )
3011 return FALSE;
3012 ssl_deb(1, "certificates installed successfully\n");
3013 }
3014
3015 if ( !dh_2048 ) dh_2048 = get_dh2048();
3016 SSL_CTX_set_tmp_dh(config->ctx, dh_2048);
3017
3018 return set_malleable_options(config);
3019 }
3020
3021
3022 static PL_SSL_INSTANCE *
ssl_instance_new(PL_SSL * config,IOSTREAM * sread,IOSTREAM * swrite)3023 ssl_instance_new(PL_SSL *config, IOSTREAM* sread, IOSTREAM* swrite)
3024 { PL_SSL_INSTANCE *new = NULL;
3025
3026 if ((new = malloc(sizeof(PL_SSL_INSTANCE))) != NULL)
3027 { memset(new, 0, sizeof(*new));
3028 new->config = config;
3029 new->sread = sread;
3030 new->swrite = swrite;
3031 new->fatal_alert = FALSE;
3032 }
3033
3034 return new;
3035 }
3036
3037 static int
ssl_lib_init(void)3038 ssl_lib_init(void)
3039 /*
3040 * One-time library initialization code
3041 */
3042 {
3043 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
3044 (void) SSL_library_init();
3045 SSL_load_error_strings();
3046 #endif
3047
3048 if ((ctx_idx = SSL_CTX_get_ex_new_index( 0
3049 , NULL
3050 , ssl_config_new
3051 , ssl_config_dup
3052 , ssl_config_free
3053 )) < 0) {
3054 ssl_err("Cannot register application data\n");
3055 return -1;
3056 }
3057
3058 /*
3059 * Index used to store our config data in the SSL data structure
3060 */
3061 ssl_idx = SSL_get_ex_new_index(0, "config", NULL, NULL, NULL);
3062
3063 #ifdef __SWI_PROLOG__
3064 FUNCTOR_error2 = PL_new_functor(PL_new_atom("error"), 2);
3065 FUNCTOR_ssl_error4 = PL_new_functor(PL_new_atom("ssl_error"), 4);
3066 #endif
3067
3068 return 0;
3069 }
3070
3071 static int
ssl_lib_exit(void)3072 ssl_lib_exit(void)
3073 /*
3074 * One-time library exit calls
3075 */
3076 {
3077 return 0;
3078 }
3079
3080
3081 /*
3082 * Establish an SSL session using the given read and write streams
3083 * and the role
3084 */
3085 static int
ssl_ssl_bio(PL_SSL * config,IOSTREAM * sread,IOSTREAM * swrite,PL_SSL_INSTANCE ** instancep)3086 ssl_ssl_bio(PL_SSL *config, IOSTREAM* sread, IOSTREAM* swrite,
3087 PL_SSL_INSTANCE** instancep)
3088 { PL_SSL_INSTANCE *instance;
3089 BIO *rbio = BIO_new(bio_read_method());
3090 BIO *wbio = BIO_new(bio_write_method());
3091
3092 if ( rbio == NULL ||
3093 wbio == NULL )
3094 return raise_ssl_error(ERR_get_error());
3095
3096 if ( !(instance=ssl_instance_new(config, sread, swrite)) )
3097 return PL_resource_error("memory");
3098
3099 BIO_set_ex_data(rbio, 0, sread);
3100 BIO_set_ex_data(wbio, 0, swrite);
3101
3102 if ( config->crl_required )
3103 { X509_STORE_set_flags(SSL_CTX_get_cert_store(config->ctx),
3104 X509_V_FLAG_CRL_CHECK|X509_V_FLAG_CRL_CHECK_ALL);
3105 }
3106
3107
3108 if ( !(instance->ssl = SSL_new(config->ctx)) )
3109 { free(instance);
3110 return raise_ssl_error(ERR_get_error());
3111 }
3112
3113 if ( config->role == PL_SSL_CLIENT )
3114 {
3115 #ifndef OPENSSL_NO_TLSEXT
3116 if ( config->host )
3117 SSL_set_tlsext_host_name(instance->ssl, config->host);
3118 #endif
3119 #ifdef HAVE_X509_CHECK_HOST
3120 #if (defined(HAVE_X509_VERIFY_PARAM_ID) || OPENSSL_VERSION_NUMBER >= 0x10100000L) && !defined(LIBRESSL_VERSION_NUMBER)
3121 X509_VERIFY_PARAM *param = SSL_get0_param(instance->ssl);
3122 /* This could in theory be user-configurable. The documentation at
3123 https://wiki.openssl.org/index.php/Manual:X509_check_host(3)
3124 says that the flag is 'usually 0', however
3125 */
3126 /* X509_VERIFY_PARAM_set_hostflags(param,
3127 X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS);
3128 */
3129 X509_VERIFY_PARAM_set_hostflags(param, 0);
3130 X509_VERIFY_PARAM_set1_host(param, config->host, 0);
3131 #endif
3132 #endif
3133 }
3134
3135 SSL_set_session_id_context(instance->ssl, (unsigned char*)"SWI-Prolog", 10);
3136 ssl_deb(1, "allocated ssl layer\n");
3137
3138 SSL_set_ex_data(instance->ssl, ssl_idx, config);
3139 SSL_set_bio(instance->ssl, rbio, wbio); /* No return value */
3140 ssl_deb(1, "allocated ssl fd\n");
3141
3142 for(;;)
3143 { int ssl_ret;
3144
3145 ssl_deb(1, "Negotiating %s ...\n",
3146 config->role == PL_SSL_SERVER ? "server" : "client");
3147 ssl_ret = (config->role == PL_SSL_SERVER ?
3148 SSL_accept(instance->ssl) :
3149 SSL_connect(instance->ssl));
3150
3151 switch( ssl_inspect_status(instance, ssl_ret, STAT_NEGOTIATE) )
3152 { case SSL_PL_OK:
3153 ssl_deb(1, "established ssl connection\n");
3154 *instancep = instance;
3155 #if defined(TLS1_3_VERSION) && defined(EPIPE)
3156 if ( config->role == PL_SSL_SERVER &&
3157 strcmp(SSL_get_version(instance->ssl), "TLSv1.3") == 0 &&
3158 SSL_get_error(instance->ssl, 0) == SSL_ERROR_SYSCALL &&
3159 errno == EPIPE )
3160 { Sclearerr(swrite); PL_clear_exception();
3161 }
3162 #endif
3163 return TRUE;
3164 case SSL_PL_RETRY:
3165 ssl_deb(1, "retry ssl connection\n");
3166 continue;
3167 case SSL_PL_ERROR:
3168 ssl_deb(1, "failed ssl connection\n");
3169 SSL_free(instance->ssl);
3170 free(instance);
3171 return FALSE;
3172 }
3173 }
3174 }
3175
3176 /*
3177 * Perform read on SSL session
3178 */
3179 static ssize_t
ssl_read(void * handle,char * buf,size_t size)3180 ssl_read(void *handle, char *buf, size_t size)
3181 { PL_SSL_INSTANCE *instance = handle;
3182 SSL *ssl = instance->ssl;
3183
3184 assert(ssl != NULL);
3185
3186 for(;;)
3187 { int rbytes = SSL_read(ssl, buf, size);
3188
3189 switch(ssl_inspect_status(instance, rbytes, STAT_READ))
3190 { case SSL_PL_OK:
3191 if (rbytes <= 0) /* SSL_read() returns -1 on EOF in OpenSSL 1.1.0c! */
3192 return 0; /* We handle EOF in Prolog. */
3193 return rbytes;
3194 case SSL_PL_RETRY:
3195 continue;
3196 case SSL_PL_ERROR:
3197 return -1;
3198 }
3199 }
3200 }
3201
3202 /*
3203 * Perform write on SSL session
3204 */
3205 static ssize_t
ssl_write(void * handle,char * buf,size_t size)3206 ssl_write(void *handle, char *buf, size_t size)
3207 { PL_SSL_INSTANCE *instance = handle;
3208 SSL *ssl = instance->ssl;
3209
3210 assert(ssl != NULL);
3211
3212 for(;;)
3213 { int wbytes = SSL_write(ssl, buf, size);
3214
3215 switch(ssl_inspect_status(instance, wbytes, STAT_WRITE))
3216 { case SSL_PL_OK:
3217 return wbytes;
3218 case SSL_PL_RETRY:
3219 continue;
3220 case SSL_PL_ERROR:
3221 return -1;
3222 }
3223 }
3224 }
3225
3226 static int
protocol_version_to_integer(const term_t symbol,int * version)3227 protocol_version_to_integer(const term_t symbol, int *version)
3228 {
3229 atom_t arg;
3230
3231 if ( !PL_get_atom_ex(symbol, &arg) )
3232 return FALSE;
3233
3234 #ifdef SSL_CTX_set_min_proto_version
3235 if ( arg == ATOM_sslv3 )
3236 *version = SSL3_VERSION;
3237 else if ( arg == ATOM_tlsv1 )
3238 *version = TLS1_VERSION;
3239 else if ( arg == ATOM_tlsv1_1 )
3240 *version = TLS1_1_VERSION;
3241 else if ( arg == ATOM_tlsv1_2 )
3242 *version = TLS1_2_VERSION;
3243 #ifdef TLS1_3_VERSION
3244 else if ( arg == ATOM_tlsv1_3 )
3245 *version = TLS1_3_VERSION;
3246 #endif
3247 else
3248 return PL_domain_error("ssl_protocol_version", symbol);
3249 #else
3250 *version = 0; /* prevent compiler warning */
3251 #endif
3252
3253 return TRUE;
3254 }
3255
3256 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257 We call an option *malleable* if it can be set not only when the
3258 context is created, but also later via ssl_set_options/3. Not all
3259 options fall into this category: Notably, it is not yet documented
3260 what OpenSSL does if a certificate and key are later replaced.
3261
3262 Therefore, we split option processing between malleable options and
3263 those that can only be set when the context is being created.
3264
3265 Note an important design principle:
3266
3267 We *never* destructively modify an existing Prolog SSL context.
3268 ---------------------------------------------------------------
3269
3270 Instead, when setting any options for an existing context, the
3271 context is always first duplicated, and the options are set on the
3272 copy! This is critical to ensure that all code stays thread-safe at
3273 the Prolog level.
3274
3275 I mention this explicitly because the OpenSSL API makes it
3276 extremely tempting to modify some paramaters destructively.
3277 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3278
3279 static int
parse_malleable_options(PL_SSL * conf,module_t module,term_t options)3280 parse_malleable_options(PL_SSL *conf, module_t module, term_t options)
3281 { term_t tail = PL_copy_term_ref(options);
3282 term_t head = PL_new_term_ref();
3283
3284 while( PL_get_list_ex(tail, head, tail) )
3285 { atom_t name;
3286 size_t arity;
3287
3288 if ( !(PL_get_name_arity(head, &name, &arity) && arity == 1) )
3289 return PL_type_error("ssl_option", head);
3290
3291 if ( name == ATOM_cipher_list )
3292 { char *s;
3293
3294 if ( !get_char_arg(1, head, &s) )
3295 return FALSE;
3296
3297 set_string(conf, cipher_list, s);
3298 } else if ( name == ATOM_ecdh_curve )
3299 { char *s;
3300
3301 if ( !get_char_arg(1, head, &s) )
3302 return FALSE;
3303
3304 set_string(conf, ecdh_curve, s);
3305 } else if ( name == ATOM_host )
3306 { char *s;
3307
3308 if ( !get_char_arg(1, head, &s) )
3309 return FALSE;
3310
3311 set_string(conf, host, s);
3312 } else if ( name == ATOM_peer_cert )
3313 { int val;
3314
3315 if ( !get_bool_arg(1, head, &val) )
3316 return FALSE;
3317
3318 conf->peer_cert_required = val;
3319 } else if ( name == ATOM_cert_verify_hook )
3320 { term_t cb = PL_new_term_ref();
3321 _PL_get_arg(1, head, cb);
3322
3323 if (conf->cb_cert_verify.goal)
3324 PL_erase(conf->cb_cert_verify.goal);
3325
3326 conf->cb_cert_verify.goal = PL_record(cb);
3327 conf->cb_cert_verify.module = module;
3328 } else if ( name == ATOM_close_parent )
3329 { int val;
3330
3331 if ( !get_bool_arg(1, head, &val) )
3332 return FALSE;
3333
3334 conf->close_parent = val;
3335 } else if ( name == ATOM_disable_ssl_methods )
3336 { term_t opt_head = PL_new_term_ref();
3337 term_t opt_tail = PL_new_term_ref();
3338 long options = 0;
3339 long isset;
3340
3341 _PL_get_arg(1, head, opt_tail);
3342 while( PL_get_list_ex(opt_tail, opt_head, opt_tail) )
3343 { atom_t option_name;
3344 if ( !PL_get_atom_ex(opt_head, &option_name) )
3345 return FALSE;
3346 if (option_name == ATOM_sslv2)
3347 options |= SSL_OP_NO_SSLv2;
3348 else if (option_name == ATOM_sslv23)
3349 options |= SSL_OP_NO_SSLv3 | SSL_OP_NO_SSLv2;
3350 else if (option_name == ATOM_sslv3)
3351 options |= SSL_OP_NO_SSLv3;
3352 #ifdef SSL_OP_NO_TLSv1
3353 else if (option_name == ATOM_tlsv1)
3354 options |= SSL_OP_NO_TLSv1;
3355 #endif
3356 #ifdef SSL_OP_NO_TLSv1_1
3357 else if (option_name == ATOM_tlsv1_1)
3358 options |= SSL_OP_NO_TLSv1_1;
3359 #endif
3360 #ifdef SSL_OP_NO_TLSv1_2
3361 else if (option_name == ATOM_tlsv1_2)
3362 options |= SSL_OP_NO_TLSv1_2;
3363 #endif
3364 }
3365 if ( !PL_get_nil_ex(opt_tail) )
3366 return FALSE;
3367
3368 if ( (isset=(SSL_CTX_set_options(conf->ctx, options)&options)) != options )
3369 ssl_deb(1, "SSL_CTX_set_options 0x%lx only set 0x%lx\n", options, isset);
3370 } else if ( name == ATOM_min_protocol_version )
3371 { term_t val = PL_new_term_ref();
3372 int version;
3373
3374 _PL_get_arg(1, head, val);
3375
3376 if ( !protocol_version_to_integer(val, &version) )
3377 return FALSE;
3378 conf->min_protocol.is_set = TRUE;
3379 conf->min_protocol.version = version;
3380 } else if ( name == ATOM_max_protocol_version )
3381 { term_t val = PL_new_term_ref();
3382 int version;
3383
3384 _PL_get_arg(1, head, val);
3385
3386 if ( !protocol_version_to_integer(val, &version) )
3387 return FALSE;
3388 conf->max_protocol.is_set = TRUE;
3389 conf->max_protocol.version = version;
3390 } else if ( name == ATOM_sni_hook && arity == 1 &&
3391 conf->role == PL_SSL_SERVER )
3392 { term_t cb = PL_new_term_ref();
3393 _PL_get_arg(1, head, cb);
3394
3395 if (conf->cb_sni.goal)
3396 PL_erase(conf->cb_sni.goal);
3397
3398 conf->cb_sni.goal = PL_record(cb);
3399 conf->cb_sni.module = module;
3400 } else if ( name == ATOM_close_notify )
3401 { int val;
3402
3403 if ( !get_bool_arg(1, head, &val) )
3404 return FALSE;
3405
3406 conf->close_notify = val;
3407 } else if ( name == ATOM_alpn_protocols )
3408 { term_t protos_tail = PL_new_term_ref();
3409 term_t protos_head = PL_new_term_ref();
3410 _PL_get_arg(1, head, protos_tail);
3411 size_t current_size = 0;
3412 unsigned char *protos_vec = NULL;
3413 size_t total_length = 0;
3414
3415 while( PL_get_list_ex(protos_tail, protos_head, protos_tail) )
3416 { char *proto;
3417 size_t proto_len;
3418
3419 if ( !PL_get_nchars(protos_head, &proto_len, &proto,
3420 CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_UTF8|BUF_RING) )
3421 return FALSE;
3422 total_length += proto_len + 1;
3423 if ( total_length > current_size ) {
3424 unsigned char* new_protos_vec = realloc(protos_vec, total_length);
3425 if ( new_protos_vec == NULL ) {
3426 if ( protos_vec != NULL ) free(protos_vec);
3427 return PL_resource_error("memory");
3428 } else {
3429 protos_vec = new_protos_vec;
3430 }
3431 }
3432 protos_vec[current_size] = proto_len;
3433 memcpy(protos_vec + current_size + 1, proto, proto_len);
3434 current_size = total_length;
3435 }
3436 conf->alpn_protos = protos_vec;
3437 conf->alpn_protos_len = current_size;
3438 } else if ( name == ATOM_alpn_protocol_hook &&
3439 conf->role == PL_SSL_SERVER )
3440 { term_t cb = PL_new_term_ref();
3441 _PL_get_arg(1, head, cb);
3442 if ( conf->cb_alpn_proto.goal ) PL_erase(conf->cb_alpn_proto.goal);
3443 conf->cb_alpn_proto.goal = PL_record(cb);
3444 conf->cb_alpn_proto.module = module;
3445 } else
3446 continue;
3447 }
3448
3449 return PL_get_nil_ex(tail);
3450 }
3451
3452
3453 static foreign_t
pl_ssl_set_options(term_t config,term_t options)3454 pl_ssl_set_options(term_t config, term_t options)
3455 { PL_SSL *conf;
3456 module_t module = NULL;
3457
3458 if ( !get_conf(config, &conf) )
3459 return FALSE;
3460
3461 if ( !PL_strip_module(options, &module, options) )
3462 return FALSE;
3463
3464 return
3465 parse_malleable_options(conf, module, options) &&
3466 set_malleable_options(conf);
3467 }
3468
3469
3470 static foreign_t
pl_ssl_property(term_t config,term_t prop)3471 pl_ssl_property(term_t config, term_t prop)
3472 { PL_SSL *conf;
3473 atom_t name;
3474 size_t arity;
3475
3476 if ( !get_conf(config, &conf) )
3477 return FALSE;
3478
3479 if ( PL_get_name_arity(prop, &name, &arity) && arity == 1 )
3480 { term_t arg = PL_new_term_ref();
3481
3482 _PL_get_arg(1, prop, arg);
3483 if ( name == ATOM_close_parent )
3484 return PL_unify_bool(arg, conf->close_parent);
3485
3486 return FALSE;
3487 }
3488
3489 return PL_type_error("ssl_property", prop);
3490 }
3491
3492
3493 static const SSL_METHOD *
get_ssl_method(term_t method)3494 get_ssl_method(term_t method)
3495 { const SSL_METHOD *ssl_method = NULL;
3496 #if OPENSSL_VERSION_NUMBER < 0x10100000L
3497 atom_t method_name;
3498 #endif
3499
3500 #if OPENSSL_VERSION_NUMBER < 0x10100000L
3501 if ( !method )
3502 { method_name = ATOM_sslv23;
3503 } else if ( !PL_get_atom(method, &method_name) )
3504 { PL_domain_error("ssl_method", method);
3505 return NULL;
3506 }
3507
3508 if ( method_name == ATOM_sslv23 )
3509 ssl_method = SSLv23_method();
3510 #ifndef OPENSSL_NO_SSL2
3511 else if ( method_name == ATOM_sslv2 )
3512 ssl_method = SSLv2_method();
3513 #endif
3514 #ifndef OPENSSL_NO_SSL3_METHOD
3515 else if ( method_name == ATOM_sslv3 )
3516 ssl_method = SSLv3_method();
3517 #endif
3518 #ifdef SSL_OP_NO_TLSv1
3519 else if ( method_name == ATOM_tlsv1 )
3520 ssl_method = TLSv1_method();
3521 #endif
3522 #ifdef SSL_OP_NO_TLSv1_1
3523 else if ( method_name == ATOM_tlsv1_1 )
3524 ssl_method = TLSv1_1_method();
3525 #endif
3526 #ifdef SSL_OP_NO_TLSv1_2
3527 else if ( method_name == ATOM_tlsv1_2 )
3528 ssl_method = TLSv1_2_method();
3529 #endif
3530 else
3531 { PL_domain_error("ssl_method", method);
3532 return NULL;
3533 }
3534 #else
3535 ssl_method = TLS_method(); /* In OpenSSL >= 1.1.0, always use TLS_method() */
3536 #endif
3537
3538 return ssl_method;
3539 }
3540
3541
3542 static cacert_stack *root_cacert_stack = NULL;
3543
3544 static int
add_system_root_certificates(cacert_stack * stack)3545 add_system_root_certificates(cacert_stack *stack)
3546 { STACK_OF(X509) *system_certs = system_root_certificates();
3547
3548 if ( system_certs )
3549 { int index = 0;
3550
3551 while( index < sk_X509_num(system_certs) )
3552 { sk_X509_push(stack->cacerts,
3553 X509_dup(sk_X509_value(system_certs, index++)));
3554 }
3555 }
3556
3557 return TRUE;
3558 }
3559
3560
3561 static int
get_cacerts_roots_only(term_t term,cacert_stack ** stackp)3562 get_cacerts_roots_only(term_t term, cacert_stack **stackp)
3563 { term_t tail = PL_copy_term_ref(term);
3564 term_t head = PL_new_term_ref();
3565
3566 if ( PL_get_list(tail, head, tail) && PL_get_nil(tail) &&
3567 PL_is_functor(head, FUNCTOR_system1) )
3568 { atom_t a;
3569
3570 _PL_get_arg(1, head, head);
3571 if ( PL_get_atom(head, &a) && a == ATOM_root_certificates )
3572 { if ( root_cacert_stack )
3573 { *stackp = dup_cacert_stack(root_cacert_stack);
3574 return TRUE;
3575 } else
3576 { cacert_stack *stack;
3577
3578 if ( !(stack=new_cacert_stack()) ||
3579 !add_system_root_certificates(stack) )
3580 return FALSE;
3581 if ( COMPARE_AND_SWAP_PTR(&root_cacert_stack, NULL, stack) )
3582 { (void)dup_cacert_stack(root_cacert_stack);
3583 } else
3584 { free_cacert_stack(stack);
3585 }
3586
3587 *stackp = dup_cacert_stack(root_cacert_stack);
3588 return TRUE;
3589 }
3590 }
3591 }
3592
3593 return FALSE;
3594 }
3595
3596
3597 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3598 Create a cacert_stack from a Prolog list of certificate sources. The
3599 certificates are all duplicated using X509_dup() such that they can be
3600 freed uniformely when the stack is freed.
3601 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3602
3603 static int
get_cacerts(term_t CATail,cacert_stack ** stackp)3604 get_cacerts(term_t CATail, cacert_stack **stackp)
3605 { term_t CAHead;
3606 cacert_stack *stack;
3607
3608 if ( get_cacerts_roots_only(CATail, stackp) )
3609 return TRUE;
3610
3611 if ( !(CAHead = PL_new_term_ref()) )
3612 return FALSE;
3613
3614 if ( !(stack=new_cacert_stack()) )
3615 { PL_resource_error("memory");
3616 return FALSE;
3617 }
3618
3619 while( PL_get_list_ex(CATail, CAHead, CATail) )
3620 { X509* cert = NULL;
3621
3622 if ( PL_is_functor(CAHead, FUNCTOR_certificate1) )
3623 { _PL_get_arg(1, CAHead, CAHead);
3624
3625 if ( !get_certificate_blob(CAHead, &cert) )
3626 { error:
3627 free_cacert_stack(stack);
3628 return FALSE;
3629 }
3630 sk_X509_push(stack->cacerts, X509_dup(cert));
3631 } else if ( PL_is_functor(CAHead, FUNCTOR_file1) )
3632 { char *file;
3633
3634 _PL_get_arg(1, CAHead, CAHead);
3635
3636 if ( !PL_get_file_name(CAHead, &file, PL_FILE_EXIST) ||
3637 !load_certificates_from_file(file, stack->cacerts))
3638 goto error;
3639 } else if ( PL_is_functor(CAHead, FUNCTOR_system1) )
3640 { atom_t a;
3641
3642 _PL_get_arg(1, CAHead, CAHead);
3643
3644 if ( !PL_get_atom_ex(CAHead, &a) )
3645 goto error;
3646
3647 if ( a == ATOM_root_certificates )
3648 { if ( !add_system_root_certificates(stack) )
3649 goto error;
3650 }
3651 }
3652 }
3653
3654 if ( !PL_get_nil_ex(CATail) )
3655 goto error;
3656
3657 *stackp = stack;
3658 return TRUE;
3659 }
3660
3661
3662
3663 static foreign_t
pl_ssl_context(term_t role,term_t config,term_t options,term_t method)3664 pl_ssl_context(term_t role, term_t config, term_t options, term_t method)
3665 { atom_t a;
3666 PL_SSL *conf;
3667 int r;
3668 term_t tail;
3669 term_t head = PL_new_term_ref();
3670 module_t module = NULL;
3671 const SSL_METHOD *ssl_method;
3672
3673 if ( !PL_strip_module(options, &module, options) )
3674 return FALSE;
3675 tail = PL_copy_term_ref(options);
3676
3677 if ( !PL_get_atom_ex(role, &a) )
3678 return FALSE;
3679 if ( a == ATOM_server )
3680 r = PL_SSL_SERVER;
3681 else if ( a == ATOM_client )
3682 r = PL_SSL_CLIENT;
3683 else
3684 return PL_domain_error("ssl_role", role);
3685
3686 if ( !(ssl_method = get_ssl_method(method)) )
3687 return FALSE;
3688
3689 if ( !(conf = ssl_init(r, ssl_method)) )
3690 return PL_resource_error("memory");
3691
3692 while( PL_get_list(tail, head, tail) )
3693 { atom_t name;
3694 size_t arity;
3695
3696 if ( !(PL_get_name_arity(head, &name, &arity) && arity == 1) )
3697 return PL_type_error("ssl_option", head);
3698
3699 if ( name == ATOM_password )
3700 { char *s;
3701
3702 if ( !get_char_arg(1, head, &s) )
3703 return FALSE;
3704
3705 set_string(conf, password, s);
3706 } else if ( name == ATOM_require_crl )
3707 { int val;
3708
3709 if ( !get_bool_arg(1, head, &val) )
3710 return FALSE;
3711
3712 conf->crl_required = val;
3713 } else if ( name == ATOM_crl )
3714 { STACK_OF(X509_CRL) *crls = sk_X509_CRL_new_null();
3715 term_t list_head = PL_new_term_ref();
3716 term_t list_tail = PL_new_term_ref();
3717
3718 _PL_get_arg(1, head, list_tail);
3719 while( PL_get_list(list_tail, list_head, list_tail) )
3720 { atom_t crl_name;
3721 X509_CRL *crl;
3722 if (PL_is_atom(list_head) && PL_get_atom(list_head, &crl_name))
3723 { FILE *file = fopen(PL_atom_chars(crl_name), "rb");
3724 if ( file )
3725 { crl = PEM_read_X509_CRL(file, NULL, NULL, NULL);
3726 sk_X509_CRL_push(crls, crl);
3727 } else
3728 return PL_existence_error("file", list_head);
3729 }
3730 }
3731 if (conf->crl_list)
3732 sk_X509_CRL_pop_free(conf->crl_list, X509_CRL_free);
3733 conf->crl_list = crls;
3734 } else if ( name == ATOM_certificate_file )
3735 { char *file;
3736
3737 if ( !get_file_arg(1, head, &file) )
3738 return FALSE;
3739
3740 set_string(conf, certificate_file, file);
3741 } else if ( name == ATOM_cacerts )
3742 { term_t arg = PL_new_term_ref();
3743 cacert_stack *stack;
3744
3745 _PL_get_arg(1, head, arg);
3746 if ( get_cacerts(arg, &stack) )
3747 { free_cacert_stack(conf->cacerts);
3748 conf->cacerts = stack;
3749 } else
3750 return FALSE;
3751 } else if ( name == ATOM_certificate_file )
3752 { char *file;
3753
3754 if ( !get_file_arg(1, head, &file) )
3755 return FALSE;
3756
3757 set_string(conf, certificate_file, file);
3758 } else if ( name == ATOM_certificate_key_pairs )
3759 { term_t cert_head = PL_new_term_ref();
3760 term_t cert_tail = PL_new_term_ref();
3761 _PL_get_arg(1, head, cert_tail);
3762 while( PL_get_list(cert_tail, cert_head, cert_tail) )
3763 { atom_t name;
3764 char *certificate, *key;
3765 int idx = conf->num_cert_key_pairs;
3766
3767 if ( idx >= SSL_MAX_CERT_KEY_PAIRS )
3768 return PL_domain_error("fewer_certificates", options);
3769
3770 ssl_deb(4, "loading certificate/key pair with index %d\n", idx);
3771
3772 if ( !PL_get_name_arity(cert_head, &name, &arity) ||
3773 name != ATOM_minus ||
3774 arity != 2 )
3775 return PL_type_error("pair", cert_head);
3776
3777 if ( !get_char_arg(1, cert_head, &certificate) )
3778 return FALSE;
3779 if ( !get_char_arg(2, cert_head, &key) )
3780 return FALSE;
3781
3782 conf->cert_key_pairs[idx].certificate = ssl_strdup(certificate);
3783 conf->cert_key_pairs[idx].key = ssl_strdup(key);
3784 conf->num_cert_key_pairs++;
3785 }
3786 if ( !PL_get_nil_ex(cert_tail) )
3787 return FALSE;
3788 } else if ( name == ATOM_key_file )
3789 { char *file;
3790
3791 if ( !get_file_arg(1, head, &file) )
3792 return FALSE;
3793
3794 set_string(conf, key_file, file);
3795 } else if ( name == ATOM_pem_password_hook )
3796 { term_t cb = PL_new_term_ref();
3797 _PL_get_arg(1, head, cb);
3798 conf->cb_pem_passwd.goal = PL_record(cb);
3799 conf->cb_pem_passwd.module = module;
3800 } else
3801 continue;
3802 }
3803
3804 if ( !parse_malleable_options(conf, module, options) )
3805 return FALSE;
3806
3807 return unify_conf(config, conf) && ssl_config(conf);
3808 }
3809
3810
3811 static int
pl_ssl_close(void * handle)3812 pl_ssl_close(void *handle)
3813 { PL_SSL_INSTANCE *instance = handle;
3814
3815 assert(instance->close_needed > 0);
3816
3817 if ( --instance->close_needed == 0 )
3818 return ssl_close(instance);
3819
3820 return 0;
3821 }
3822
3823
3824 static int
pl_ssl_control(void * handle,int action,void * data)3825 pl_ssl_control(void *handle, int action, void *data)
3826 { PL_SSL_INSTANCE *instance = handle;
3827
3828 switch(action)
3829 {
3830 #ifdef __WINDOWS__
3831 case SIO_GETFILENO:
3832 return -1;
3833 case SIO_GETWINSOCK:
3834 { if (instance->sread != NULL)
3835 { (*instance->sread->functions->control)(instance->sread->handle,
3836 SIO_GETWINSOCK,
3837 data);
3838 return 0;
3839 } else if (instance->swrite != NULL)
3840 { (*instance->swrite->functions->control)(instance->swrite->handle,
3841 SIO_GETWINSOCK,
3842 data);
3843 return 0;
3844 }
3845 }
3846 return -1;
3847 #else
3848 case SIO_GETFILENO:
3849 { if (instance->sread != NULL)
3850 { int fd = Sfileno(instance->sread);
3851 int *fdp = data;
3852 *fdp = fd;
3853 return 0;
3854 } else if (instance->swrite != NULL)
3855 { int fd = Sfileno(instance->swrite);
3856 int *fdp = data;
3857 *fdp = fd;
3858 return 0;
3859 }
3860 }
3861 return -1;
3862 #endif
3863 case SIO_SETENCODING:
3864 case SIO_FLUSHOUTPUT:
3865 return 0;
3866 default:
3867 return -1;
3868 }
3869 }
3870
3871
3872 static IOFUNCTIONS ssl_funcs =
3873 { ssl_read, /* read */
3874 ssl_write, /* write */
3875 NULL, /* seek */
3876 pl_ssl_close, /* close */
3877 pl_ssl_control /* control */
3878 };
3879
3880
3881 /**
3882 * FIXME: if anything goes wrong, the instance is not reclaimed.
3883 * Can we simple call free() on it?
3884 */
3885 static foreign_t
pl_ssl_negotiate(term_t config,term_t org_in,term_t org_out,term_t in,term_t out)3886 pl_ssl_negotiate(term_t config,
3887 term_t org_in, term_t org_out, /* wire streams */
3888 term_t in, term_t out) /* data streams */
3889 { PL_SSL *conf;
3890 IOSTREAM *sorg_in = NULL, *sorg_out = NULL;
3891 IOSTREAM *i, *o;
3892 PL_SSL_INSTANCE * instance = NULL;
3893 int rc = FALSE;
3894
3895 if ( !get_conf(config, &conf) )
3896 return FALSE;
3897 if ( !PL_get_stream_handle(org_in, &sorg_in) ||
3898 !PL_get_stream_handle(org_out, &sorg_out) )
3899 goto out;
3900
3901 if ( !(rc = ssl_ssl_bio(conf, sorg_in, sorg_out, &instance)) )
3902 { rc = raise_ssl_error(ERR_get_error());
3903 goto out;
3904 }
3905
3906 if ( !(i=Snew(instance, SIO_INPUT|SIO_RECORDPOS|SIO_FBUF, &ssl_funcs)) )
3907 { rc = PL_resource_error("memory");
3908 goto out;
3909 }
3910 instance->close_needed++;
3911 if ( !PL_unify_stream(in, i) )
3912 { Sclose(i);
3913 goto out;
3914 }
3915 Sset_filter(sorg_in, i);
3916 instance->dread = i;
3917
3918 if ( !(o=Snew(instance, SIO_OUTPUT|SIO_RECORDPOS|SIO_FBUF, &ssl_funcs)) )
3919 { rc = PL_resource_error("memory");
3920 goto out;
3921 }
3922 instance->close_needed++;
3923 if ( !PL_unify_stream(out, o) )
3924 { Sclose(i);
3925 Sclose(o);
3926 goto out;
3927 }
3928 Sset_filter(sorg_out, o);
3929 instance->dwrite = o;
3930
3931 /* Increase atom reference count so that the context is not
3932 GCd until this session is complete */
3933 ssl_deb(4, "Increasing count on %d\n", conf->atom);
3934 PL_register_atom(conf->atom);
3935
3936 out:
3937 if ( sorg_in )
3938 { if ( !rc )
3939 Sset_filter(sorg_in, NULL);
3940 PL_release_stream(sorg_in);
3941 }
3942 if ( sorg_out )
3943 { if ( !rc )
3944 Sset_filter(sorg_out, NULL);
3945 PL_release_stream(sorg_out);
3946 }
3947
3948 return rc;
3949 }
3950
3951 static void
ssl_copy_callback(const PL_SSL_CALLBACK old,PL_SSL_CALLBACK * new)3952 ssl_copy_callback(const PL_SSL_CALLBACK old, PL_SSL_CALLBACK *new)
3953 {
3954 if (old.goal)
3955 { new->goal = PL_duplicate_record(old.goal);
3956 new->module = old.module;
3957 }
3958 }
3959
3960 static foreign_t
pl_ssl_copy_context(term_t term_old,term_t term_new)3961 pl_ssl_copy_context(term_t term_old, term_t term_new)
3962 { PL_SSL *old, *new;
3963 int idx;
3964 const SSL_METHOD *ssl_method;
3965
3966 if ( !PL_is_variable(term_new) )
3967 return PL_uninstantiation_error(term_new);
3968
3969 if ( !get_conf(term_old, &old) )
3970 return FALSE;
3971
3972 if ( !(ssl_method = get_ssl_method(0)) )
3973 return FALSE;
3974 if ( !(new = ssl_init(old->role, ssl_method)) )
3975 return PL_resource_error("memory");
3976 if ( !unify_conf(term_new, new) )
3977 return FALSE; /* TBD: cleanup */
3978
3979 new->role = old->role;
3980 new->close_parent = old->close_parent;
3981 new->close_notify = old->close_notify;
3982 new->min_protocol = old->min_protocol;
3983 new->max_protocol = old->max_protocol;
3984 new->peer_cert_required = old->peer_cert_required;
3985
3986 set_string(new, password, old->password);
3987 set_string(new, host, old->host);
3988 set_string(new, certificate_file, old->certificate_file);
3989 set_string(new, key_file, old->key_file);
3990 set_string(new, cipher_list, old->cipher_list);
3991 set_string(new, ecdh_curve, old->ecdh_curve);
3992
3993 new->cacerts = dup_cacert_stack(old->cacerts);
3994
3995 #ifndef HAVE_X509_CHECK_HOST
3996 new->hostname_check_status = old->hostname_check_status;
3997 #endif
3998
3999 if ( old->crl_list )
4000 new->crl_list = sk_X509_CRL_dup(old->crl_list);
4001 new->crl_required = old->crl_required;
4002
4003 ssl_copy_callback(old->cb_cert_verify, &new->cb_cert_verify);
4004 ssl_copy_callback(old->cb_pem_passwd, &new->cb_pem_passwd);
4005 ssl_copy_callback(old->cb_sni, &new->cb_sni);
4006 ssl_copy_callback(old->cb_alpn_proto, &new->cb_alpn_proto);
4007
4008 for(idx = 0; idx < old->num_cert_key_pairs; idx++)
4009 { new->cert_key_pairs[idx].certificate = ssl_strdup(old->cert_key_pairs[idx].certificate);
4010 new->cert_key_pairs[idx].key = ssl_strdup(old->cert_key_pairs[idx].key);
4011 new->num_cert_key_pairs++;
4012 }
4013
4014 if ( old->alpn_protos )
4015 { unsigned char *protos_copy = malloc(old->alpn_protos_len *
4016 sizeof(unsigned char));
4017 if ( protos_copy == NULL )
4018 return PL_resource_error("memory");
4019 memcpy(old->alpn_protos, protos_copy, old->alpn_protos_len);
4020 new->alpn_protos = protos_copy;
4021 }
4022
4023 return ssl_config(new);
4024 }
4025
4026
4027 static foreign_t
pl_ssl_add_certificate_key(term_t config,term_t cert_arg,term_t key_arg)4028 pl_ssl_add_certificate_key(term_t config, term_t cert_arg, term_t key_arg)
4029 { PL_SSL *conf;
4030 char *cert, *key;
4031 int idx;
4032 X509 *certX509;
4033
4034 if ( !get_conf(config, &conf) )
4035 return FALSE;
4036
4037 idx = conf->num_cert_key_pairs;
4038 if ( idx < SSL_MAX_CERT_KEY_PAIRS &&
4039 PL_get_chars(cert_arg, &cert, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) &&
4040 PL_get_chars(key_arg, &key, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) &&
4041 ssl_use_certificate(conf, cert, &certX509) &&
4042 ssl_use_key(conf, key) )
4043 { conf->cert_key_pairs[idx].certificate = ssl_strdup(cert);
4044 conf->cert_key_pairs[idx].key = ssl_strdup(key);
4045 conf->cert_key_pairs[idx].certificate_X509 = certX509;
4046
4047 conf->num_cert_key_pairs++;
4048 return TRUE;
4049 }
4050
4051 return FALSE;
4052 }
4053
4054
4055 static foreign_t
pl_ssl_debug(term_t level)4056 pl_ssl_debug(term_t level)
4057 { int l;
4058
4059 if ( !PL_get_integer_ex(level, &l) )
4060 return FALSE;
4061
4062 ssl_set_debug(l);
4063
4064 return TRUE;
4065 }
4066
4067
4068 static int
add_key_string(term_t list,functor_t f,size_t len,const unsigned char * s)4069 add_key_string(term_t list, functor_t f, size_t len, const unsigned char*s)
4070 { term_t tmp;
4071 int rc;
4072
4073 rc = ( (tmp = PL_new_term_refs(2)) &&
4074 PL_unify_list_ex(list, tmp+0, list) &&
4075 PL_put_string_nchars(tmp+1, len, (const char*)s) &&
4076 PL_unify_term(tmp+0, PL_FUNCTOR, f, PL_TERM, tmp+1)
4077 );
4078 if ( tmp )
4079 PL_reset_term_refs(tmp);
4080 return rc;
4081 }
4082
4083
4084 static foreign_t
pl_system_root_certificates(term_t list)4085 pl_system_root_certificates(term_t list)
4086 { STACK_OF(X509) *certs;
4087 term_t head = PL_new_term_ref();
4088 term_t tail = PL_copy_term_ref(list);
4089 int index = 0;
4090
4091 if ( !(certs=system_root_certificates()) )
4092 return PL_unify_nil(list);
4093
4094 while (index < sk_X509_num(certs))
4095 { if ( !(PL_unify_list(tail, head, tail) &&
4096 unify_certificate_blob_copy(head, sk_X509_value(certs, index++))) )
4097 { return FALSE;
4098 }
4099 }
4100
4101 return PL_unify_nil(tail);
4102 }
4103
4104
4105 static foreign_t
pl_verify_certificate(term_t Cert,term_t Chain,term_t Roots)4106 pl_verify_certificate(term_t Cert, term_t Chain, term_t Roots)
4107 { X509* cert = NULL;
4108 X509_STORE_CTX* ctx = NULL;
4109 X509_STORE* store = NULL;
4110 STACK_OF(X509) *chain = NULL;
4111 STACK_OF(X509) *roots = NULL;
4112 int rc = 1;
4113 int index = 0;
4114
4115 if ( !get_certificate_blob(Cert, &cert))
4116 return FALSE;
4117
4118 if ( PL_is_functor(Roots, FUNCTOR_system1) )
4119 { _PL_get_arg(1, Roots, Roots);
4120 atom_t a;
4121
4122 if ( !PL_get_atom_ex(Roots, &a) )
4123 return FALSE;
4124 if ( a == ATOM_root_certificates )
4125 roots = system_root_certificates();
4126 else
4127 return PL_domain_error("certificate_list", Roots);
4128 } else if ( !get_certificate_blobs(Roots, &roots))
4129 return FALSE;
4130
4131 if ( !get_certificate_blobs(Chain, &chain))
4132 rc = FALSE;
4133
4134 rc &= ((ctx = X509_STORE_CTX_new()) != NULL);
4135 rc &= ((store = X509_STORE_new()) != NULL);
4136
4137 /* Add roots to store */
4138 if (rc)
4139 { for ( index = 0; index < sk_X509_num(roots); index++ )
4140 X509_STORE_add_cert(store, sk_X509_value(roots, index));
4141 Sdprintf("Added %d certificates to the store\n", index);
4142
4143 rc &= X509_STORE_CTX_init(ctx, store, cert, chain);
4144 rc &= X509_verify_cert(ctx);
4145 if (rc <= 0)
4146 { char msg[1024];
4147 ERR_error_string(X509_STORE_CTX_get_error(ctx), &msg[0]);
4148 Sdprintf("Failed to verify certificate: %s (%d)\n", msg, rc);
4149 }
4150 }
4151 if (store != NULL)
4152 X509_STORE_free(store);
4153 if (ctx != NULL)
4154 X509_STORE_CTX_free(ctx);
4155 if (chain != NULL)
4156 sk_X509_free(chain);
4157
4158 if (roots != NULL && roots != system_root_store)
4159 sk_X509_free(roots);
4160 return rc;
4161 }
4162
4163 static int
get_ssl_stream(term_t stream_t,IOSTREAM ** locked,IOSTREAM ** ssl)4164 get_ssl_stream(term_t stream_t, IOSTREAM **locked, IOSTREAM **ssl)
4165 { IOSTREAM *stream, *ssl_stream;
4166
4167 if ( !PL_get_stream(stream_t, &stream, SIO_INPUT) )
4168 return FALSE;
4169
4170 for( ssl_stream = stream;
4171 ssl_stream && ssl_stream->functions != &ssl_funcs;
4172 ssl_stream = ssl_stream->downstream )
4173 ;
4174
4175 if ( ssl_stream )
4176 { *locked = stream;
4177 *ssl = ssl_stream;
4178
4179 return TRUE;
4180 }
4181
4182 PL_release_stream(stream);
4183 PL_domain_error("ssl_stream", stream_t);
4184
4185 return FALSE;
4186 }
4187
4188
4189 static foreign_t
pl_ssl_peer_certificate(term_t stream_t,term_t Cert)4190 pl_ssl_peer_certificate(term_t stream_t, term_t Cert)
4191 { IOSTREAM *stream, *ssl_stream;
4192 PL_SSL_INSTANCE *instance;
4193 X509 *cert;
4194 int rc = FALSE;
4195
4196 if ( !get_ssl_stream(stream_t, &stream, &ssl_stream) )
4197 return FALSE;
4198
4199 instance = ssl_stream->handle;
4200 if ( (cert = ssl_peer_certificate(instance)) )
4201 rc = unify_certificate_blob_copy(Cert, cert);
4202 PL_release_stream(stream);
4203
4204 return rc;
4205 }
4206
4207 static foreign_t
pl_ssl_peer_certificate_chain(term_t stream_t,term_t chain)4208 pl_ssl_peer_certificate_chain(term_t stream_t, term_t chain)
4209 { IOSTREAM *stream, *ssl_stream;
4210 PL_SSL_INSTANCE *instance;
4211 int rc;
4212
4213 if ( !get_ssl_stream(stream_t, &stream, &ssl_stream) )
4214 return FALSE;
4215
4216 instance = ssl_stream->handle;
4217 rc = unify_certificate_copies_inorder(chain,
4218 SSL_get_peer_cert_chain(instance->ssl));
4219 PL_release_stream(stream);
4220
4221 return rc;
4222 }
4223
4224
4225 static foreign_t
pl_ssl_session(term_t stream_t,term_t session_t)4226 pl_ssl_session(term_t stream_t, term_t session_t)
4227 { IOSTREAM *stream, *ssl_stream;
4228 PL_SSL_INSTANCE* instance;
4229 SSL* ssl;
4230 SSL_SESSION* session;
4231 term_t list_t = PL_copy_term_ref(session_t);
4232 term_t node_t = PL_new_term_ref();
4233 int version;
4234 unsigned char *master_key;
4235 int master_key_length;
4236 const char *cipher;
4237
4238 if ( !get_ssl_stream(stream_t, &stream, &ssl_stream) )
4239 return FALSE;
4240
4241 instance = ssl_stream->handle;
4242 PL_release_stream(stream);
4243
4244 if ( !(ssl = instance->ssl) ||
4245 !(session = SSL_get1_session(ssl)) )
4246 return PL_existence_error("ssl_session", stream_t);
4247
4248 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
4249 version = session->ssl_version;
4250 master_key = session->master_key;
4251 master_key_length = session->master_key_length;
4252 /* session_key is SSL2 specific, i.e., obsolete */
4253 #ifndef OPENSSL_NO_SSL2
4254 if ( !add_key_string(list_t, FUNCTOR_session_key1,
4255 session->key_arg_length, session->key_arg) )
4256 goto err;
4257 #endif
4258 #else
4259 version = SSL_SESSION_get_protocol_version(session);
4260 if ( (master_key = PL_malloc(SSL_MAX_MASTER_KEY_LENGTH)) == NULL )
4261 { SSL_SESSION_free(session);
4262 return PL_resource_error("memory");
4263 }
4264 master_key_length = SSL_SESSION_get_master_key(session, master_key, SSL_MAX_MASTER_KEY_LENGTH);
4265 #endif
4266
4267 if ( !PL_unify_list_ex(list_t, node_t, list_t) )
4268 goto err;
4269 if ( !PL_unify_term(node_t,
4270 PL_FUNCTOR, FUNCTOR_version1,
4271 PL_INT, version))
4272 goto err;
4273
4274 cipher = SSL_get_cipher_name(ssl);
4275
4276 if ( !add_key_string(list_t, FUNCTOR_cipher1,
4277 strlen(cipher), (unsigned char*)cipher) )
4278 goto err;
4279
4280 if ( !add_key_string(list_t, FUNCTOR_master_key1,
4281 master_key_length, master_key) )
4282 goto err;
4283
4284 #if OPENSSL_VERSION_NUMBER < 0x10100000L || defined(LIBRESSL_VERSION_NUMBER)
4285 if ( !add_key_string(list_t, FUNCTOR_session_id1,
4286 session->session_id_length, session->session_id) )
4287 goto err;
4288
4289 if ( ssl->s3 != NULL ) /* If the connection is SSLv2?! */
4290 { if ( !add_key_string(list_t, FUNCTOR_client_random1,
4291 SSL3_RANDOM_SIZE, ssl->s3->client_random) )
4292 goto err;
4293
4294 if ( !add_key_string(list_t, FUNCTOR_server_random1,
4295 SSL3_RANDOM_SIZE, ssl->s3->server_random) )
4296 goto err;
4297 }
4298 #else
4299 /* Note: session_id has no correspondence in OpenSSL >= 1.1.0 */
4300
4301 { unsigned char random[SSL3_RANDOM_SIZE];
4302
4303 SSL_get_client_random(ssl, random, SSL3_RANDOM_SIZE);
4304 if ( !add_key_string(list_t, FUNCTOR_client_random1,
4305 SSL3_RANDOM_SIZE, random) )
4306 goto err;
4307
4308 SSL_get_server_random(ssl, random, SSL3_RANDOM_SIZE);
4309 if ( !add_key_string(list_t, FUNCTOR_server_random1,
4310 SSL3_RANDOM_SIZE, random) )
4311 goto err;
4312 }
4313
4314 PL_free(master_key);
4315 #endif
4316
4317 #ifdef HAVE_SSL_CTX_SET_ALPN_PROTOS
4318 { const unsigned char *data;
4319 unsigned int len;
4320 SSL_get0_alpn_selected(ssl, &data, &len);
4321 if ( !add_key_string(list_t, FUNCTOR_alpn_protocol1,
4322 len, data)) {
4323 goto err;
4324 }
4325 }
4326 #endif
4327
4328 SSL_SESSION_free(session);
4329 return PL_unify_nil_ex(list_t);
4330
4331 err:
4332 SSL_SESSION_free(session);
4333 return FALSE;
4334 }
4335
4336
4337 /*******************************
4338 * INSTALL *
4339 *******************************/
4340
4341 #define MKATOM(n) ATOM_ ## n = PL_new_atom(#n);
4342
4343 install_t
install_ssl4pl(void)4344 install_ssl4pl(void)
4345 { MKATOM(server);
4346 MKATOM(client);
4347 MKATOM(password);
4348 MKATOM(host);
4349 MKATOM(peer_cert);
4350 MKATOM(cacerts);
4351 MKATOM(certificate_file);
4352 MKATOM(certificate_key_pairs);
4353 MKATOM(key_file);
4354 MKATOM(pem_password_hook);
4355 MKATOM(cert_verify_hook);
4356 MKATOM(close_parent);
4357 MKATOM(close_notify);
4358 MKATOM(disable_ssl_methods);
4359 MKATOM(min_protocol_version);
4360 MKATOM(max_protocol_version);
4361 MKATOM(cipher_list);
4362 MKATOM(ecdh_curve);
4363 MKATOM(root_certificates);
4364 MKATOM(sni_hook);
4365 MKATOM(sslv2);
4366 MKATOM(sslv23);
4367 MKATOM(sslv3);
4368 MKATOM(tlsv1);
4369 MKATOM(tlsv1_1);
4370 MKATOM(tlsv1_2);
4371 MKATOM(tlsv1_3);
4372 MKATOM(require_crl);
4373 MKATOM(crl);
4374 MKATOM(alpn_protocols);
4375 MKATOM(alpn_protocol_hook);
4376
4377 ATOM_minus = PL_new_atom("-");
4378
4379 FUNCTOR_error2 = PL_new_functor(PL_new_atom("error"), 2);
4380 FUNCTOR_ssl_error4 = PL_new_functor(PL_new_atom("ssl_error"), 4);
4381 FUNCTOR_permission_error3 = PL_new_functor(PL_new_atom("permission_error"), 3);
4382 FUNCTOR_version1 = PL_new_functor(PL_new_atom("version"), 1);
4383 FUNCTOR_notbefore1 = PL_new_functor(PL_new_atom("notbefore"), 1);
4384 FUNCTOR_notafter1 = PL_new_functor(PL_new_atom("notafter"), 1);
4385 FUNCTOR_subject1 = PL_new_functor(PL_new_atom("subject"), 1);
4386 FUNCTOR_issuername1 = PL_new_functor(PL_new_atom("issuer_name"), 1);
4387 FUNCTOR_serial1 = PL_new_functor(PL_new_atom("serial"), 1);
4388 FUNCTOR_key1 = PL_new_functor(PL_new_atom("key"), 1);
4389 FUNCTOR_public_key1 = PL_new_functor(PL_new_atom("public_key"), 1);
4390 FUNCTOR_private_key1 = PL_new_functor(PL_new_atom("private_key"), 1);
4391 FUNCTOR_rsa8 = PL_new_functor(PL_new_atom("rsa"), 8);
4392 FUNCTOR_ec3 = PL_new_functor(PL_new_atom("ec"), 3);
4393 FUNCTOR_hash1 = PL_new_functor(PL_new_atom("hash"), 1);
4394 FUNCTOR_next_update1 = PL_new_functor(PL_new_atom("next_update"), 1);
4395 FUNCTOR_signature1 = PL_new_functor(PL_new_atom("signature"), 1);
4396 FUNCTOR_signature_algorithm1 = PL_new_functor(PL_new_atom("signature_algorithm"), 1);
4397 FUNCTOR_to_be_signed1 = PL_new_functor(PL_new_atom("to_be_signed"), 1);
4398 FUNCTOR_equals2 = PL_new_functor(PL_new_atom("="), 2);
4399 FUNCTOR_crl1 = PL_new_functor(PL_new_atom("crl"), 1);
4400 FUNCTOR_revoked2 = PL_new_functor(PL_new_atom("revoked"), 2);
4401 FUNCTOR_revocations1 = PL_new_functor(PL_new_atom("revocations"), 1);
4402 #ifndef OPENSSL_NO_SSL2
4403 FUNCTOR_session_key1 = PL_new_functor(PL_new_atom("session_key"), 1);
4404 #endif
4405 FUNCTOR_cipher1 = PL_new_functor(PL_new_atom("cipher"), 1);
4406 FUNCTOR_master_key1 = PL_new_functor(PL_new_atom("master_key"), 1);
4407 FUNCTOR_session_id1 = PL_new_functor(PL_new_atom("session_id"), 1);
4408 FUNCTOR_client_random1 = PL_new_functor(PL_new_atom("client_random"), 1);
4409 FUNCTOR_server_random1 = PL_new_functor(PL_new_atom("server_random"), 1);
4410 FUNCTOR_alpn_protocol1 = PL_new_functor(PL_new_atom("alpn_protocol"), 1);
4411 FUNCTOR_system1 = PL_new_functor(PL_new_atom("system"), 1);
4412 FUNCTOR_unknown1 = PL_new_functor(PL_new_atom("unknown"), 1);
4413 FUNCTOR_unsupported_hash_algorithm1 = PL_new_functor(PL_new_atom("unsupported_hash_algorithm"), 1);
4414 FUNCTOR_certificate1 = PL_new_functor(PL_new_atom("certificate"), 1);
4415 FUNCTOR_file1 = PL_new_functor(PL_new_atom("file"), 1);
4416 PL_register_foreign("_ssl_context", 4, pl_ssl_context, 0);
4417 PL_register_foreign("ssl_copy_context", 2, pl_ssl_copy_context, 0);
4418 PL_register_foreign("ssl_negotiate", 5, pl_ssl_negotiate, 0);
4419 PL_register_foreign("_ssl_add_certificate_key",
4420 3, pl_ssl_add_certificate_key, 0);
4421 PL_register_foreign("_ssl_set_options", 2, pl_ssl_set_options, 0);
4422 PL_register_foreign("ssl_property", 2, pl_ssl_property, 0);
4423 PL_register_foreign("ssl_debug", 1, pl_ssl_debug, 0);
4424 PL_register_foreign("ssl_session", 2, pl_ssl_session, 0);
4425 PL_register_foreign("ssl_peer_certificate",
4426 2, pl_ssl_peer_certificate, 0);
4427 PL_register_foreign("ssl_peer_certificate_chain",
4428 2, pl_ssl_peer_certificate_chain, 0);
4429 PL_register_foreign("load_crl", 2, pl_load_crl, 0);
4430 PL_register_foreign("load_certificate",2,pl_load_certificate, 0);
4431 PL_register_foreign("write_certificate",3,pl_write_certificate, 0);
4432 PL_register_foreign("verify_certificate",3,pl_verify_certificate, 0);
4433 PL_register_foreign("load_private_key",3,pl_load_private_key, 0);
4434 PL_register_foreign("load_public_key", 2,pl_load_public_key, 0);
4435 PL_register_foreign("system_root_certificates", 1, pl_system_root_certificates, 0);
4436
4437 PL_register_foreign("certificate_field", 2, pl_certificate_field, PL_FA_NONDETERMINISTIC);
4438 PL_register_foreign("verify_certificate_issuer", 2, pl_verify_certificate_issuer, 0);
4439 PL_register_foreign("same_certificate", 2, pl_same_certificate, 0);
4440
4441 /* Note that libcrypto threading needs to be initialized exactly once.
4442 This is achieved by loading library(crypto) from library(ssl) and
4443 do the initialization from the library(crypto) foreign installation.
4444 */
4445 ssl_lib_init();
4446
4447 PL_set_prolog_flag("ssl_library_version", PL_ATOM,
4448 #ifdef HAVE_OPENSSL_VERSION
4449 OpenSSL_version(OPENSSL_VERSION)
4450 #else
4451 SSLeay_version(SSLEAY_VERSION)
4452 #endif
4453 );
4454
4455 PL_set_prolog_flag("system_cacert_filename", PL_ATOM,
4456 SYSTEM_CACERT_FILENAME);
4457 }
4458
4459 install_t
uninstall_ssl4pl(void)4460 uninstall_ssl4pl(void)
4461 { ssl_lib_exit();
4462 }
4463