src/cdeps/Makefile

 CC=gcc
-OBJS:=bsearch.o systemsignal.o systemprocess.o WCsubst.o
+OBJS:=bsearch.o cryptossl.o systemsignal.o systemprocess.o WCsubst.o
 
 all: $(OBJS)
 

src/cdeps/cryptossl.c

+#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;
+}

src/libraries/OS-Independent/Crypto/SSL.dcl

+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)

src/libraries/OS-Independent/Crypto/SSL.icl

+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"
+}

tests/.gitignore

 common/commentstest
 common/gentest
 common/snappytest
+common/ssltest
 common/systemprocesstest
 common/tartest
 

tests/common/Makefile

@@ -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)

tests/common/ssltest.icl

+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+++"'")

tests/imports_common.icl

@@ -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