...
 
Commits (1)
CC=gcc
OBJS:=bsearch.o systemsignal.o systemprocess.o WCsubst.o
OBJS:=bsearch.o cryptossl.o systemsignal.o systemprocess.o WCsubst.o
all: $(OBJS)
......
#include <openssl/ssl.h>
#include <openssl/ocsp.h>
int SSL_CTX_set_verify_help(SSL_CTX *ctx, int mode)
{
SSL_CTX_set_verify(ctx, mode, NULL);
return 1;
}
int X509_VERIFY_PARAM_set_hostflags_help(X509_VERIFY_PARAM *param, unsigned int flags)
{
X509_VERIFY_PARAM_set_hostflags(param, flags);
return 1;
}
int SSL_CTX_set_verify_depth_help(SSL_CTX *ctx, int depth)
{
SSL_CTX_set_verify_depth(ctx, depth);
return 1;
}
definition module Crypto.SSL
from Data.Error import :: MaybeError
from System._Pointer import :: Pointer
:: SSLContext (:== Pointer)
initSSL :: !String !Int !*World -> *(!MaybeError String SSLContext, !*World)
writeSSL :: !String !SSLContext !*World -> (!MaybeError String (), *World)
readAllSSL :: !SSLContext !*World -> *(!MaybeError String String, !*World)
implementation module Crypto.SSL
import StdEnv
import Data.Error
import Data.Func
import System.FilePath
import System._Pointer
import code from "cryptossl."
// Linux / mac:
import code from library "-lcrypto"
import code from library "-lssl"
:: SSLContext :== Pointer
:: SSLMethod :== Pointer
:: SSLOption :== Int
:: SSLCTX :== Pointer
:: BIO :== Pointer
// See: https://wiki.openssl.org/index.php/SSL/TLS_Client
initSSL :: !String !Int !*World -> *(!MaybeError String SSLContext, !*World)
initSSL host port w
#! (_,w) = OPENSSL_init_ssl 0 0 w
#! (meth,w) = TLS_method w
| meth == 0 = (Error "TLS_method failed", w)
#! (ctx,w) = SSL_CTX_new meth w
| ctx == 0 = (Error "SSL_CTX_new failed", w)
#! (prm,w) = SSL_CTX_get0_param ctx w
#! (_,w) = X509_VERIFY_PARAM_set_hostflags prm X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS w
#! w = X509_VERIFY_PARAM_set1_host prm host w
#! w = SSL_CTX_set_verify ctx SSL_VERIFY_PEER w
#! (_,w) = SSL_CTX_set_verify_depth ctx 4 w
// NB: the below would enable CRL checking. However, we would still need a
// way to actually fetch CRLs, and ideally cache them. Because this is
// currently not implemented, CRL checking is disabled.
//#! (prm,w) = X509_VERIFY_PARAM_new w
//#! (_,w) = X509_VERIFY_PARAM_set_flags prm X509_V_FLAG_CRL_CHECK w
//#! (str,w) = SSL_CTX_get_cert_store ctx w
//#! (_,w) = X509_STORE_set1_param str prm w
// TODO: eventually, we might enable certificate transparency checking here.
// However, this requires OpenSSL to be bundled with ct_log_list.cnf, which it is currently not in
// major linux distributions. For this reason the check is currently disabled. For details, see:
// https://www.certificate-transparency.org/certificate-transparency-in-openssl
//#! (res,w) = SSL_CTX_enable_ct ctx SSL_CT_VALIDATION_STRICT w
//| res <> 1 = (Error "SSL_CTX_enable_ct failed", w)
#! w = SSL_CTX_set_options ctx [SSL_OP_NO_SSLv2, SSL_OP_NO_SSLv3, SSL_OP_NO_COMPRESSION] w
#! (res,w) = SSL_CTX_load_verify_locations_file ctx "/etc/ssl/certs/ca-certificates.crt" w
| res <> 1 = (Error "SSL_CTX_load_verify_locations_file failed", w)
#! (web,w) = BIO_new_ssl_connect ctx w
| web == 0 = (Error "BIO_new_ssl_connect failed", w)
#! (res,w) = BIO_set_conn_hostname web host port w
| res <> 1 = (Error "BIO_set_conn_hostname failed", w)
#! (ssl,w) = BIO_get_ssl web w
| ssl == 0 = (Error "BIO_get_ssl failed", w)
#! (res,w) = SSL_set_cipher_list ssl "HIGH:!aNULL:!kRSA:!PSK:!SRP:!MD5:!RC4:!SHA1:!SHA256:!SHA384:!DH" w
| res <> 1 = (Error "SSL_set_cipher_list failed", w)
#! (res,w) = SSL_set_tlsext_host_name ssl host w
| res <> 1 = (Error "SSL_set_tlsext_host_name failed", w)
#! (res,w) = BIO_do_connect web w
| res <> 1 = (Error "BIO_do_connect failed", w)
#! (res,w) = BIO_do_handshake web w
| res <> 1 = (Error "BIO_do_handshake failed", w)
| otherwise = (Ok web,w)
where
OPENSSL_init_ssl :: !Int !Pointer !*World -> *(!Int, !*World)
OPENSSL_init_ssl _ _ w = code {
ccall OPENSSL_init_ssl "Ip:I:A"
}
writeSSL :: !String !SSLContext !*World -> (!MaybeError String (), *World)
writeSSL data ctx w
# (res,w) = BIO_puts ctx data w
| res == size data
= (Ok (), w)
| res < 0
= (Error "writeSSL: an error occurred", w)
| res == 0
= (Error "writeSSL: could not write data", w)
= (Error ("writeSSL: only "+++toString res+++" bytes could be written"), w)
read_buffer :: String
read_buffer =: createArray READ_SIZE '\0'
READ_SIZE = 1536
readAllSSL :: !SSLContext !*World -> *(!MaybeError String String, !*World)
readAllSSL bio w
#! read_buffer = array_ptr read_buffer + IF_INT_64_OR_32 24 12
#! (n,w) = BIO_read bio read_buffer READ_SIZE w
#! (r,w) = BIO_test_flags bio BIO_FLAGS_SHOULD_RETRY w
#! (s,w) = (derefString read_buffer,w)
#! s = s % (0, n-1)
| n < 0
| r == 0 = (Error "readAllSSL: BIO_read failed", w)
| otherwise = readAllSSL bio w
| n == 0
= (Ok s, w)
#! (rest,w) = readAllSSL bio w
| isError rest
= (rest, w)
= (Ok (s +++ fromOk rest), w) // TODO: remove concatenation
where
array_ptr :: !String -> Pointer
array_ptr _ = code {
push_a_b 0
pop_a 1
}
TLS_method :: !*World -> *(!SSLMethod, !*World)
TLS_method w = code {
ccall TLS_method ":p:A"
}
SSL_CTX_new :: !SSLMethod !*World -> *(!SSLCTX, !*World)
SSL_CTX_new m w = code {
ccall SSL_CTX_new "p:p:A"
}
SSL_CTX_get0_param :: !SSLCTX !*World -> *(!Pointer, !*World)
SSL_CTX_get0_param ctx w = code {
ccall SSL_CTX_get0_param "p:p:A"
}
X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS :== 0x4
X509_VERIFY_PARAM_set_hostflags :: !Pointer !Int !*World -> *(!Int, !*World)
X509_VERIFY_PARAM_set_hostflags param flags w = code {
ccall X509_VERIFY_PARAM_set_hostflags_help "pI:I:A"
}
X509_VERIFY_PARAM_set1_host :: !Pointer !String !*World -> *World
X509_VERIFY_PARAM_set1_host param s w = snd (set param (packString s) 0 w)
where
set :: !Pointer !String !Int !*World -> *(!Int, !*World)
set param s len w = code {
ccall X509_VERIFY_PARAM_set1_host "psI:I:A"
}
SSL_CTX_get_cert_store :: !SSLCTX !*World -> *(!Pointer, !*World)
SSL_CTX_get_cert_store ctx w = code {
ccall SSL_CTX_get_cert_store "p:p:A"
}
X509_STORE_set1_param :: !Pointer !Pointer !*World -> *(!Int, !*World)
X509_STORE_set1_param store param w = code {
ccall X509_STORE_set1_param "pp:I:A"
}
X509_VERIFY_PARAM_new :: !*World -> *(!Pointer, !*World)
X509_VERIFY_PARAM_new w = code {
ccall X509_VERIFY_PARAM_new ":p:A"
}
X509_V_FLAG_CRL_CHECK :== 0x4
X509_VERIFY_PARAM_set_flags :: !Pointer !Int !*World -> *(!Int, !*World)
X509_VERIFY_PARAM_set_flags param flags w = code {
ccall X509_VERIFY_PARAM_set_flags "pI:I:A"
}
SSL_VERIFY_PEER :== 0x01
SSL_CTX_set_verify :: !SSLCTX !Int !*World -> *World
SSL_CTX_set_verify ctx mode w = snd (set_verify ctx mode w)
where
set_verify :: !SSLCTX !Int /*!Pointer*/ !*World -> *(!Int, !*World)
set_verify ctx mode /*callback*/ w = code {
ccall SSL_CTX_set_verify_help "pI:I:A"
}
SSL_CTX_set_verify_depth :: !SSLCTX !Int !*World -> *(!Int, !*World)
SSL_CTX_set_verify_depth ctx depth w = code {
ccall SSL_CTX_set_verify_depth_help "pI:I:A"
}
SSL_CTX_load_verify_locations_file :: !SSLCTX !FilePath !*World -> *(!Int, !*World)
SSL_CTX_load_verify_locations_file ctx file w
= load_verify_locations ctx (packString file) 0 w
where
load_verify_locations :: !SSLCTX !String !Pointer !*World -> *(!Int, !*World)
load_verify_locations ctx file dir w = code {
ccall SSL_CTX_load_verify_locations "psp:I:A"
}
SSL_CT_VALIDATION_STRICT :== 1
SSL_CTX_enable_ct :: !SSLCTX !Int !*World -> *(!Int, !*World)
SSL_CTX_enable_ct ctx setting w = code {
ccall SSL_CTX_enable_ct "pI:I:A"
}
SSL_OP_NO_COMPRESSION :== 0x00020000
SSL_OP_NO_SSLv2 :== 0x01000000
SSL_OP_NO_SSLv3 :== 0x02000000
SSL_CTX_set_options :: !SSLCTX [SSLOption] *World -> *World
SSL_CTX_set_options ctx opts w = snd $ SSL_CTX_ctrl ctx SSL_CTRL_OPTIONS (foldr (bitor) 0 opts) 0 w
SSL_CTRL_OPTIONS :== 32
SSL_CTX_ctrl :: !SSLCTX !Int !Int !Pointer !*World -> *(!Int, !*World)
SSL_CTX_ctrl ctx cmd larg parg w = code {
ccall SSL_CTX_ctrl "pIpp:p:A"
}
SSL_set_cipher_list :: !Pointer !String !*World -> *(!Int, !*World)
SSL_set_cipher_list ssl list w = set_cipher_list ssl (packString list) w
where
set_cipher_list :: !Pointer !String !*World -> *(!Int, !*World)
set_cipher_list ssl list w = code {
ccall SSL_set_cipher_list "ps:I:A"
}
SSL_set_tlsext_host_name :: !Pointer !String !*World -> *(!Int, !*World)
SSL_set_tlsext_host_name ssl host w
= SSL_ctrl_string ssl SSL_CTRL_SET_TLSEXT_HOSTNAME TLSEXT_NAMETYPE_host_name host w
where TLSEXT_NAMETYPE_host_name = 0
SSL_CTRL_SET_TLSEXT_HOSTNAME :== 55
SSL_ctrl_string :: !Pointer !Int !Int !String !*World -> *(!Int, !*World)
SSL_ctrl_string ssl cmd larg parg w = call ssl cmd /*(size parg)*/ larg (packString parg) w
where
call :: !Pointer !Int !Int !String !*World -> *(!Int, !*World)
call ssl cmd larg parg w = code {
ccall SSL_ctrl "pIps:p:A"
}
BIO_new_ssl_connect :: !SSLCTX !*World -> *(!BIO, *World)
BIO_new_ssl_connect ctx w = code {
ccall BIO_new_ssl_connect "p:p:A"
}
BIO_set_conn_hostname :: !BIO !String !Int !*World -> *(!Int, !*World)
BIO_set_conn_hostname bio host port w
= BIO_ctrl_string bio BIO_C_SET_CONNECT 0 (host +++ ":" +++ toString port) w
BIO_C_GET_SSL :== 110
BIO_get_ssl :: !BIO !*World -> *(!Pointer, !*World)
BIO_get_ssl bio w = ctrl bio BIO_C_GET_SSL 0 w
where
ctrl :: !BIO !Int !Int !*World -> *(!Pointer, !*World)
ctrl bio cmd arg w = code {
ccall BIO_ctrl "pIp:Vp:A"
}
BIO_do_connect :== BIO_do_handshake
BIO_do_handshake :: !BIO !*World -> *(!Int, !*World)
BIO_do_handshake bio w = BIO_ctrl_ptr bio BIO_C_DO_STATE_MACHINE 0 0 w
BIO_C_DO_STATE_MACHINE :== 101
BIO_ctrl_ptr :: !BIO !Int !Int !Pointer !*World -> *(!Int, !*World)
BIO_ctrl_ptr bio cmd larg parg w = code {
ccall BIO_ctrl "pIpp:p:A"
}
BIO_C_SET_CONNECT :== 100
BIO_ctrl_string :: !BIO !Int !Int !String !*World -> *(!Int, !*World)
BIO_ctrl_string bio cmd larg parg w = call bio cmd larg (packString parg) w
where
call :: !BIO !Int !Int !String !*World -> *(!Int, !*World)
call bio cmd larg parg w = code {
ccall BIO_ctrl "pIps:p:A"
}
BIO_puts :: !BIO !String !*World -> (!Int, !*World)
BIO_puts bio s w = puts bio (packString s) w
where
puts :: !BIO !String !*World -> *(!Int, !*World)
puts bio s w = code {
ccall BIO_puts "ps:I:A"
}
BIO_read :: !BIO !Pointer !Int !*World -> *(!Int, !*World)
BIO_read bio p n w = code {
ccall BIO_read "ppI:I:A"
}
BIO_FLAGS_SHOULD_RETRY :== 0x08
BIO_test_flags :: !BIO !Int !*World -> *(!Int, !*World)
BIO_test_flags bio f w = code {
ccall BIO_test_flags "pI:I:A"
}
common/commentstest
common/gentest
common/snappytest
common/ssltest
common/systemprocesstest
common/tartest
......
......@@ -26,7 +26,7 @@ COCLLIBS:=\
-I $(COCLPATH)/main\
-I $(COCLPATH)/main/Unix
BINARIES:=commentstest gentest snappytest systemprocesstest tartest
BINARIES:=commentstest gentest snappytest ssltest systemprocesstest tartest
RUN_BINARIES:=$(addprefix run_,$(BINARIES))
all: $(RUN_BINARIES)
......
module ssltest
import StdEnv
import StdMaybe
import Crypto.SSL
import Data.Error
import Data.Func
import Internet.HTTP
import System.CommandLine
Start w =
seqSt
(\(host,port,expected) w
# (_,w) = fclose (stderr <<< host <<< "... ") w
# (mbErr,w) = test host port expected w
| isError mbErr
-> setReturnCode 1 (snd (fclose (stderr <<< fromError mbErr <<< "\n") w))
-> snd (fclose (stderr <<< "ok.\n") w))
tests w
where
// See https://badssl.com/dashboard/
tests =
[ ("badssl.com", 443, Ok 200)
// Certificate validation (high risk)
, ("expired.badssl.com", 443, Error "BIO_do_connect failed")
, ("wrong.host.badssl.com", 443, Error "BIO_do_connect failed")
, ("self-signed.badssl.com", 443, Error "BIO_do_connect failed")
, ("untrusted-root.badssl.com", 443, Error "BIO_do_connect failed")
// Interception certificates (high risk)
, ("superfish.badssl.com", 443, Error "BIO_do_connect failed")
, ("edellroot.badssl.com", 443, Error "BIO_do_connect failed")
, ("dsdtestprovider.badssl.com", 443, Error "BIO_do_connect failed")
, ("preact-cli.badssl.com", 443, Error "BIO_do_connect failed")
, ("webpack-dev-server.badssl.com", 443, Error "BIO_do_connect failed")
// Broken cryptography (medium risk)
, ("sha1-intermediate.badssl.com", 443, Error "BIO_do_connect failed")
, ("rc4.badssl.com", 443, Error "BIO_do_connect failed")
, ("rc4-md5.badssl.com", 443, Error "BIO_do_connect failed")
, ("dh480.badssl.com", 443, Error "BIO_do_connect failed")
, ("dh512.badssl.com", 443, Error "BIO_do_connect failed")
, ("dh1024.badssl.com", 443, Error "BIO_do_connect failed")
, ("null.badssl.com", 443, Error "BIO_do_connect failed")
// Legacy cryptography (moderate risk)
, ("tls-v1-0.badssl.com", 1010, Error "BIO_do_connect failed")
, ("tls-v1-1.badssl.com", 1011, Error "BIO_do_connect failed")
, ("cbc.badssl.com", 443, Error "BIO_do_connect failed")
, ("3des.badssl.com", 443, Error "BIO_do_connect failed")
, ("dh2048.badssl.com", 443, Error "BIO_do_connect failed")
// Domain security policies
// , ("revoked.badssl.com", 443, Error "BIO_do_connect failed") // Revocation is not checked; see initSSL for explanation
// , ("pinning-test.badssl.com", 443, Error "BIO_do_connect failed") // TODO: this test fails for unknown reasons
, ("invalid-expected-sct.badssl.com", 443, Error "BIO_do_connect failed")
// , ("no-sct.badssl.com", 443, Error "BIO_do_connect failed") // Certificate transparency is not enabled yet; see initSSL for explanation
// Secure (uncommon)
, ("1000-sans.badssl.com", 443, Ok 200)
// , ("10000-sans.badssl.com", 443, Ok 200) // not supported but uncommon, don't care
, ("sha384.badssl.com", 443, Ok 200)
, ("sha512.badssl.com", 443, Ok 200)
, ("rsa8192.badssl.com", 443, Ok 200)
// , ("no-subject.badssl.com", 443, Ok 200) // not supported but uncommon, don't care
// , ("no-common-name.badssl.com", 443, Ok 200) // not supported but uncommon, don't care
// , ("incomplete-chain.badssl.com", 443, Ok 200) // not supported but uncommon, don't care
// Secure (common)
, ("tls-v1-2.badssl.com", 1012, Ok 200)
, ("sha256.badssl.com", 443, Ok 200)
, ("rsa2048.badssl.com", 443, Ok 200)
, ("ecc256.badssl.com", 443, Ok 200)
, ("ecc384.badssl.com", 443, Ok 200)
, ("extended-validation.badssl.com", 443, Ok 200)
, ("mozilla-modern.badssl.com", 443, Ok 200)
]
test :: !String !Int !(MaybeError String Int) !*World -> (!MaybeError String (), !*World)
test host port expected w
#! (mbCtx,w) = initSSL host port w
| isError mbCtx
= (check mbCtx, w)
#! ctx = fromOk mbCtx
#! (mbErr,w) = writeSSL (toString req) ctx w
| isError mbErr
= (check mbErr, w)
#! (mbResp,w) = readAllSSL ctx w
| isError mbResp
= (check mbResp, w)
#! mbResp = parseResponse (fromOk mbResp)
| isNone mbResp
= (Error "failed to parse HTTP response", w)
| isError expected
= (Error ("missed error: "+++fromError expected), w)
#! {HTTPResponse | rsp_code} = fromJust mbResp
| rsp_code <> fromOk expected
= (Error ("unexpected HTTP status code "+++toString rsp_code+++"; expected "+++toString (fromOk expected)), w)
= (Ok (), w)
where
req =
{ newHTTPRequest
& req_path = "/"
, server_name = host
, server_port = port
}
check (Error e) = case expected of
Ok _ -> Error ("unexpected error: "+++e)
Error exp
| e == exp -> Ok ()
| otherwise -> Error ("unexpected error '"+++e+++"'; expected '"+++exp+++"'")
......@@ -69,6 +69,7 @@ import qualified Control.Monad.Trans
import qualified Control.Monad.Writer
import qualified Crypto.Hash.MD5
import qualified Crypto.Hash.SHA1
import qualified Crypto.SSL
import qualified Data.Array
import qualified Data.Bifunctor
import qualified Data.CircularStack
......