racket · LiberalArtist · Jan 5, 2019 · Jan 11, 2019
diff --git a/pkgs/racket-test/tests/openssl/test-cipher-server-preference.rkt b/pkgs/racket-test/tests/openssl/test-cipher-server-preference.rkt
@@ -0,0 +1,110 @@
+#lang racket
+
+(require openssl
+         ;"../../../../racket/collects/openssl/mzssl.rkt"
+         rackunit)
+
+;; not sure this is ideal for pem, but copied from "test-protocols.rkt"
+(define pem (build-path (collection-path "openssl") "test.pem")) 
+(define MSG:C->S "Hello. This is Racket speaking.")
+(define MSG:S->C "Yes, this is Racket too. Hello, Racket.")
+
+(define (negotiate-ciphers #:server server-cipher-spec
+                           #:client client-cipher-spec
+                           #:use-server-pref? use-server-pref?)
+  (define cust (make-custodian))
+  (dynamic-wind
+   void
+   (λ () 
+     (parameterize ([current-custodian cust])
+       (define-values (r1 w2) (make-pipe 10))
+       (define-values (r2 w1) (make-pipe 10))
+       (define server-thread
+         (thread
+          (λ ()
+            (define server-ctx (ssl-make-server-context 'tls))
+            (ssl-load-certificate-chain! server-ctx pem)
+            (ssl-load-private-key! server-ctx pem)
+            (ssl-set-ciphers! server-ctx server-cipher-spec)
+            (when use-server-pref?
+              (ssl-server-context-use-server-cipher-preference! server-ctx))
+            (define-values (r w)
+              (ports->ssl-ports r2 w2
+                                #:context server-ctx
+                                #:mode 'accept 
+                                #:close-original? #t
+                                #:shutdown-on-close? #t))
+            (check-equal? (read-line r) MSG:C->S "message from client")
+            (fprintf w "~a\n" MSG:S->C)
+            (close-output-port w))))
+       (define client-ctx (ssl-make-client-context 'tls))
+       (ssl-set-ciphers! client-ctx client-cipher-spec)
+       (define-values (r w)
+         (ports->ssl-ports r1 w1
+                           #:context client-ctx
+                           #:mode 'connect 
+                           #:close-original? #t
+                           #:shutdown-on-close? #t))
+       (fprintf w "~a\n" MSG:C->S)
+       (flush-output w)
+       (define chosen-name (ssl-get-cipher-name r))
+       (define chosen-version (ssl-get-cipher-version w))
+       (check-equal? (read-line r) MSG:S->C "reply from server")
+       (check-equal? (read-byte r) eof "server should have closed port")
+       (list chosen-name chosen-version)))
+   (λ () (custodian-shutdown-all cust))))
+
+
+
+(define c1
+  ;; aka TLS_RSA_WITH_AES_128_CBC_SHA
+  "AES128-SHA")
+(define c2
+  ;; aka TLS_RSA_WITH_AES_256_CBC_SHA
+  "AES256-SHA")
+(define c3
+  ;; aka TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA
+  "ECDHE-RSA-AES128-SHA")
+(define c4
+  ;; aka TLS_ECDHE_RSA_WITH_AES_256_CBC_SHA
+  "ECDHE-RSA-AES256-SHA")
+
+(define c2-c4 (string-append c2 ":" c4))
+(define c4-c2 (string-append c4 ":" c2))
+
+(negotiate-ciphers #:server c2-c4
+                   #:client c4-c2
+                   #:use-server-pref? #t)
+
+(negotiate-ciphers #:server c4-c2
+                   #:client c2-c4
+                   #:use-server-pref? #t)
+
+(negotiate-ciphers #:server c2-c4
+                   #:client c4-c2
+                   #:use-server-pref? #f)
+
+(negotiate-ciphers #:server c4-c2
+                   #:client c2-c4
+                   #:use-server-pref? #f)
+
+
+(define c1-c2 (string-append c1 ":" c2))
+(define c2-c1 (string-append c2 ":" c1))
+
+(negotiate-ciphers #:server c1-c2
+                   #:client c2-c1
+                   #:use-server-pref? #t)
+
+(negotiate-ciphers #:server c2-c1
+                   #:client c1-c2
+                   #:use-server-pref? #t)
+
+(negotiate-ciphers #:server c1-c2
+                   #:client c2-c1
+                   #:use-server-pref? #f)
+
+(negotiate-ciphers #:server c2-c1
+                   #:client c1-c2
+                   #:use-server-pref? #f)
+
diff --git a/racket/collects/openssl/libssl.rkt b/racket/collects/openssl/libssl.rkt
@@ -11,7 +11,7 @@
 
 (define libssl-load-fail-reason #f)
 
-;; We need to declare because they might be distributed with PLT Scheme
+;; We need to declare because they might be distributed with Racket
 ;; in which case they should get bundled with stand-alone executables:
 (define-runtime-path libssl-so
   #:runtime?-id runtime?

diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt
@@ -94,6 +94,8 @@ TO DO:
    (c-> ssl-client-context?)]
   [ssl-make-server-context
    (->* () (protocol-symbol/c) ssl-server-context?)]
+  [ssl-server-context-use-server-cipher-preference!
+   (c-> ssl-server-context? void?)]
   [ssl-server-context-enable-dhe!
    (->* (ssl-server-context?) (path-string?) void?)]
   [ssl-server-context-enable-ecdhe!
@@ -152,6 +154,10 @@ TO DO:
    (c-> ssl-port? (or/c bytes? #f))]
   [ssl-peer-issuer-name
    (c-> ssl-port? (or/c bytes? #f))]
+  [ssl-get-cipher-name
+    (c-> ssl-port? string?)]
+  [ssl-get-cipher-version
+    (c-> ssl-port? string?)]
   [ports->ssl-ports
    (->* [input-port?
          output-port?]
@@ -223,6 +229,7 @@ TO DO:
 (define-cpointer-type _SSL_METHOD*)
 (define-cpointer-type _SSL_CTX*)
 (define-cpointer-type _SSL*)
+(define-cpointer-type _SSL_CIPHER*)
 (define-cpointer-type _X509_NAME*)
 (define-cpointer-type _X509_NAME_ENTRY*)
 (define-cpointer-type _X509*)
@@ -310,6 +317,10 @@ TO DO:
 (define-ssl SSL_do_handshake (_fun _SSL* -> _int))
 (define-ssl SSL_ctrl (_fun _SSL* _int _long _pointer -> _long))
 (define-ssl SSL_set_SSL_CTX (_fun _SSL* _SSL_CTX* -> _SSL_CTX*))
+(define-ssl SSL_get_current_cipher (_fun _SSL* -> _SSL_CIPHER*))
+
+(define-ssl SSL_CIPHER_get_name (_fun _SSL_CIPHER* -> _string))
+(define-ssl SSL_CIPHER_get_version (_fun _SSL_CIPHER* -> _string))
 
 (define-crypto X509_free (_fun _X509* -> _void)
   #:wrap (deallocator))
@@ -461,6 +472,8 @@ TO DO:
 (define SSL_OP_SINGLE_ECDH_USE #x00080000)
 (define SSL_OP_SINGLE_DH_USE #x00100000)
 
+(define SSL_OP_CIPHER_SERVER_PREFERENCE #x00400000)
+
 (define TLSEXT_NAMETYPE_host_name 0)
 
 (define SSL_TLSEXT_ERR_OK 0)
@@ -709,6 +722,12 @@ TO DO:
 (define (ssl-seal-context! mzctx)
   (set-ssl-context-sealed?! mzctx #t))
 
+(define (ssl-server-context-use-server-cipher-preference! context)
+  (define ctx
+    (extract-ctx 'ssl-server-context-use-server-cipher-preference! #t context))
+  (SSL_CTX_set_options ctx SSL_OP_CIPHER_SERVER_PREFERENCE)
+  (void))
+
 (define (ssl-server-context-enable-ecdhe! context [name 'secp521r1])
   (define (symbol->nid name)
     (cond [(assq name curve-nid-alist)
@@ -1535,6 +1554,21 @@ TO DO:
      [else
       (close-input-port p)])))
 
+;; ssl-get-cipher-name : ssl-port -> string
+(define (ssl-get-cipher-name p)
+  (SSL_CIPHER_get_name
+   (ssl-port->cipher 'ssl-get-cipher-name p)))
+
+;; ssl-get-cipher-version : ssl-port -> string
+(define (ssl-get-cipher-version p)
+  (SSL_CIPHER_get_version
+   (ssl-port->cipher 'ssl-get-cipher-version p)))
+
+;; ssl-port->cipher : symbol ssl-port -> _SSL_CIPHER*
+(define (ssl-port->cipher who p)
+  (let-values ([(mzssl _input?) (lookup who p)])
+    (SSL_get_current_cipher (mzssl-ssl mzssl))))
+
 (define (ssl-peer-verified? p)
   (let-values ([(mzssl input?) (lookup 'ssl-peer-verified? p)])
     (and (eq? X509_V_OK (SSL_get_verify_result (mzssl-ssl mzssl)))