3rdparties/software/cl+ssl-20200427-git/ssl-verify-test.lisp (6350 bytes)
1 ;;; Copyright (C) 2011 David Lichteblau 2 ;;; 3 ;;; See LICENSE for details. 4 5 #+xcvb (module (:depends-on ("package"))) 6 7 (in-package :cl+ssl) 8 9 ;; from cl+ssl/example.lisp 10 (defun read-line-crlf-2 (stream &optional eof-error-p) 11 (let ((s (make-string-output-stream))) 12 (loop 13 for empty = t then nil 14 for c = (read-char stream eof-error-p nil) 15 while (and c (not (eql c #\return))) 16 do 17 (unless (eql c #\newline) 18 (write-char c s)) 19 finally 20 (return 21 (if empty nil (get-output-stream-string s)))))) 22 23 (defun write-ssl-certificate-names (ssl-stream &optional (output-stream t)) 24 (let* ((ssl (ssl-stream-handle ssl-stream)) 25 (cert (ssl-get-peer-certificate ssl))) 26 (unless (cffi:null-pointer-p cert) 27 (unwind-protect 28 (multiple-value-bind (issuer subject) 29 (x509-certificate-names cert) 30 (format output-stream 31 " issuer: ~a~% subject: ~a~%" issuer subject)) 32 (x509-free cert))))) 33 34 ;; from cl+ssl/example.lisp 35 (defun test-https-client-2 (host &key (port 443) show-text-p) 36 (let* ((deadline (+ (get-internal-real-time) 37 (* 3 internal-time-units-per-second))) 38 (socket (ccl:make-socket :address-family :internet 39 :connect :active 40 :type :stream 41 :remote-host host 42 :remote-port port 43 ;; :local-host (resolve-hostname local-host) 44 ;; :local-port local-port 45 :deadline deadline)) 46 https) 47 (unwind-protect 48 (handler-bind 49 ((ssl-error-verify 50 (lambda (c) 51 (write-ssl-certificate-names (ssl-error-stream c))))) 52 (setf https 53 (cl+ssl:make-ssl-client-stream 54 socket 55 :unwrap-stream-p t 56 :external-format '(:iso-8859-1 :eol-style :lf))) 57 (write-ssl-certificate-names https) 58 (format https "GET / HTTP/1.0~%Host: ~a~%~%" host) 59 (force-output https) 60 (loop :for line = (read-line-crlf-2 https nil) 61 for cnt from 0 62 :while line :do 63 (when show-text-p 64 (format t "HTTPS> ~a~%" line)) 65 finally (return cnt))) 66 (if https 67 (close https) 68 (close socket))))) 69 70 (defparameter *rayservers-ca-certificate-pem-file* 71 "rayservers-ca-certificate.pem") 72 73 (defparameter *rayservers-ca-certificate-path* 74 (merge-pathnames *rayservers-ca-certificate-pem-file* 75 (asdf:system-source-directory :cl+ssl))) 76 77 (defparameter *rayservers-ca-certificate-pem* 78 "-----BEGIN CERTIFICATE----- 79 MIIElTCCA32gAwIBAgIJALoXNnj+yvJCMA0GCSqGSIb3DQEBBQUAMIGNMQswCQYD 80 VQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNVBAcTC1BhbmFtYSBDaXR5MRgwFgYD 81 VQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNVBAMTEWNhLnJheXNlcnZlcnMuY29t 82 MSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJheXNlcnZlcnMuY29tMB4XDTA5MTAx 83 OTE3MzgyMFoXDTE5MTAxNzE3MzgyMFowgY0xCzAJBgNVBAYTAlBBMQswCQYDVQQI 84 EwJOQTEUMBIGA1UEBxMLUGFuYW1hIENpdHkxGDAWBgNVBAoTD1JheXNlcnZlcnMg 85 R21iSDEaMBgGA1UEAxMRY2EucmF5c2VydmVycy5jb20xJTAjBgkqhkiG9w0BCQEW 86 FnN1cHBvcnRAcmF5c2VydmVycy5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAw 87 ggEKAoIBAQC9rNsCCM+TNp6xDk2yxhXQOStmPTd0txFyduNAj02/nLZV4eq0ZS5n 88 xXBE6l3MYIMBMV3BgKiy7LsdiRJeZ5HdsV/HRZzXCQI+k4acBjlRC1ZdWMNsIR+H 89 QUVx2y0wgp+QpcMrgBQZdPI7PobnXCZ6+Fmc50kM7xbIsoWZUzQDpRtUymgOhnnT 90 4TSb1/XufFHHhDMReRA7s3Co911hzcnZJqL9gFWULlB/RI2ZeVbkp0K4lUXyMZ/R 91 fnOtCdAA+TkQcpzoyBETV9p5MO8KBOPBskvyGYqVcIZNuxwfC2uoKx0s5b6eMRKR 92 54B4mB/hIi7i0uGjzuAZdt5iDXQHYaM3AgMBAAGjgfUwgfIwHQYDVR0OBBYEFOyu 93 Fp80LSc1gwnq5rghs/P8bMgrMIHCBgNVHSMEgbowgbeAFOyuFp80LSc1gwnq5rgh 94 s/P8bMgroYGTpIGQMIGNMQswCQYDVQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNV 95 BAcTC1BhbmFtYSBDaXR5MRgwFgYDVQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNV 96 BAMTEWNhLnJheXNlcnZlcnMuY29tMSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJh 97 eXNlcnZlcnMuY29tggkAuhc2eP7K8kIwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0B 98 AQUFAAOCAQEAqScS+A2Hajjb+jTKQ19LVPzTpRYo1Jz0SPtzGO91n0efYeRJD5hV 99 tU+57zGSlUDszARvB+sxzLdJTItK+wEpDM8pLtwUT/VPrRKOoOUBkKBshcTD4HmI 100 k8uJlNed0QQLP41hFjr+mYd7WM+N5LtFMQAUBMUN6dzEqQIx69EnIoVp0KB8kDwW 101 /QK5ogKY0g8DmRTFiV036bHQH93kLzyV6FNAldO8vBDqcTeru/uU2Kcn6a8YOfO1 102 T6MVYory7prWbBaGPKsGw0VgrV9OGbxhbw9EOEYSOgdejvbi9VhgMvEpDYFN7Hnq 103 0wiHJq5jKECf3bwRe9uVzVMrIeCap/r2uA== 104 -----END CERTIFICATE-----") 105 106 (defun write-rayservers-certificate-pem () 107 (with-open-file (s *rayservers-ca-certificate-path* 108 :direction :output 109 :if-exists :supersede 110 :if-does-not-exist :create) 111 (write-string *rayservers-ca-certificate-pem* s) 112 *rayservers-ca-certificate-path*)) 113 114 (defun install-rayservers-ca-certificate () 115 (let ((path (write-rayservers-certificate-pem))) 116 (ssl-load-global-verify-locations path))) 117 118 (defun test-loom-client (&optional show-text-p) 119 (test-https-client-2 "secure.loom.cc" :show-text-p show-text-p)) 120 121 (defun test-yahoo-client (&optional show-text-p) 122 (test-https-client-2 "yahoo.com" :show-text-p show-text-p)) 123 124 (defmacro expecting-no-errors (&body body) 125 `(handler-case 126 (progn ,@body) 127 (error (c) 128 (error "Got an unexpected error: ~a" c)))) 129 130 (defmacro expecting-error ((type) &body body) 131 `(let ((got-error-p nil)) 132 (handler-case 133 (progn ,@body) 134 (error (c) 135 (unless (typep c ',type) 136 (error "Got an unexpected error type: ~a" c)) 137 (setf got-error-p t))) 138 (unless got-error-p 139 (error "Did not get expected error.")))) 140 141 (defun test-verify (&optional quietly) 142 (let ((*standard-output* 143 ;; test-https-client-2 prints the certificate names 144 (if quietly (make-broadcast-stream) *standard-output*))) 145 (expecting-no-errors 146 (reload) 147 (test-loom-client) 148 (test-yahoo-client) 149 (setf (ssl-check-verify-p) t)) 150 ;; The Mac appears to have no way to get rid of the default CA certificates 151 ;; #+darwin-host is only true in Clozure Common Lisp running on a Mac, 152 ;; So this test will fail in SBCL on a Mac 153 #-darwin-host 154 (expecting-error (ssl-error-verify) 155 (test-yahoo-client)) 156 #+darwin-host 157 (expecting-no-errors 158 (test-yahoo-client)) 159 (expecting-error (ssl-error-verify) 160 (test-loom-client)) 161 (expecting-no-errors 162 (install-rayservers-ca-certificate) 163 (test-loom-client)) 164 (expecting-no-errors 165 (ssl-set-global-default-verify-paths) 166 (test-yahoo-client))))