Coverage report: /home/ellis/.stash/lisp/cl-plus-ssl/src/verify-hostname.lisp

KindCoveredAll%
expression30183 16.4
branch124 4.2
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2
 ;;;
3
 ;;; Copyright (C) contributors as per cl+ssl git history
4
 ;;;
5
 ;;; See LICENSE for details.
6
 
7
 (in-package :cl+ssl)
8
 
9
 (define-condition hostname-verification-error (error)
10
   ())
11
 
12
 (define-condition unable-to-match-altnames (hostname-verification-error)
13
   ())
14
 
15
 (define-condition unable-to-decode-common-name (hostname-verification-error)
16
   ())
17
 
18
 (define-condition unable-to-match-common-name (hostname-verification-error)
19
   ())
20
 
21
 (defun case-insensitive-match (name hostname)
22
   (string-equal name hostname))
23
 
24
 (defun remove-trailing-dot (string)
25
   (string-right-trim '(#\.) string))
26
 
27
 (defun check-wildcard-in-leftmost-label (identifier wildcard-pos)
28
   (alexandria:when-let ((dot-pos (position #\. identifier)))
29
     (> dot-pos wildcard-pos)))
30
 
31
 (defun check-single-wildcard (identifier wildcard-pos)
32
   (not (find #\* identifier :start (1+ wildcard-pos))))
33
 
34
 (defun check-two-labels-after-wildcard (after-wildcard)
35
   ;;at least two dots(in fact labels since we remove trailing dot first) after wildcard
36
   (alexandria:when-let ((first-dot-aw-pos (position #\. after-wildcard)))
37
     (and (find #\. after-wildcard :start (1+ first-dot-aw-pos))
38
          first-dot-aw-pos)))
39
 
40
 (defun validate-and-parse-wildcard-identifier (identifier hostname)
41
   (alexandria:when-let ((wildcard-pos (position #\* identifier)))
42
     (when (and (>= (length hostname) (length identifier)) ;; wildcard should constiute at least one character
43
                (check-wildcard-in-leftmost-label identifier wildcard-pos)
44
                (check-single-wildcard identifier wildcard-pos))
45
       (let ((after-wildcard (subseq identifier (1+ wildcard-pos)))
46
             (before-wildcard (subseq identifier 0 wildcard-pos)))
47
         (alexandria:when-let ((first-dot-aw-pos (check-two-labels-after-wildcard after-wildcard)))
48
           (if (and (= 0 (length before-wildcard))     ;; nothing before wildcard
49
                    (= wildcard-pos first-dot-aw-pos)) ;; i.e. dot follows *
50
               (values t before-wildcard after-wildcard t)
51
               (values t before-wildcard after-wildcard nil)))))))
52
 
53
 (defun wildcard-not-in-a-label (before-wildcard after-wildcard)
54
   (let ((after-w-dot-pos (position #\. after-wildcard)))
55
     (and
56
      (not (search "xn--" before-wildcard))
57
      (not (search "xn--" (subseq after-wildcard 0 after-w-dot-pos))))))
58
 
59
 (defun try-match-wildcard (before-wildcard after-wildcard single-char-wildcard pattern)
60
   ;; Compare AfterW part with end of pattern with length (length AfterW)
61
   ;; was Wildcard the only character in left-most label in identifier
62
   ;; doesn't matter since parts after Wildcard should match unconditionally.
63
   ;; However if Wildcard was the only character in left-most label we can't match this *.example.com and bar.foo.example.com
64
   ;; if i'm correct if it wasn't the only character
65
   ;; we can match like this: *o.example.com = bar.foo.example.com
66
   ;; but this is prohibited anyway thanks to check-vildcard-in-leftmost-label
67
   (if single-char-wildcard
68
       (let ((pattern-except-left-most-label
69
              (alexandria:if-let ((first-hostname-dot-post (position #\. pattern)))
70
                (subseq pattern first-hostname-dot-post)
71
                pattern)))
72
         (case-insensitive-match after-wildcard pattern-except-left-most-label))
73
       (when (wildcard-not-in-a-label before-wildcard after-wildcard)
74
         ;; baz*.example.net and *baz.example.net and b*z.example.net would
75
         ;; be taken to match baz1.example.net and foobaz.example.net and
76
         ;; buzz.example.net, respectively
77
         (and
78
          (case-insensitive-match before-wildcard (subseq pattern 0 (length before-wildcard)))
79
          (case-insensitive-match after-wildcard (subseq pattern
80
                                                         (- (length pattern)
81
                                                            (length after-wildcard))))))))
82
 
83
 (defun maybe-try-match-wildcard (name hostname)
84
   (multiple-value-bind (valid before-wildcard after-wildcard single-char-wildcard)
85
       (validate-and-parse-wildcard-identifier name hostname)
86
     (when valid
87
       (try-match-wildcard before-wildcard after-wildcard single-char-wildcard hostname))))
88
 
89
 (defun try-match-hostname (name hostname)
90
   (let ((name (remove-trailing-dot name))
91
         (hostname (remove-trailing-dot hostname)))
92
     (or (case-insensitive-match name hostname)
93
         (maybe-try-match-wildcard name hostname))))
94
 
95
 (defun try-match-hostnames (names hostname)
96
   (loop for name in names
97
         when (try-match-hostname name hostname) do
98
            (return t)))
99
 
100
 (defun verify-hostname (cert hostname)
101
   "Verifies the HOSTNAME against the specified
102
 CERT. Implemented for all OpenSSL versions,
103
 using custom Lisp code (without relying on the functions
104
 provided by newer OpenSSl versions, like SSL_set_verify).
105
 
106
 Signals an error in case of verification failure.
107
 
108
 Otherwise returns true"
109
   (or (try-match-hostnames (certificate-dns-alt-names cert)
110
                            hostname)
111
       (try-match-hostnames (or (certificate-subject-common-names cert)
112
                                (error 'unable-to-decode-common-name))
113
                            hostname)
114
       (error 'unable-to-match-common-name)))