<commit_before>! Copyright (C) 2007, 2008, <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel sequences namespaces math
math.order combinators init alien alien.c-types alien.strings
libc continuations destructors summary splitting assocs random
math.parser locals unicode.case openssl openssl.libcrypto
openssl.libssl io.backend io.ports io.pathnames
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.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 ;

TUPLE: openssl-context < secure-context aliens sessions ;

: set-session-cache ( ctx -- )
    handle>>
    [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
    [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
    bi ;

: 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>> latin1 malloc-string ] [ 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
    ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;

: set-verify-depth ( ctx -- )
    dup config>> verify-depth>> [
        [ handle>> ] [ config>> verify-depth>> ] bi
        SSL_CTX_set_verify_depth
    ] [ drop ] if ;

TUPLE: bio handle disposed ;

: <bio> ( handle -- bio ) f bio boa ;
<commit_msg>io.sockets.secure.openssl: Don't allocate empty password string. Fixes test failures introduced by >c-ptr change<commit_after>! Copyright (C) 2007, 2008, <NAME>, <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel sequences namespaces math
math.order combinators init alien alien.c-types alien.strings
libc continuations destructors summary splitting assocs random
math.parser locals unicode.case openssl openssl.libcrypto
openssl.libssl io.backend io.ports io.pathnames
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.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 ;

TUPLE: openssl-context < secure-context aliens sessions ;

: set-session-cache ( ctx -- )
    handle>>
    [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
    [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
    bi ;

: 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>> latin1 malloc-string ] [ aliens>> ] bi
    [ push ] [ drop ] 2bi ;

: set-default-password ( ctx -- )
    dup config>> password>> [
        [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
        [
            [ handle>> ] [ default-pasword ] bi
            SSL_CTX_set_default_passwd_cb_userdata
        ] bi
    ] [ drop ] if ;

: 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
    ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;

: set-verify-depth ( ctx -- )
    dup config>> verify-depth>> [
        [ handle>> ] [ config>> verify-depth>> ] bi
        SSL_CTX_set_verify_depth
    ] [ drop ] if ;

TUPLE: bio handle disposed ;

: <bio> ( handle -- bio ) f bio boa ;

{'fraction_non_alphanumeric': 0.12288674786402472, 'fraction_numerical': 0.009089256498818397, 'mean_word_length': 2.5937295885042455, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 132, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3098422', 'n_tokens_mistral': 1870, 'n_tokens_neox': 1797, 'n_words': 451}