Changeset 14315 in project


Ignore:
Timestamp:
04/20/09 18:07:43 (11 years ago)
Author:
Alex Shinn
Message:

openssl for chicken 4

Location:
release/4/openssl
Files:
2 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/openssl/openssl.scm

    r8428 r14315  
    22;;;; Bindings to the OpenSSL SSL/TLS library
    33
    4 (define-extension openssl
    5   (export
     4(module openssl
     5  (
    66   ssl-connect
    77   ssl-make-client-context
     
    1919   ssl-set-verify!
    2020   ssl-load-verify-root-certificates!
    21    ssl-load-suggested-certificate-authorities!))
     21   ssl-load-suggested-certificate-authorities!)
     22
     23(import scheme chicken foreign ports)
    2224
    2325(declare
     
    3638 (fixnum-arithmetic))
    3739
    38 #+(not static)
    39 (declare
    40   (import
    41    ##sys#update-errno
    42    ##sys#signal-hook
    43    ##sys#string-append
    44    ##sys#tcp-port->fileno
    45    ##sys#current-thread
    46    ##sys#size
    47    ##sys#setslot
    48    ##sys#check-string
    49    ##sys#expand-home-path
    50    ##sys#thread-block-for-i/o!) )
    51 
    5240(use srfi-18 tcp)
    5341
     
    9280(define-foreign-variable strerror c-string "strerror(errno)")
    9381
    94 (define (##net#close-socket fd)
     82(define (net-close-socket fd)
    9583  (when ((foreign-lambda bool "closesocket" int) fd)
    9684    (##sys#update-errno)
    9785    (##sys#signal-hook
    98      network-error: '##net#close-socket
     86     network-error: 'net-close-socket
    9987     (##sys#string-append "can not close socket - " strerror)
    10088     fd)))
    10189
    102 (define (##net#unwrap-tcp-ports tcp-in tcp-out)
     90(define (net-unwrap-tcp-ports tcp-in tcp-out)
    10391  (let ((fd (##sys#tcp-port->fileno tcp-in)))
    10492    (tcp-abandon-port tcp-in)
     
    10694    fd))
    10795
    108 (define (##ssl#abort loc sym . args)
     96(define (ssl-abort loc sym . args)
    10997  (let ((err ((foreign-lambda unsigned-long "ERR_get_error"))))
    11098    (abort
     
    144132       sym)))))
    145133
    146 (define ##ssl#ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer))
    147 
    148 (define (##ssl#ctx-new protocol server)
     134(define ssl-ctx-free (foreign-lambda void "SSL_CTX_free" c-pointer))
     135
     136(define (ssl-ctx-new protocol server)
    149137  (let ((ctx
    150138         ((foreign-lambda*
     
    177165                'exn
    178166                'message "invalid SSL/TLS connection protocol"
    179                 'location '##ssl#ctx-new
     167                'location 'ssl-ctx-new
    180168                'arguments (list protocol))
    181169               (make-property-condition
    182170                'type))))))))
    183     (unless ctx (##ssl#abort '##ssl#ctx-new #f))
    184     (set-finalizer! ctx ##ssl#ctx-free)
     171    (unless ctx (ssl-abort 'ssl-ctx-new #f))
     172    (set-finalizer! ctx ssl-ctx-free)
    185173    ctx))
    186        
    187    
    188 (define (##ssl#new ctx)
     174
     175
     176(define (ssl-new ctx)
    189177  (cond
    190178   (((foreign-lambda c-pointer "SSL_new" c-pointer) ctx)
    191179    => values)
    192180   (else
    193     (##ssl#abort '##ssl#new #f))))
    194 
    195 (define ##ssl#free (foreign-lambda void "SSL_free" c-pointer))
    196 
    197 (define (##ssl#result-or-abort loc ssl ret allow-i/o? . args)
     181    (ssl-abort 'ssl-new #f))))
     182
     183(define ssl-free (foreign-lambda void "SSL_free" c-pointer))
     184
     185(define (ssl-result-or-abort loc ssl ret allow-i/o? . args)
    198186  (call-with-current-continuation
    199187   (lambda (q)
    200188     (let ((sym
    201             (switch ((foreign-lambda int "SSL_get_error" c-pointer int)
    202                      ssl ret)
    203               ((foreign-value "SSL_ERROR_NONE" int)
    204                (q ret))
    205               ((foreign-value "SSL_ERROR_ZERO_RETURN" int)
    206                'zero-return)
    207               ((foreign-value "SSL_ERROR_WANT_READ" int)
    208                (if allow-i/o?
    209                    (q 'want-read)
    210                    'want-read))
    211               ((foreign-value "SSL_ERROR_WANT_WRITE" int)
    212                (if allow-i/o?
    213                    (q 'want-write)
    214                    'want-write))
    215               ((foreign-value "SSL_ERROR_WANT_CONNECT" int)
     189            (let ((x ((foreign-lambda int "SSL_get_error" c-pointer int)
     190                      ssl ret)))
     191              (cond
     192               ((eq? x (foreign-value "SSL_ERROR_NONE" int))
     193                (q ret))
     194               ((eq? x (foreign-value "SSL_ERROR_ZERO_RETURN" int))
     195                'zero-return)
     196               ((eq? x (foreign-value "SSL_ERROR_WANT_READ" int))
     197                (if allow-i/o?
     198                    (q 'want-read)
     199                    'want-read))
     200               ((eq? x (foreign-value "SSL_ERROR_WANT_WRITE" int))
     201                (if allow-i/o?
     202                    (q 'want-write)
     203                    'want-write))
     204               ((eq? x (foreign-value "SSL_ERROR_WANT_CONNECT" int))
    216205                'want-connect)
    217               ((foreign-value "SSL_ERROR_WANT_ACCEPT" int)
    218                'want-accept)
    219               ((foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int)
    220                'want-X509-lookup)
    221               ((foreign-value "SSL_ERROR_SYSCALL" int)
    222                'syscall)
    223               ((foreign-value "SSL_ERROR_SSL" int)
    224                'ssl)
    225               (else
    226                #f))))
    227        (apply ##ssl#abort loc sym args)))))
     206               ((eq? x (foreign-value "SSL_ERROR_WANT_ACCEPT" int))
     207                'want-accept)
     208               ((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int))
     209                'want-X509-lookup)
     210               ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
     211                'syscall)
     212               ((eq? x (foreign-value "SSL_ERROR_SSL" int))
     213                'ssl)
     214               (else
     215                #f)))))
     216       (apply ssl-abort loc sym args)))))
    228217     
    229 (define (##ssl#set-fd! ssl fd)
    230   (##ssl#result-or-abort
    231    '##ssl#set-fd! ssl
     218(define (ssl-set-fd! ssl fd)
     219  (ssl-result-or-abort
     220   'ssl-set-fd! ssl
    232221   ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
    233222   fd)
    234223  (void))
    235224
    236 (define (##ssl#connect ssl)
    237   (##ssl#result-or-abort
    238    '##ssl#connect ssl
     225(define (ssl-connect ssl)
     226  (ssl-result-or-abort
     227   'ssl-connect ssl
    239228   ((foreign-lambda int "SSL_connect" c-pointer) ssl) #t))
    240229
    241 (define (##ssl#accept ssl)
    242   (##ssl#result-or-abort
    243    '##ssl#accept ssl
     230(define (ssl-accept ssl)
     231  (ssl-result-or-abort
     232   'ssl-accept ssl
    244233   ((foreign-lambda int "SSL_accept" c-pointer) ssl) #t))
    245234
    246 (define (##ssl#shutdown ssl)
     235(define (ssl-shutdown ssl)
    247236  (let ((ret
    248237         ((foreign-lambda*
     
    255244           "}\n") ssl)))
    256245    (if (fixnum? ret)
    257         (##ssl#result-or-abort '##ssl#shutdown ssl ret #t)
     246        (ssl-result-or-abort 'ssl-shutdown ssl ret #t)
    258247        ret)))
    259248
    260 (define (##ssl#get-char ssl)
     249(define (ssl-get-char ssl)
    261250  (let ((ret
    262251         ((foreign-lambda*
     
    271260          ssl)))
    272261    (if (fixnum? ret)
    273         (##ssl#result-or-abort '##ssl#get-char ssl ret #t)
     262        (ssl-result-or-abort 'ssl-get-char ssl ret #t)
    274263        ret)))
    275264
    276 (define (##ssl#write ssl buffer offset size)
    277   (##ssl#result-or-abort
    278    '##ssl#write ssl
     265(define (ssl-write ssl buffer offset size)
     266  (ssl-result-or-abort
     267   'ssl-write ssl
    279268   ((foreign-lambda*
    280269     int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
     
    283272   #t))
    284273
    285 (define (##ssl#make-i/o-ports ctx fd ssl)
     274(define (ssl-make-i/o-ports ctx fd ssl)
    286275  ;; note that the ctx parameter is never used but it is passed in order
    287276  ;; to be present in the closure data of the various port functions
     
    295284            (lambda ()
    296285              (let loop ()
    297                 (case (##ssl#shutdown ssl)
     286                (case (ssl-shutdown ssl)
    298287                  ((want-read)
    299288                   (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
     
    305294                   (loop)))))
    306295            (lambda ()
    307               (##ssl#free ssl)
    308               (##net#close-socket fd)))))
     296              (ssl-free ssl)
     297              (net-close-socket fd)))))
    309298    (let ((data (vector fd))
    310299          (in
     
    315304                (unless buffer
    316305                  (let loop ()
    317                     (let ((ret (##ssl#get-char ssl)))
     306                    (let ((ret (ssl-get-char ssl)))
    318307                      (case ret
    319308                        ((want-read)
     
    338327                (or buffer
    339328                    (let loop ()
    340                       (let ((ret (##ssl#get-char ssl)))
     329                      (let ((ret (ssl-get-char ssl)))
    341330                        (case ret
    342331                          ((want-read want-write)
     
    352341                (unless buffer
    353342                  (let loop ()
    354                     (let ((ret (##ssl#get-char ssl)))
     343                    (let ((ret (ssl-get-char ssl)))
    355344                      (case ret
    356345                        ((want-read)
     
    374363            (lambda (buffer)
    375364              (let loop ((offset 0) (size (##sys#size buffer)))
    376                 (let ((ret (##ssl#write ssl buffer offset size)))
     365                (let ((ret (ssl-write ssl buffer offset size)))
    377366                  (case ret
    378367                    ((want-read)
     
    399388      (values in out))))
    400389
    401 (define (##ssl#unwrap-context obj)
     390(define (ssl-unwrap-context obj)
    402391  (cond
    403392   ((ssl-client-context? obj)
    404     (##ssl#unwrap-client-context obj))
     393    (ssl-unwrap-client-context obj))
    405394   ((ssl-listener? obj)
    406     (##ssl#unwrap-listener-context obj))
     395    (ssl-unwrap-listener-context obj))
    407396   (else
    408397    (abort
    409398     (make-property-condition
    410399      'exn
    411       'location '##ssl#unwrap-context
     400      'location 'ssl-unwrap-context
    412401      'message "expected an ssl-client-context or ssl-listener, got"
    413402      'arguments (list obj))
     
    419408;; create SSL client context
    420409(define-record-type ssl-client-context
    421   (##ssl#wrap-client-context context)
     410  (ssl-wrap-client-context context)
    422411  ssl-client-context?
    423   (context ##ssl#unwrap-client-context))
     412  (context ssl-unwrap-client-context))
    424413
    425414(define (ssl-make-client-context #!optional (protocol 'sslv2-or-v3))
    426   (##ssl#wrap-client-context (##ssl#ctx-new protocol #f)))
     415  (ssl-wrap-client-context (ssl-ctx-new protocol #f)))
    427416
    428417;; connect to SSL server
     
    430419  (let* ((fd
    431420          (call-with-values (cut tcp-connect hostname port)
    432             ##net#unwrap-tcp-ports))
     421            net-unwrap-tcp-ports))
    433422         (ctx
    434423          (if (ssl-client-context? ctx)
    435               (##ssl#unwrap-client-context ctx)
    436               (##ssl#ctx-new ctx #f)))
     424              (ssl-unwrap-client-context ctx)
     425              (ssl-ctx-new ctx #f)))
    437426         (ssl
    438           (##ssl#new ctx)))
     427          (ssl-new ctx)))
    439428    (let ((success? #f))
    440429      (dynamic-wind
    441430          void
    442431          (lambda ()
    443             (##ssl#set-fd! ssl fd)
     432            (ssl-set-fd! ssl fd)
    444433            (let loop ()
    445               (case (##ssl#connect ssl)
     434              (case (ssl-connect ssl)
    446435                ((want-read)
    447436                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
     
    455444          (lambda ()
    456445            (unless success?
    457               (##ssl#free ssl)
    458               (##net#close-socket fd)))))
    459     (##ssl#make-i/o-ports ctx fd ssl)))
     446              (ssl-free ssl)
     447              (net-close-socket fd)))))
     448    (ssl-make-i/o-ports ctx fd ssl)))
    460449
    461450;; create listener/SSL server context
    462451(define-record-type ssl-listener
    463   (##ssl#wrap-listener context listener)
     452  (ssl-wrap-listener context listener)
    464453  ssl-listener?
    465   (context ##ssl#unwrap-listener-context)
    466   (listener ##ssl#unwrap-listener))
     454  (context ssl-unwrap-listener-context)
     455  (listener ssl-unwrap-listener))
    467456
    468457(define (ssl-listen port #!optional (backlog 4) (hostname #f) (ctx 'sslv2-or-v3))
    469   (##ssl#wrap-listener
     458  (ssl-wrap-listener
    470459   (if (ssl-client-context? ctx)
    471        (##ssl#unwrap-client-context ctx)
    472        (##ssl#ctx-new ctx #t))
     460       (ssl-unwrap-client-context ctx)
     461       (ssl-ctx-new ctx #t))
    473462   (tcp-listen port backlog hostname)))
    474463
    475464;; shutdown a SSL server
    476465(define (ssl-close listener)
    477   (tcp-close (##ssl#unwrap-listener listener)))
     466  (tcp-close (ssl-unwrap-listener listener)))
    478467
    479468;; return the port number this listener is operating on
    480469(define (ssl-listener-port listener)
    481   (tcp-listener-port (##ssl#unwrap-listener listener)))
     470  (tcp-listener-port (ssl-unwrap-listener listener)))
    482471
    483472;; get the underlying socket descriptor number for an SSL listener
    484473(define (ssl-listener-fileno listener)
    485   (tcp-listener-fileno (##ssl#unwrap-listener listener)))
     474  (tcp-listener-fileno (ssl-unwrap-listener listener)))
    486475
    487476;; check whether an incoming connection is pending
    488477(define (ssl-accept-ready? listener)
    489   (tcp-accept-ready? (##ssl#unwrap-listener listener)))
     478  (tcp-accept-ready? (ssl-unwrap-listener listener)))
    490479
    491480;; accept a connection from an SSL listener
    492481(define (ssl-accept listener)
    493482  (let* ((fd
    494           (call-with-values (cut tcp-accept (##ssl#unwrap-listener listener))
    495             ##net#unwrap-tcp-ports))
     483          (call-with-values (cut tcp-accept (ssl-unwrap-listener listener))
     484            net-unwrap-tcp-ports))
    496485         (ssl
    497           (##ssl#new (##ssl#unwrap-listener-context listener))))
     486          (ssl-new (ssl-unwrap-listener-context listener))))
    498487    (let ((success? #f))
    499488      (dynamic-wind
    500489          void
    501490          (lambda ()
    502             (##ssl#set-fd! ssl fd)
     491            (ssl-set-fd! ssl fd)
    503492            (let loop ()
    504               (case (##ssl#accept ssl)
     493              (case (ssl-accept ssl)
    505494                ((want-read)
    506495                 (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
     
    514503          (lambda ()
    515504            (unless success?
    516               (##ssl#free ssl)
    517               (##net#close-socket fd)))))
    518     (##ssl#make-i/o-ports (##ssl#unwrap-listener-context listener) fd ssl)))
     505              (ssl-free ssl)
     506              (net-close-socket fd)))))
     507    (ssl-make-i/o-ports (ssl-unwrap-listener-context listener) fd ssl)))
    519508
    520509;; load identifying certificate chain into SSL context
     
    524513           ((foreign-lambda
    525514             int "SSL_CTX_use_certificate_chain_file" c-pointer c-string)
    526             (##ssl#unwrap-context obj) (##sys#expand-home-path pathname))
     515            (ssl-unwrap-context obj) (##sys#expand-home-path pathname))
    527516           1)
    528     (##ssl#abort 'ssl-load-certificate-chain! #f pathname)))
     517    (ssl-abort 'ssl-load-certificate-chain! #f pathname)))
    529518
    530519;; load the private key for the identifying certificate chain
     
    542531             "           (SSL_CTX *)ctx, path, "
    543532             "           (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));\n")
    544             (##ssl#unwrap-context obj) (##sys#expand-home-path pathname)
     533            (ssl-unwrap-context obj) (##sys#expand-home-path pathname)
    545534            rsa? asn1?)
    546535           1)
    547     (##ssl#abort 'ssl-load-private-key! #f pathname rsa? asn1?)))
     536    (ssl-abort 'ssl-load-private-key! #f pathname rsa? asn1?)))
    548537
    549538;; switch verification of peer on or off
     
    555544    " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
    556545    " : SSL_VERIFY_NONE), NULL);\n")
    557    (##ssl#unwrap-context obj) v))
     546   (ssl-unwrap-context obj) v))
    558547
    559548;; load trusted root certificates into SSL context
     
    564553           ((foreign-lambda
    565554             int "SSL_CTX_load_verify_locations" c-pointer c-string c-string)
    566             (##ssl#unwrap-context obj)
     555            (ssl-unwrap-context obj)
    567556            (if pathname (##sys#expand-home-path pathname) #f)
    568557            (if dirname (##sys#expand-home-path dirname) #f))
    569558           1)
    570     (##ssl#abort 'ssl-load-verify-root-certificates! #f pathname dirname)))
     559    (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname)))
    571560
    572561;; load suggested root certificates into SSL context
     
    579568        (foreign-lambda
    580569         void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
    581         (##ssl#unwrap-context obj) <>))
     570        (ssl-unwrap-context obj) <>))
    582571   (else
    583     ##ssl#abort 'ssl-load-suggested-certificate-authorities! #f pathname)))
     572    ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname)))
     573
     574)
  • release/4/openssl/openssl.setup

    r7147 r14315  
     1
    12(if (eq? (software-type) 'windows)
    23    (begin
    34      (compile
    4        -O2 -d0 -check-imports -s "openssl.scm" -lssl -lcrypto -lgdi32
    5        -o openssl.so -emit-exports "openssl.exports")
     5       -O2 -d0 -s -j openssl "openssl.scm" -lssl -lcrypto -lgdi32)
     6      (compile -O2 -d0 -s openssl.import.scm)
    67      (compile
    78       -O2 -d0 -c "openssl.scm" -lssl -lcrypto -lgdi32
     
    910    (begin
    1011      (compile
    11        -O2 -d0 -check-imports -s "openssl.scm" -lssl -lcrypto
    12        -o openssl.so -emit-exports "openssl.exports")
     12       -O2 -d0 -s -j openssl "openssl.scm" -lssl -lcrypto)
     13      (compile -O2 -d0 -s openssl.import.scm)
    1314      (compile
    1415       -O2 -d0 -c "openssl.scm" -lssl -lcrypto
    1516       -o openssl-static.o -unit openssl -D static)))
    16      
     17
    1718(install-extension
    1819  'openssl
    19   `("openssl.scm" "openssl.so" "openssl-static.o"
     20  '("openssl.scm" "openssl.so" "openssl.import.so" "openssl-static.o"
    2021    "openssl.html" "egg.jpg")
    21   '((version "1.1.6")
     22  '((version "1.2.0")
    2223    (static "openssl-static.o")
    2324    (static-options "-lssl -lcrypto -lgdi32")
Note: See TracChangeset for help on using the changeset viewer.