Working on OpenSSL
Slava Pestov
parent
e13be8ce3f
commit
2ddc0028f0
|
|
@ -88,6 +88,8 @@ FUNCTION: int BIO_puts ( void* bp, char* buf ) ;
|
|||
|
||||
FUNCTION: ulong ERR_get_error ( ) ;
|
||||
|
||||
FUNCTION: void ERR_clear_error ( ) ;
|
||||
|
||||
FUNCTION: char* ERR_error_string ( ulong e, void* buf ) ;
|
||||
|
||||
FUNCTION: void* BIO_f_buffer ( ) ;
|
||||
|
|
@ -96,6 +98,17 @@ FUNCTION: void* BIO_f_buffer ( ) ;
|
|||
! evp.h
|
||||
! ===============================================
|
||||
|
||||
: EVP_MAX_MD_SIZE 64 ;
|
||||
|
||||
C-STRUCT: EVP_MD_CTX
|
||||
{ "EVP_MD*" "digest" }
|
||||
{ "ENGINE*" "engine" }
|
||||
{ "ulong" "flags" }
|
||||
{ "void*" "md_data" } ;
|
||||
|
||||
TYPEDEF: void* EVP_MD*
|
||||
TYPEDEF: void* ENGINE*
|
||||
|
||||
! Initialize ciphers and digest tables
|
||||
FUNCTION: void OpenSSL_add_all_ciphers ( ) ;
|
||||
|
||||
|
|
@ -104,19 +117,35 @@ FUNCTION: void OpenSSL_add_all_digests ( ) ;
|
|||
! Clean them up before exiting
|
||||
FUNCTION: void EVP_cleanup ( ) ;
|
||||
|
||||
FUNCTION: void* EVP_get_digestbyname ( char* name ) ;
|
||||
FUNCTION: EVP_MD* EVP_get_digestbyname ( char* name ) ;
|
||||
|
||||
FUNCTION: void EVP_MD_CTX_init ( void* ctx ) ;
|
||||
FUNCTION: void EVP_MD_CTX_init ( EVP_MD* ctx ) ;
|
||||
|
||||
FUNCTION: int EVP_MD_CTX_cleanup ( EVP_MD_CTX* ctx ) ;
|
||||
|
||||
FUNCTION: EVP_MD_CTX* EVP_MD_CTX_create ( ) ;
|
||||
|
||||
FUNCTION: void EVP_MD_CTX_destroy ( EVP_MD_CTX* ctx ) ;
|
||||
|
||||
FUNCTION: int EVP_MD_CTX_copy_ex ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ;
|
||||
|
||||
FUNCTION: int EVP_DigestInit_ex ( EVP_MD_CTX* ctx, EVP_MD* type, ENGINE* impl ) ;
|
||||
|
||||
FUNCTION: int EVP_DigestUpdate ( EVP_MD_CTX* ctx, void* d, uint cnt ) ;
|
||||
|
||||
FUNCTION: int EVP_DigestFinal_ex ( EVP_MD_CTX* ctx, void* md, uint* s ) ;
|
||||
|
||||
FUNCTION: int EVP_Digest ( void* data, uint count, void* md, uint* size, EVP_MD* type, ENGINE* impl ) ;
|
||||
|
||||
FUNCTION: int EVP_MD_CTX_copy ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ;
|
||||
|
||||
FUNCTION: int EVP_DigestInit ( EVP_MD_CTX* ctx, EVP_MD* type ) ;
|
||||
|
||||
FUNCTION: int EVP_DigestFinal ( EVP_MD_CTX* ctx, void* md, uint* s ) ;
|
||||
|
||||
FUNCTION: void* PEM_read_bio_DHparams ( void* bp, void* x, void* cb,
|
||||
void* u ) ;
|
||||
|
||||
! ===============================================
|
||||
! md5.h
|
||||
! ===============================================
|
||||
|
||||
FUNCTION: uchar* MD5 ( uchar* d, ulong n, uchar* md ) ;
|
||||
|
||||
! ===============================================
|
||||
! rsa.h
|
||||
! ===============================================
|
||||
|
|
@ -97,6 +97,7 @@ FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
|
|||
! Load the certificates and private keys into the SSL_CTX
|
||||
FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
|
||||
char* file ) ; ! PEM type
|
||||
|
||||
FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
|
||||
|
||||
FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
|
||||
|
|
@ -121,6 +122,10 @@ FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
|
|||
|
||||
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ;
|
||||
|
||||
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;
|
||||
|
||||
FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
|
||||
|
||||
FUNCTION: void RAND_seed ( void* buf, int num ) ;
|
||||
|
|
@ -165,10 +170,64 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
|
|||
FUNCTION: void* BIO_f_ssl ( ) ;
|
||||
|
||||
! ===============================================
|
||||
! sha.h
|
||||
! x509.h
|
||||
! ===============================================
|
||||
|
||||
! For a high level interface to message digests
|
||||
! use the EVP digest routines in libcrypto.factor
|
||||
TYPEDEF: void* X509_NAME*
|
||||
|
||||
FUNCTION: uchar* SHA1 ( uchar* d, ulong n, uchar* md ) ;
|
||||
TYPEDEF: void* X509*
|
||||
|
||||
FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
|
||||
FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
|
||||
|
||||
! ===============================================
|
||||
! x509_vfy.h
|
||||
! ===============================================
|
||||
|
||||
: X509_V_OK 0 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT 2 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_GET_CRL 3 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline
|
||||
: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline
|
||||
: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline
|
||||
: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline
|
||||
: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline
|
||||
: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline
|
||||
: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline
|
||||
: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline
|
||||
: X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 ; inline
|
||||
: X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 ; inline
|
||||
: X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 ; inline
|
||||
: X509_V_ERR_OUT_OF_MEM 17 ; inline
|
||||
: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline
|
||||
: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline
|
||||
: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline
|
||||
: X509_V_ERR_CERT_REVOKED 23 ; inline
|
||||
: X509_V_ERR_INVALID_CA 24 ; inline
|
||||
: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline
|
||||
: X509_V_ERR_INVALID_PURPOSE 26 ; inline
|
||||
: X509_V_ERR_CERT_UNTRUSTED 27 ; inline
|
||||
: X509_V_ERR_CERT_REJECTED 28 ; inline
|
||||
: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline
|
||||
: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline
|
||||
: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline
|
||||
: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline
|
||||
: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline
|
||||
: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline
|
||||
: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline
|
||||
: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline
|
||||
: X509_V_ERR_INVALID_NON_CA 37 ; inline
|
||||
: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline
|
||||
: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline
|
||||
: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline
|
||||
: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline
|
||||
|
||||
! ===============================================
|
||||
! obj_mac.h
|
||||
! ===============================================
|
||||
|
||||
: NID_commonName 13 ; inline
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
USING: io.sockets.secure io.encodings.ascii alien.strings
|
||||
openssl namespaces accessors tools.test continuations kernel ;
|
||||
|
||||
openssl ssl-backend [
|
||||
[ ] [
|
||||
<ssl-config>
|
||||
"resource:extra/openssl/test/server.pem" >>key-file
|
||||
"resource:extra/openssl/test/root.pem" >>ca-file
|
||||
"password" ascii string>alien >>password
|
||||
[ ] with-ssl-context
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<ssl-config>
|
||||
"resource:extra/openssl/test/server.pem" >>key-file
|
||||
"resource:extra/openssl/test/root.pem" >>ca-file
|
||||
"wrong password" ascii string>alien >>password
|
||||
[ ] with-ssl-context
|
||||
] must-fail
|
||||
] with-variable
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.nonblocking io.files io.encodings.ascii io.sockets.secure ;
|
||||
IN: openssl
|
||||
|
||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||
|
||||
SINGLETON: openssl
|
||||
|
||||
GENERIC: ssl-method ( symbol -- method )
|
||||
|
||||
M: SSLv2 ssl-method drop SSLv2_client_method ;
|
||||
M: SSLv23 ssl-method drop SSLv23_method ;
|
||||
M: SSLv3 ssl-method drop SSLv3_method ;
|
||||
M: TLSv1 ssl-method drop TLSv1_method ;
|
||||
|
||||
: (ssl-error) ( num -- * )
|
||||
ERR_get_error ERR_clear_error f ERR_error_string throw ;
|
||||
|
||||
: ssl-error ( obj -- )
|
||||
{ f 0 } member? [ (ssl-error) ] when ;
|
||||
|
||||
: init-ssl ( -- )
|
||||
SSL_library_init ssl-error
|
||||
SSL_load_error_strings
|
||||
OpenSSL_add_all_digests
|
||||
OpenSSL_add_all_ciphers ;
|
||||
|
||||
SYMBOL: ssl-initiazed?
|
||||
|
||||
: maybe-init-ssl ( -- )
|
||||
ssl-initiazed? get-global [
|
||||
init-ssl
|
||||
t ssl-initiazed? set-global
|
||||
] unless ;
|
||||
|
||||
[ f ssl-initiazed? set-global ] "openssl" add-init-hook
|
||||
|
||||
TUPLE: openssl-context < ssl-context aliens ;
|
||||
|
||||
: load-certificate-chain ( ctx -- )
|
||||
dup config>> key-file>> [
|
||||
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
|
||||
SSL_CTX_use_certificate_chain_file
|
||||
ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
: password-callback ( -- alien )
|
||||
"int" { "void*" "int" "bool" "void*" } "cdecl"
|
||||
[| buf size rwflag password! |
|
||||
password [ B{ 0 } password! ] unless
|
||||
|
||||
[let | len [ password strlen ] |
|
||||
buf password len 1+ size min memcpy
|
||||
len
|
||||
]
|
||||
] alien-callback ;
|
||||
|
||||
: default-pasword ( ctx -- alien )
|
||||
[ config>> password>> malloc-byte-array ] [ aliens>> ] bi
|
||||
[ push ] [ drop ] 2bi ;
|
||||
|
||||
: set-default-password ( ctx -- )
|
||||
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
|
||||
[
|
||||
[ handle>> ] [ default-pasword ] bi
|
||||
SSL_CTX_set_default_passwd_cb_userdata
|
||||
] bi ;
|
||||
|
||||
: use-private-key-file ( ctx -- )
|
||||
dup config>> key-file>> [
|
||||
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
|
||||
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
|
||||
ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
: load-verify-locations ( ctx -- )
|
||||
dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
|
||||
[ handle>> ]
|
||||
[
|
||||
config>>
|
||||
[ ca-file>> dup [ (normalize-path) ] when ]
|
||||
[ ca-path>> dup [ (normalize-path) ] when ] bi
|
||||
] bi
|
||||
SSL_CTX_load_verify_locations ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
: set-verify-depth ( ctx -- )
|
||||
handle>> 1 SSL_CTX_set_verify_depth ;
|
||||
|
||||
M: openssl <ssl-context> ( config -- context )
|
||||
maybe-init-ssl
|
||||
[
|
||||
dup method>> ssl-method SSL_CTX_new
|
||||
dup ssl-error V{ } clone openssl-context boa
|
||||
dup add-error-destructor
|
||||
{
|
||||
[ load-certificate-chain ]
|
||||
[ set-default-password ]
|
||||
[ use-private-key-file ]
|
||||
[ load-verify-locations ]
|
||||
[ set-verify-depth ]
|
||||
[ ]
|
||||
} cleave
|
||||
] with-destructors ;
|
||||
|
||||
M: openssl-context dispose
|
||||
dup aliens>> [ free ] each f >>aliens
|
||||
dup handle>> [ SSL_CTX_free ] when* f >>handle
|
||||
drop ;
|
||||
|
||||
TUPLE: ssl file handle ;
|
||||
|
||||
: <ssl> ( file -- ssl )
|
||||
ssl-context get handle>> SSL_new dup ssl-error ssl boa ;
|
||||
|
||||
M: ssl init-handle drop ;
|
||||
|
||||
M: ssl close-handle
|
||||
[ file>> close-handle ] [ handle>> SSL_free ] bi ;
|
||||
|
||||
ERROR: certificate-verify-error result ;
|
||||
|
||||
: check-verify-result ( ssl-handle -- )
|
||||
SSL_get_verify_result dup X509_V_OK =
|
||||
[ certificate-verify-error ] [ drop ] if ;
|
||||
|
||||
: common-name ( certificate -- host )
|
||||
X509_get_subject_name
|
||||
NID_commonName 256 <byte-array>
|
||||
[ 256 X509_NAME_get_text_by_NID ] keep
|
||||
swap -1 = [ drop f ] [ ascii alien>string ] if ;
|
||||
|
||||
ERROR: common-name-verify-error expected got ;
|
||||
|
||||
: check-common-name ( host ssl-handle -- )
|
||||
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
|
||||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
: check-certificate ( host ssl -- )
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi ;
|
||||
|
||||
openssl ssl-backend set-global
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.files io.encodings.ascii io.sockets.secure ;
|
||||
IN: openssl.unix
|
||||
|
||||
|
||||
|
|
@ -1,146 +0,0 @@
|
|||
USING: alien alien.c-types alien.strings assocs bit-arrays
|
||||
hashtables io io.files io.encodings.ascii io.sockets kernel
|
||||
mirrors openssl.libcrypto openssl.libssl namespaces math
|
||||
math.parser openssl prettyprint sequences tools.test ;
|
||||
|
||||
! =========================================================
|
||||
! Some crypto functions (still to be turned into words)
|
||||
! =========================================================
|
||||
|
||||
[
|
||||
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
|
||||
]
|
||||
[ "Hello world from the openssl binding" >md5 ] unit-test
|
||||
|
||||
! Not found on netbsd, windows -- why?
|
||||
! [
|
||||
! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
|
||||
! 82 115 0 }
|
||||
! ]
|
||||
! [ "Hello world from the openssl binding" >sha1 ] unit-test
|
||||
|
||||
! =========================================================
|
||||
! Initialize context
|
||||
! =========================================================
|
||||
|
||||
[ ] [ init load-error-strings ] unit-test
|
||||
|
||||
[ ] [ ssl-v23 new-ctx ] unit-test
|
||||
|
||||
[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test
|
||||
|
||||
! TODO: debug 'Memory protection fault at address 6c'
|
||||
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
|
||||
|
||||
[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
|
||||
|
||||
! Enter PEM pass phrase: password
|
||||
[ ] [ get-ctx "resource:extra/openssl/test/server.pem"
|
||||
SSL_FILETYPE_PEM use-private-key ] unit-test
|
||||
|
||||
[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f
|
||||
verify-load-locations ] unit-test
|
||||
|
||||
[ ] [ get-ctx 1 set-verify-depth ] unit-test
|
||||
|
||||
! =========================================================
|
||||
! Load Diffie-Hellman parameters
|
||||
! =========================================================
|
||||
|
||||
[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test
|
||||
|
||||
[ ] [ get-bio f f f read-pem-dh-params ] unit-test
|
||||
|
||||
[ ] [ get-bio bio-free ] unit-test
|
||||
|
||||
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
|
||||
[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
|
||||
|
||||
! Workaround (this function should never be called directly)
|
||||
! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
|
||||
|
||||
! =========================================================
|
||||
! Generate ephemeral RSA key
|
||||
! =========================================================
|
||||
|
||||
[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
|
||||
|
||||
! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
|
||||
! get-ctx get-rsa set-tmp-rsa-callback
|
||||
|
||||
! Workaround (this function should never be called directly)
|
||||
[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
|
||||
|
||||
[ ] [ get-rsa free-rsa ] unit-test
|
||||
|
||||
! =========================================================
|
||||
! Listen and accept on socket
|
||||
! =========================================================
|
||||
|
||||
! SYMBOL: sock
|
||||
! SYMBOL: fdset
|
||||
! SYMBOL: acset
|
||||
! SYMBOL: sbio
|
||||
! SYMBOL: ssl
|
||||
!
|
||||
! : is-set ( seq -- newseq )
|
||||
! <enum> >alist [ nip ] assoc-filter >hashtable keys ;
|
||||
!
|
||||
! ! 1234 server-socket sock set
|
||||
! "127.0.0.1" 1234 <inet4> SOCK_STREAM server-fd sock set
|
||||
!
|
||||
! FD_SETSIZE 8 * <bit-array> fdset set
|
||||
!
|
||||
! FD_SETSIZE 8 * <bit-array> t 8 rot [ set-nth ] keep fdset set
|
||||
!
|
||||
! fdset get is-set .
|
||||
|
||||
! : loop ( -- )
|
||||
! sock get f f accept
|
||||
! dup -1 = [ drop ] [
|
||||
! dup number>string print flush
|
||||
! ! BIO_NOCLOSE bio-new-socket sbio set
|
||||
! [ get-ctx new-ssl ssl set ] keep
|
||||
! ssl get swap set-ssl-fd
|
||||
! ! ssl get sbio get dup set-ssl-bio
|
||||
! ! ssl get ssl-accept
|
||||
! ! dup 0 <= [
|
||||
! ! ssl get swap ssl-get-error
|
||||
! ! ] [ drop ] if
|
||||
! ] if
|
||||
! loop ;
|
||||
|
||||
! { } acset set
|
||||
!
|
||||
! : loop ( -- )
|
||||
! ! FD_SETSIZE fdset get f f f select . flush
|
||||
! FD_SETSIZE fdset get f f 10000 make-timeval select
|
||||
! 0 <= [ acset get [ close ] each "timeout" print ] [
|
||||
! fdset get is-set sock get swap member? [
|
||||
! sock get f f accept dup . flush
|
||||
! acset get swap add acset set
|
||||
! ] [ ] if
|
||||
! loop
|
||||
! ] if ;
|
||||
!
|
||||
! loop
|
||||
!
|
||||
! sock get close
|
||||
|
||||
! =========================================================
|
||||
! Dump errors to file
|
||||
! =========================================================
|
||||
|
||||
[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test
|
||||
|
||||
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
|
||||
|
||||
[ ] [ get-bio bio-free ] unit-test
|
||||
|
||||
! =========================================================
|
||||
! Clean-up
|
||||
! =========================================================
|
||||
|
||||
! sock get close
|
||||
|
||||
get-ctx destroy-ctx
|
||||
|
|
@ -1,154 +0,0 @@
|
|||
! Copyright (C) 2007 Elie CHAFTARI
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
|
||||
|
||||
USING: alien alien.c-types alien.strings assocs kernel libc
|
||||
namespaces openssl.libcrypto openssl.libssl sequences
|
||||
io.encodings.ascii ;
|
||||
|
||||
IN: openssl
|
||||
|
||||
SYMBOL: bio
|
||||
SYMBOL: ssl-bio
|
||||
|
||||
SYMBOL: ctx
|
||||
SYMBOL: dh
|
||||
SYMBOL: rsa
|
||||
|
||||
! =========================================================
|
||||
! Callback routines
|
||||
! =========================================================
|
||||
|
||||
: password-cb ( -- alien )
|
||||
"int" { "char*" "int" "int" "void*" } "cdecl"
|
||||
[ 3drop "password" ascii string>alien 1023 memcpy
|
||||
"password" length ] alien-callback ;
|
||||
|
||||
! =========================================================
|
||||
! Error-handling routines
|
||||
! =========================================================
|
||||
|
||||
: get-error ( -- num )
|
||||
ERR_get_error ;
|
||||
|
||||
: error-string ( num -- str )
|
||||
f ERR_error_string ;
|
||||
|
||||
: check-result ( result -- )
|
||||
1 = [ ] [
|
||||
get-error error-string throw
|
||||
] if ;
|
||||
|
||||
: ssl-get-error ( ssl ret -- )
|
||||
SSL_get_error error-messages at throw ;
|
||||
|
||||
! Write errors to a file
|
||||
: bio-new-file ( path mode -- )
|
||||
BIO_new_file bio set ;
|
||||
|
||||
: bio-print ( bio str -- n )
|
||||
BIO_printf ;
|
||||
|
||||
: bio-free ( bio -- )
|
||||
BIO_free check-result ;
|
||||
|
||||
! =========================================================
|
||||
! Initialization routines
|
||||
! =========================================================
|
||||
|
||||
: init ( -- )
|
||||
SSL_library_init drop ; ! always returns 1
|
||||
|
||||
: load-error-strings ( -- )
|
||||
SSL_load_error_strings ;
|
||||
|
||||
: ssl-v23 ( -- method )
|
||||
SSLv23_method ;
|
||||
|
||||
: new-ctx ( method -- )
|
||||
SSL_CTX_new ctx set ;
|
||||
|
||||
: use-cert-chain ( ctx file -- )
|
||||
SSL_CTX_use_certificate_chain_file check-result ;
|
||||
|
||||
: set-default-passwd ( ctx cb -- )
|
||||
SSL_CTX_set_default_passwd_cb ;
|
||||
|
||||
: set-default-passwd-userdata ( ctx passwd -- )
|
||||
SSL_CTX_set_default_passwd_cb_userdata ;
|
||||
|
||||
: use-private-key ( ctx file type -- )
|
||||
SSL_CTX_use_PrivateKey_file check-result ;
|
||||
|
||||
: verify-load-locations ( ctx file path -- )
|
||||
SSL_CTX_load_verify_locations check-result ;
|
||||
|
||||
: set-verify-depth ( ctx depth -- )
|
||||
SSL_CTX_set_verify_depth ;
|
||||
|
||||
: read-pem-dh-params ( bio x cb u -- )
|
||||
PEM_read_bio_DHparams dh set ;
|
||||
|
||||
: set-tmp-dh-callback ( ctx dh -- )
|
||||
SSL_CTX_set_tmp_dh_callback ;
|
||||
|
||||
: set-ctx-ctrl ( ctx cmd larg parg -- )
|
||||
SSL_CTX_ctrl check-result ;
|
||||
|
||||
: generate-rsa-key ( n e cb cbarg -- )
|
||||
RSA_generate_key rsa set ;
|
||||
|
||||
: set-tmp-rsa-callback ( ctx rsa -- )
|
||||
SSL_CTX_set_tmp_rsa_callback ;
|
||||
|
||||
: free-rsa ( rsa -- )
|
||||
RSA_free ;
|
||||
|
||||
: bio-new-socket ( fd flag -- sbio )
|
||||
BIO_new_socket ;
|
||||
|
||||
: new-ssl ( ctx -- ssl )
|
||||
SSL_new ;
|
||||
|
||||
: set-ssl-bio ( ssl bio bio -- )
|
||||
SSL_set_bio ;
|
||||
|
||||
: set-ssl-fd ( ssl fd -- )
|
||||
SSL_set_fd check-result ;
|
||||
|
||||
: ssl-accept ( ssl -- result )
|
||||
SSL_accept ;
|
||||
|
||||
! =========================================================
|
||||
! Clean-up and termination routines
|
||||
! =========================================================
|
||||
|
||||
: destroy-ctx ( ctx -- )
|
||||
SSL_CTX_free ;
|
||||
|
||||
! =========================================================
|
||||
! Public routines
|
||||
! =========================================================
|
||||
|
||||
: get-bio ( -- bio )
|
||||
bio get ;
|
||||
|
||||
: get-ssl-bio ( -- bio )
|
||||
ssl-bio get ;
|
||||
|
||||
: get-ctx ( -- ctx )
|
||||
ctx get ;
|
||||
|
||||
: get-dh ( -- dh )
|
||||
dh get ;
|
||||
|
||||
: get-rsa ( -- rsa )
|
||||
rsa get ;
|
||||
|
||||
: >md5 ( str -- byte-array )
|
||||
dup length 16 "uchar" <c-array> [ MD5 ] keep nip ;
|
||||
|
||||
: >sha1 ( str -- byte-array )
|
||||
dup length 20 "uchar" <c-array> [ SHA1 ] keep nip ;
|
||||
|
||||
Loading…
Reference in New Issue