3rdparties/software/cl+ssl-20200427-git/src/verify-hostname.lisp (5125 bytes)
1 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*- 2 3 (in-package :cl+ssl) 4 5 (define-condition hostname-verification-error (error) 6 ()) 7 8 (define-condition unable-to-match-altnames (hostname-verification-error) 9 ()) 10 11 (define-condition unable-to-decode-common-name (hostname-verification-error) 12 ()) 13 14 (define-condition unable-to-match-common-name (hostname-verification-error) 15 ()) 16 17 (defun case-insensitive-match (name hostname) 18 (string-equal name hostname)) 19 20 (defun remove-trailing-dot (string) 21 (string-right-trim '(#\.) string)) 22 23 (defun check-wildcard-in-leftmost-label (identifier wildcard-pos) 24 (alexandria:when-let ((dot-pos (position #\. identifier))) 25 (> dot-pos wildcard-pos))) 26 27 (defun check-single-wildcard (identifier wildcard-pos) 28 (not (find #\* identifier :start (1+ wildcard-pos)))) 29 30 (defun check-two-labels-after-wildcard (after-wildcard) 31 ;;at least two dots(in fact labels since we remove trailing dot first) after wildcard 32 (alexandria:when-let ((first-dot-aw-pos (position #\. after-wildcard))) 33 (and (find #\. after-wildcard :start (1+ first-dot-aw-pos)) 34 first-dot-aw-pos))) 35 36 (defun validate-and-parse-wildcard-identifier (identifier hostname) 37 (alexandria:when-let ((wildcard-pos (position #\* identifier))) 38 (when (and (>= (length hostname) (length identifier)) ;; wildcard should constiute at least one character 39 (check-wildcard-in-leftmost-label identifier wildcard-pos) 40 (check-single-wildcard identifier wildcard-pos)) 41 (let ((after-wildcard (subseq identifier (1+ wildcard-pos))) 42 (before-wildcard (subseq identifier 0 wildcard-pos))) 43 (alexandria:when-let ((first-dot-aw-pos (check-two-labels-after-wildcard after-wildcard))) 44 (if (and (= 0 (length before-wildcard)) ;; nothing before wildcard 45 (= wildcard-pos first-dot-aw-pos)) ;; i.e. dot follows * 46 (values t before-wildcard after-wildcard t) 47 (values t before-wildcard after-wildcard nil))))))) 48 49 (defun wildcard-not-in-a-label (before-wildcard after-wildcard) 50 (let ((after-w-dot-pos (position #\. after-wildcard))) 51 (and 52 (not (search "xn--" before-wildcard)) 53 (not (search "xn--" (subseq after-wildcard 0 after-w-dot-pos)))))) 54 55 (defun try-match-wildcard (before-wildcard after-wildcard single-char-wildcard pattern) 56 ;; Compare AfterW part with end of pattern with length (length AfterW) 57 ;; was Wildcard the only character in left-most label in identifier 58 ;; doesn't matter since parts after Wildcard should match unconditionally. 59 ;; However if Wildcard was the only character in left-most label we can't match this *.example.com and bar.foo.example.com 60 ;; if i'm correct if it wasn't the only character 61 ;; we can match like this: *o.example.com = bar.foo.example.com 62 ;; but this is prohibited anyway thanks to check-vildcard-in-leftmost-label 63 (if single-char-wildcard 64 (let ((pattern-except-left-most-label 65 (alexandria:if-let ((first-hostname-dot-post (position #\. pattern))) 66 (subseq pattern first-hostname-dot-post) 67 pattern))) 68 (case-insensitive-match after-wildcard pattern-except-left-most-label)) 69 (when (wildcard-not-in-a-label before-wildcard after-wildcard) 70 ;; baz*.example.net and *baz.example.net and b*z.example.net would 71 ;; be taken to match baz1.example.net and foobaz.example.net and 72 ;; buzz.example.net, respectively 73 (and 74 (case-insensitive-match before-wildcard (subseq pattern 0 (length before-wildcard))) 75 (case-insensitive-match after-wildcard (subseq pattern 76 (- (length pattern) 77 (length after-wildcard)))))))) 78 79 (defun maybe-try-match-wildcard (name hostname) 80 (multiple-value-bind (valid before-wildcard after-wildcard single-char-wildcard) 81 (validate-and-parse-wildcard-identifier name hostname) 82 (when valid 83 (try-match-wildcard before-wildcard after-wildcard single-char-wildcard hostname)))) 84 85 (defun try-match-hostname (name hostname) 86 (let ((name (remove-trailing-dot name)) 87 (hostname (remove-trailing-dot hostname))) 88 (or (case-insensitive-match name hostname) 89 (maybe-try-match-wildcard name hostname)))) 90 91 (defun try-match-hostnames (names hostname) 92 (loop for name in names 93 when (try-match-hostname name hostname) do 94 (return t))) 95 96 (defun maybe-check-subject-cn (dns-names cert hostname) 97 (when dns-names 98 (error 'unable-to-match-altnames)) 99 ;; TODO: we are matching only first CN 100 (alexandria:if-let ((cn (first (certificate-subject-common-names cert)))) 101 (progn 102 (or (try-match-hostname cn hostname) 103 (error 'unable-to-match-common-name))) 104 (error 'unable-to-decode-common-name))) 105 106 (defun verify-hostname (cert hostname) 107 (let* ((dns-names (certificate-dns-alt-names cert))) 108 (or (try-match-hostnames dns-names hostname) 109 (maybe-check-subject-cn dns-names cert hostname))))