145 lines
4.0 KiB
Factor
145 lines
4.0 KiB
Factor
USING: alien alien.c-types assocs bit-arrays hashtables io io.files
|
|
io.sockets kernel mirrors openssl.libcrypto openssl.libssl
|
|
namespaces math math.parser openssl prettyprint sequences tools.test unix ;
|
|
|
|
! =========================================================
|
|
! 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
|
|
|
|
[
|
|
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
|
|
|
|
ssl-v23 new-ctx
|
|
|
|
get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
|
|
|
|
! 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" string>char-alien set-default-passwd-userdata
|
|
|
|
! Enter PEM pass phrase: password
|
|
get-ctx "/extra/openssl/test/server.pem" resource-path
|
|
SSL_FILETYPE_PEM use-private-key
|
|
|
|
get-ctx "/extra/openssl/test/root.pem" resource-path f
|
|
verify-load-locations
|
|
|
|
get-ctx 1 set-verify-depth
|
|
|
|
! =========================================================
|
|
! Load Diffie-Hellman parameters
|
|
! =========================================================
|
|
|
|
"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
|
|
|
|
get-bio f f f read-pem-dh-params
|
|
|
|
get-bio bio-free
|
|
|
|
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
|
|
! get-ctx get-dh set-tmp-dh-callback
|
|
|
|
! Workaround (this function should never be called directly)
|
|
get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl
|
|
|
|
! =========================================================
|
|
! Generate ephemeral RSA key
|
|
! =========================================================
|
|
|
|
512 RSA_F4 f f generate-rsa-key
|
|
|
|
! 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
|
|
|
|
get-rsa free-rsa
|
|
|
|
! =========================================================
|
|
! Listen and accept on socket
|
|
! =========================================================
|
|
|
|
! SYMBOL: sock
|
|
! SYMBOL: fdset
|
|
! SYMBOL: acset
|
|
! SYMBOL: sbio
|
|
! SYMBOL: ssl
|
|
!
|
|
! : is-set ( seq -- newseq )
|
|
! <enum> >alist [ nip ] assoc-subset >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
|
|
! =========================================================
|
|
|
|
"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
|
|
|
|
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
|
|
|
|
get-bio bio-free
|
|
|
|
! =========================================================
|
|
! Clean-up
|
|
! =========================================================
|
|
|
|
! sock get close
|
|
|
|
get-ctx destroy-ctx
|