From f446adad3f09972b5a7ee1242b2135e0bf5f8aac Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 20 Nov 2012 12:23:43 -0500
Subject: [PATCH] added ssl-set-ciphers!

---
 collects/openssl/mzssl.rkt     | 19 +++++++++++++++++--
 collects/openssl/openssl.scrbl | 11 +++++++++++
 2 files changed, 28 insertions(+), 2 deletions(-)

diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt
index 77f5893286..03647419d5 100644
--- a/collects/openssl/mzssl.rkt
+++ b/collects/openssl/mzssl.rkt
@@ -38,6 +38,7 @@
 	   ssl-load-private-key!
 	   ssl-load-verify-root-certificates!
 	   ssl-load-suggested-certificate-authorities!
+           ssl-set-ciphers!
            ssl-seal-context!
 
            ssl-default-root-certificate-locations
@@ -136,6 +137,7 @@
   (define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int))
   (define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int))
   (define-ssl SSL_load_client_CA_file (_fun _bytes -> _X509_NAME*))
+  (define-ssl SSL_CTX_set_cipher_list (_fun _SSL_CTX* _string -> _int))
 
   (define-ssl SSL_new (_fun _SSL_CTX* -> _SSL*))
   (define-ssl SSL_set_bio (_fun _SSL* _BIO* _BIO* -> _void))
@@ -536,6 +538,19 @@
         (if asn1? SSL_FILETYPE_ASN1 SSL_FILETYPE_PEM)))
      ssl-context-or-listener pathname))
 
+  (define (ssl-set-ciphers! context cipher-spec)
+    (unless (ssl-context? context)
+      (raise-argument-error 'ssl-set-ciphers!
+                            "(or/c ssl-client-context? ssl-server-context?)"
+                            context))
+    (unless (string? cipher-spec)
+      (raise-argument-error 'ssl-set-ciphers! "string?" cipher-spec))
+    (let* ([ctx (extract-ctx 'ssl-set-ciphers! #t context)]
+           [result (SSL_CTX_set_cipher_list ctx cipher-spec)])
+      (unless (= result 1)
+        (error 'ssl-set-ciphers! "setting cipher list failed"))
+      (void)))
+
   (define (ssl-set-verify-hostname! ssl-context on?)
     (unless (ssl-context? ssl-context)
       (raise-argument-error 'ssl-set-verify-hostname!
@@ -618,8 +633,8 @@
       (set-ssl_struct-state! (cast (mzssl-ssl mzssl) _pointer _ssl_struct-pointer)
                              SSL_ST_ACCEPT)
       (check-err (lambda () (SSL_do_handshake (mzssl-ssl mzssl))))))
-  
-  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; SSL ports
 
   (define (mzssl-release mzssl)
diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl
index c813a61cba..70756ded5c 100644
--- a/collects/openssl/openssl.scrbl
+++ b/collects/openssl/openssl.scrbl
@@ -421,6 +421,17 @@ You can use the file @filepath{test.pem} of the @filepath{openssl}
 collection for testing purposes where the peer identifies itself using
 @filepath{test.pem}.}
 
+@defproc[(ssl-set-ciphers! [context (or/c ssl-client-context? ssl-server-context?)]
+                           [cipher-spec string?])
+         void?]{
+
+Specifies the cipher suites that can be used in connections created
+with @racket[context]. The meaning of @racket[cipher-spec] is the same
+as for the
+@hyperlink["http://www.openssl.org/docs/apps/ciphers.html"]{@tt{openssl
+ciphers} command}.
+}
+
 @defproc[(ssl-seal-context! [context (or/c ssl-client-context? ssl-server-context?)])
          void?]{