diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,38 +5,32 @@ Introduction ------------ -This is an early-stage and very experimental library to create HTTP/2 servers -using Haskell. +This is a library for creating HTTP/2 servers. -To see the package docs, please check the Hackage page or +To see some introductory docs, please check the Hackage page or the file hs-src/SecondTransfer.hs. +Supported platforms +------------------- + +At the moment, we only support Linux. But there are plans to support other platforms. + Building and installing ----------------------- -You need Haskell GHC compiler installed (version 7.8.3 at least). You also -need OpenSSL 1.0.2, since the ALPN feature and some very recent cypher-suites -are needed by HTTP/2. this source distribution will try to find them at -directory `/opt/openssl-1.0.2`, but you should be able to -alter the options using `cabal configure`. This package uses Haskell's FFI to interface with OpenSSL. - -Provided that you have all the dependencies, you should be able to just do: +The preferred method of installing SecondTransfer is through [Stack](https://github.com/commercialhaskell/stack). +SecondTransfer embeds [Botan](http://botan.randombit.net/) for its TLS layer. +Therefore, a modern C++ compiler (e.g., g++ 4.8) should be available at compile time. - $ cabal install second-transfer +We used OpenSSL in the past +and there is a possibility of supporting it again in the future. Running the tests ----------------- - $ cabal test - - -Debugging complicated scenarios -------------------------------- - -To access full debugging capabilities, for example from the test suite, use the -following command from the project's directory: - - $ cabal exec -- ghci -ihs-src -itests/tests-hs-src -itests/support -XCPP -Imacros/ dist/build/cbits/tlsinc.o +There are two sets of tests: normal Haskell tests and a custom test suite called Suite 1 that requires +Stack, Python 3.4+, Redis running in localhost/standard port with DB 3 erasable, and Numpy. +To run Suite 1, SecondTransfer should be compiled with the "Monitoring" flag enabled. Example ------- diff --git a/cbits/enable_tls.cpp b/cbits/enable_tls.cpp new file mode 100644 --- /dev/null +++ b/cbits/enable_tls.cpp @@ -0,0 +1,410 @@ + +#ifdef INCLUDE_BOTAN_ALL_H +#include "botan_all.h" +#else + +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "Botan_stub.h" +#include + +#include + +// TODO: +// +// Consider marking these functions "safe" in Haskell code. +// For that to work, you need first to change them in such a way that no lock +// takes place, that is, you shouldn't call back to Haskell code from here, but +// instead have the callbacks to simply write that in a provided buffer. +// +// This is also a good point to write about the "TLS overhead." + +namespace second_transfer { + +// Just because of the conversions, but it may be a handy place for +// other stuff later. +void output_dn_cb (void* botan_pad_ref, const unsigned char a[], size_t sz) +{ + iocba_push(botan_pad_ref, (char*)a, sz); +} + +void data_cb (void* botan_pad_ref, const unsigned char a[], size_t sz) +{ + iocba_data_cb(botan_pad_ref, (char*)a, sz); +} + +void alert_cb (void* botan_pad_ref, Botan::TLS::Alert const& alert, const unsigned char a[], size_t sz) +{ + // printf("BOTAN WAS TO DELIVER ALERT: %d \n", alert.type_string().c_str()); + if (alert.is_valid() && alert.is_fatal() ) + { + // TODO: Propagate this softly. + iocba_alert_cb(botan_pad_ref, -1); + } else { + // printf("Ignore an alert!!\n"); + } +} + +bool handshake_cb(void* botan_pad_ref, const Botan::TLS::Session&) +{ + iocba_handshake_cb(botan_pad_ref); + // TODO: Implement cache management + return false; +} + +// TODO: We can use stronger ciphers here. For now let's go simple +class HereTLSPolicy: public Botan::TLS::Policy { +public: + virtual bool acceptable_protocol_version(const Botan::TLS::Protocol_Version& v) + { + return v == Botan::TLS::Protocol_Version::TLS_V12; + } + + virtual std::vector allowed_macs() const + { + std::vector result; + result.push_back("AEAD"); + result.push_back("SHA-384"); + result.push_back("SHA-256"); + // + result.push_back("SHA-1"); + return result; + } + + virtual std::vector allowed_ciphers() const + { + std::vector result; + result.push_back("ChaCha20Poly1305"); + result.push_back("AES-256/GCM"); + result.push_back("AES-128/GCM"); + result.push_back("Camellia-256/GCM"); + result.push_back("AES-256/OCB(12)"); + result.push_back("AES-256/CCM"); + // For use with old browsers.... + result.push_back("AES-256"); + result.push_back("3DES"); + return result; + } + + virtual std::vector allowed_key_exchange_methods() const + { + std::vector result; + result.push_back("ECDH"); + result.push_back("DH"); + result.push_back("RSA"); + result.push_back("EDCHE"); + return result; + } + + virtual std::vector allowed_signature_hashes() const + { + std::vector result; + result.push_back("SHA-256"); + return result; + } + + virtual std::vector allowed_signature_methods() const + { + std::vector result; + result.push_back("RSA"); + return result; + } + + // This is experimental, may need to change. + virtual bool server_uses_own_ciphersuite_preferences() const + { + return true; + } + +}; + +// TODO: We can use different certificates if needs come.... +class HereCredentialsManager: public Botan::Credentials_Manager { + std::vector certs; + Botan::Private_Key* privkey; +public: + HereCredentialsManager( + const char* cert_filename, + const char* privkey_filename, + Botan::AutoSeeded_RNG& rng + ) + { + // In addition to the certificate itself, build a chain + // of certificates + Botan::DataSource_Stream dss(cert_filename); + int i = 0; + while ( not dss.end_of_data() ) + { + try { + certs.push_back(Botan::X509_Certificate(dss)); + } catch (Botan::Decoding_Error const& err) + { + if ( i == 0) + { + throw; + } else + { + break; + } + } + i ++; + } + privkey = Botan::PKCS8::load_key( + privkey_filename, rng + ); + } + + HereCredentialsManager( + const uint8_t* cert_data, + uint32_t cert_data_len, + const uint8_t* privkey_data, + uint32_t privkey_data_len, + Botan::AutoSeeded_RNG& rng + ) + { + std::string cert_string((char*)cert_data, cert_data_len); + std::stringstream certs_source(cert_string); + std::string key_string((char*)privkey_data, privkey_data_len); + std::stringstream key_source(key_string); + // In addition to the certificate itself, build a chain + // of certificates + Botan::DataSource_Stream certs_source_(certs_source); + Botan::DataSource_Stream key_source_(key_source); + int i = 0; + while ( not certs_source_.end_of_data() ) + { + try { + certs.push_back(Botan::X509_Certificate(certs_source_)); + } catch (Botan::Decoding_Error const& err) + { + if ( i == 0) + { + throw; + } else + { + break; + } + } + i ++; + } + privkey = Botan::PKCS8::load_key( + key_source_, rng + ); + } + + virtual std::vector< + Botan::X509_Certificate > cert_chain( + const std::vector< std::string >&, + const std::string&, + const std::string& ) + { + return certs; + } + + virtual Botan::Private_Key* private_key_for(const Botan::X509_Certificate &cert, const std::string & type, const std::string &context) + { + return privkey; + } + + ~HereCredentialsManager() + { + delete privkey; + } +}; + +std::string defaultProtocolSelector(void* botan_pad_ref, std::vector const& prots) +{ + std::string pass_to_haskell; + bool is_first = true; + for (int i=0; i < prots.size(); i++ ) + { + if ( is_first ) + { + is_first=false; + } else + { + pass_to_haskell += '\0'; + } + pass_to_haskell += prots[i]; + //printf("Prot: %s \n", prots[i].c_str()); + } + int idx = iocba_select_protocol_cb( botan_pad_ref, (void*)pass_to_haskell.c_str(), pass_to_haskell.size()); + //printf("Prot selected: %d \n", idx); + if ( idx >= 0 ) + return prots[idx]; + else + throw Botan::TLS::TLS_Exception( Botan::TLS::Alert::NO_APPLICATION_PROTOCOL, "ShimmerCat:NoApplicationProtocol" ); +} + +} // namespace + +extern "C" int iocba_receive_data( + void* tls_channel, + char* data, + int length ) +{ + Botan::TLS::Channel* channel = (Botan::TLS::Channel*) tls_channel; + try { + //printf("Before taking data=%p \n", channel); + size_t more_data_required = channel->received_data( (const unsigned char*) data, length); + //printf("More data required %d \n", more_data_required); + //printf("After taking data=%p \n", channel); + } catch (std::exception const& e) + { + // TODO: control messages + printf("BotanTLS engine instance crashed (normal if ALPN didn't go well): %s \n", e.what()); + return -1; + } + return 0; +} + +extern "C" void iocba_cleartext_push( + void* tls_channel, + char* data, + int length ) +{ + // TODO: Check for "can send"!!!!! + // OTHERWISE THIS WON'T WORK + try { + Botan::TLS::Channel* channel = (Botan::TLS::Channel*) tls_channel; + // printf("Before send channel=%p \n", channel); + channel->send( (const unsigned char*) data, length); + // printf("After send channel=%p \n", channel); + } catch (...) + { + printf("BotanTLS engine raised exception on send\n"); + } +} + + +extern "C" void iocba_close( + void* tls_channel + ) +{ + Botan::TLS::Channel* channel = (Botan::TLS::Channel*) tls_channel; + try{ + channel->close(); + } catch (...) + { + printf("BotanTLS engine raised exception on close\n"); + } +} + + +struct botan_tls_context_t { + second_transfer::HereCredentialsManager credentials_manager; + Botan::TLS::Session_Manager_In_Memory* session_manager; + Botan::AutoSeeded_RNG* rng; + std::vector protocols; + second_transfer::HereTLSPolicy here_tls_policty; +}; + +extern "C" botan_tls_context_t* iocba_make_tls_context( + const char* cert_filename, + const char* privkey_filename + ) +{ + Botan::AutoSeeded_RNG* rng=new Botan::AutoSeeded_RNG(); + std::vector< std::string > protocols; + + // Not sure what is this good for.... + protocols.push_back("h2"); + protocols.push_back("http/1.1"); + + return new botan_tls_context_t{ + second_transfer::HereCredentialsManager(cert_filename, privkey_filename, *rng), + new Botan::TLS::Session_Manager_In_Memory(*rng), + rng, + protocols, + second_transfer::HereTLSPolicy() + }; +} + +// Oh Gods, forgive me +pthread_mutex_t new_ctx_mutex = PTHREAD_MUTEX_INITIALIZER ; +pthread_mutex_t new_channel_mutex = PTHREAD_MUTEX_INITIALIZER ; + +extern "C" botan_tls_context_t* iocba_make_tls_context_from_memory( + const uint8_t* cert_data, + uint32_t cert_data_length, + const uint8_t* key_data, + uint32_t key_data_length +) +{ + // printf("New tls context from memory\n"); + pthread_mutex_lock(&new_ctx_mutex); + Botan::AutoSeeded_RNG* rng=new Botan::AutoSeeded_RNG(); + std::vector< std::string > protocols; + + // Not sure what is this good for.... + protocols.push_back("h2"); + protocols.push_back("http/1.1"); + + botan_tls_context_t* result = new botan_tls_context_t{ + second_transfer::HereCredentialsManager( + cert_data, + cert_data_length, + key_data, + key_data_length, + *rng), + new Botan::TLS::Session_Manager_In_Memory(*rng), + rng, + protocols, + second_transfer::HereTLSPolicy() + }; + pthread_mutex_unlock(&new_ctx_mutex); + return result; +} + + +extern "C" void iocba_delete_tls_context(botan_tls_context_t* ctx) +{ + delete ctx->session_manager; + delete ctx->rng; + delete ctx; +} + + +extern "C" void* iocba_new_tls_server_channel ( + void* botan_pad_ref, + botan_tls_context_t* ctx) +{ + //printf("New tls server channel\n"); + pthread_mutex_lock(&new_channel_mutex); + auto* server = + new Botan::TLS::Server( + std::bind(second_transfer::output_dn_cb, botan_pad_ref, std::placeholders::_1, std::placeholders::_2), + std::bind(second_transfer::data_cb, botan_pad_ref, std::placeholders::_1, std::placeholders::_2), + std::bind(second_transfer::alert_cb, botan_pad_ref, std::placeholders::_1, std::placeholders::_2, std::placeholders::_3), + std::bind(second_transfer::handshake_cb, botan_pad_ref, std::placeholders::_1), + *(ctx->session_manager), + ctx->credentials_manager, + ctx->here_tls_policty, + *(ctx->rng), + std::bind(second_transfer::defaultProtocolSelector, botan_pad_ref, std::placeholders::_1) + ); + pthread_mutex_unlock(&new_channel_mutex); + return server; +} + +extern "C" void iocba_delete_tls_server_channel ( + Botan::TLS::Server * srv + ) +{ + delete srv; +} diff --git a/cbits/tlsinc.c b/cbits/tlsinc.c deleted file mode 100644 --- a/cbits/tlsinc.c +++ /dev/null @@ -1,935 +0,0 @@ - -#define _BSD_SOURCE 1 -#define _XOPEN_SOURCE 1 /* or any value < 500 */ -#define _POSIX_C_SOURCE 1 - - - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - - -#include -#include -#include - - -// - - -// Some constants -#define ALL_OK 0 -#define BAD_HAPPENED 1 -#define TIMEOUT_REACHED 3 -// This is also a failed IO with SSL, but this one may be quite -// natural and we want to handle it differently -#define TRANSPORT_CLOSED 2 - - -#if OPENSSL_VERSION_NUMBER < 0x1000200fL -#define ALPN_DISABLED -#warning Due to low OpenSSL version, this build is completely broken. Check second-transfer.cabal to see how -#warning to indicate a recent OpenSSL version. - -int SSL_CTX_set_ecdh_auto(SSL *s, int onoff) -{ - fprintf(stderr, "Fake OPENSSL function called. Updated your SSL version!!\n"); -} - -void SSL_CTX_set_alpn_select_cb(SSL_CTX *ctx, - int (*cb) (SSL *ssl, - const unsigned char **out, - unsigned char *outlen, - const unsigned char *in, - unsigned int inlen, - void *arg), - void *arg) -{ - fprintf(stderr, "Fake OPENSSL function called. Updated your SSL version!!\n"); -} - - -void SSL_get0_alpn_selected(SSL*a , int*b, int*c) -{ - fprintf(stderr, "Fake OPENSSL function called. Updated your SSL version!!\n"); -} - -#endif - - -// Simple structure to keep track of the handle, and -// of what needs to be freed later. -typedef struct { - int socket; - SSL_CTX *sslContext; - char* protocol_list; - int protocol_list_length; -} connection_t; - -// Simple structure representing a session here -typedef struct { - int socket; - SSL *sslHandle; - // Protocol index selected during negotiation.... - int protocol_index; -} wired_session_t; - -// This is the public API of this server... -// No arguments, all are wired here somewhere... for now -connection_t* make_connection(); -// Call when you are done -void close_connection(connection_t* conn); -// Wait for the next one... - -int wait_for_connection(connection_t* conn, int microseconds, wired_session_t** wired_session); -int send_data(wired_session_t* ws, char* buffer, int buffer_size); -int recv_data(wired_session_t* ws, char* inbuffer, int buffer_size, int* data_recvd); -int recv_data_best_effort(wired_session_t* ws, char* inbuffer, int buffer_size, int can_wait, int* data_recvd); -int get_selected_protocol(wired_session_t* ws){ return ws->protocol_index; } -void dispose_wired_session(wired_session_t* ws); -static int thread_setup(void); - -// Preprocessor flag: when 1, we will trace ALPN info -#define TRACE_ALPN_NEGOTIATION 0 - - -//////////////////////////////////////////////////////////////////////// - - -static int threads_are_up = 0; - -// Leaky implementation now -void close_connection(connection_t* conn) -{ - if (conn->socket) - { - close (conn->socket); - conn->socket = 0; - } - - if (conn->sslContext) - { - SSL_CTX_free(conn->sslContext); - conn->sslContext = 0; - } - - free(conn); -} - -// For this example, we'll be testing on openssl.org - - -// Establish a regular tcp connection -static int tcpStart (char* hostname, int portno, int* errorh) -{ - int error, handle; - *errorh = 0; - struct hostent *host; - struct sockaddr_in server; - - bzero((char *) &server, sizeof(server)); - - - host = gethostbyname (hostname); - handle = socket (AF_INET, SOCK_STREAM, 0); - int one = 1; - setsockopt(handle, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(one)); - - if (handle == -1) - { - perror ("Socket could not be created"); - handle = 0; - *errorh = BAD_HAPPENED; - } - else - { - - int flag = 1; - int result = setsockopt(handle, /* socket affected */ - IPPROTO_TCP, /* set option at TCP level */ - TCP_NODELAY, /* name of option */ - (char *) &flag, /* the cast is historical - cruft */ - sizeof(int)); /* length of option value */ - if (result < 0) - { - perror("Couldn't set TCP_NODELAY"); - handle = 0; - *errorh = BAD_HAPPENED; - } else - { - server.sin_family = AF_INET; - server.sin_port = htons (portno); - server.sin_addr = *((struct in_addr *) host->h_addr); - bzero (&(server.sin_zero), 8); - - error = bind (handle, (struct sockaddr *) &server, - sizeof (struct sockaddr)); - if (error == -1) - { - perror ("Bind"); - handle = 0; - *errorh = BAD_HAPPENED; - } - else - { - error = listen(handle, 5); - if ( error != 0 ) - { - perror("Listen"); - handle = 0; - *errorh = BAD_HAPPENED; - } - } - } - - } - - return handle; -} - -// Dh_Callback {{{ -#ifndef HEADER_DH_H -#include -#endif -DH *get_dh2236() -{ - static unsigned char dh2236_p[]={ - 0x08,0x32,0x3B,0x6A,0xE8,0xEA,0x55,0xE3,0x0C,0xD9,0x95,0x3D, - 0xE7,0x78,0xDA,0xF0,0x05,0x81,0x94,0x85,0x34,0x5C,0x26,0x5A, - 0xAE,0x9E,0x31,0x8F,0x0C,0xCC,0xFC,0xF3,0x30,0x88,0x20,0x0B, - 0x41,0xC3,0xC9,0xEC,0x13,0xA7,0xFF,0xDA,0xBB,0x11,0xFB,0x7B, - 0x19,0x92,0x3B,0x61,0xDF,0x31,0xEF,0x2C,0x4A,0x5C,0xD1,0x59, - 0x16,0x90,0xAC,0xFC,0xEA,0xFF,0xCB,0xC4,0x04,0x07,0x93,0x9D, - 0xF0,0x70,0x0B,0xCB,0x3E,0x79,0x0D,0xEB,0xD3,0x3E,0x06,0x0B, - 0x19,0xF2,0x97,0x1E,0xE1,0xBF,0xD2,0xBE,0x5E,0xA5,0xBD,0x5F, - 0x73,0x2C,0x57,0x0C,0xB0,0x97,0x78,0xAA,0x60,0xDC,0x98,0x89, - 0xAF,0xBF,0xCD,0x49,0x74,0x82,0x64,0x09,0x60,0x47,0xD0,0xD4, - 0x5D,0x25,0xDC,0x38,0xAC,0x17,0xE7,0xA4,0x47,0x59,0x94,0xFE, - 0xA8,0xAD,0x58,0xD0,0xD1,0x43,0x3C,0x20,0x2E,0x34,0xEE,0xA9, - 0x0F,0x71,0x20,0x93,0xB7,0x8E,0xEC,0xB1,0x75,0xB9,0xE9,0x9A, - 0xAB,0x73,0xBB,0x7F,0xA2,0x8F,0x11,0xDE,0x58,0x5E,0xB0,0x98, - 0xD6,0x95,0x84,0x62,0x90,0x87,0x90,0x32,0x34,0xF7,0x61,0x28, - 0xFF,0x17,0xD0,0x58,0x33,0xA6,0xC2,0xC6,0x58,0x65,0x1C,0x92, - 0xF3,0xDF,0x4D,0xB3,0xB0,0xFD,0xD2,0x4A,0x97,0x1B,0xA7,0xD2, - 0x7C,0x8D,0x8F,0x1F,0x69,0x98,0x54,0xD9,0x33,0x15,0xE5,0xEA, - 0xBA,0xAA,0x31,0xB1,0x17,0x65,0x21,0xFA,0xC7,0x54,0xC0,0xE4, - 0x72,0x3C,0x15,0x74,0x41,0xF2,0x9A,0xF6,0xD1,0x16,0x10,0x35, - 0x4F,0x36,0xA6,0x23,0x67,0x67,0x89,0x65,0xDD,0x77,0x5D,0x8F, - 0x69,0x49,0x22,0x24,0xB6,0xB8,0x45,0xCA,0x8F,0x35,0x71,0x45, - 0x4C,0x65,0x38,0x11,0x21,0xD5,0x39,0x03,0x4D,0x05,0xBB,0x95, - 0x43,0x58,0xBB,0xF3, - }; - static unsigned char dh2236_g[]={ - 0x02, - }; - DH *dh; - - if ((dh=DH_new()) == NULL) return(NULL); - dh->p=BN_bin2bn(dh2236_p,sizeof(dh2236_p),NULL); - dh->g=BN_bin2bn(dh2236_g,sizeof(dh2236_g),NULL); - if ((dh->p == NULL) || (dh->g == NULL)) - { DH_free(dh); return(NULL); } - return(dh); -} -DH *get_dh2048() -{ - static unsigned char dh2048_p[]={ - 0xCE,0x28,0x14,0x1C,0xEF,0x22,0x1D,0x86,0xEA,0x10,0x00,0x50, - 0x24,0x42,0x95,0xC3,0x07,0x5A,0x87,0xED,0x0F,0xC5,0xDC,0x0F, - 0x5E,0x7E,0x69,0x25,0x85,0x90,0x39,0x60,0x1E,0x87,0x5C,0x4B, - 0xAD,0xDF,0xA8,0xF4,0x9C,0xC6,0x2D,0x6A,0x2E,0x7C,0xD1,0x5C, - 0xC5,0x1A,0x74,0xD3,0x9E,0xE1,0xBB,0x31,0xC4,0x23,0x2F,0x78, - 0xF5,0x61,0x5C,0x09,0x7E,0x29,0x06,0xC5,0x07,0x50,0x32,0x80, - 0x4A,0xBE,0x5F,0x7F,0x68,0x69,0x8F,0xB1,0x6D,0xA0,0x0C,0x7F, - 0x9E,0x28,0x77,0x9D,0x4F,0xEA,0xB5,0x38,0xB3,0x72,0x8E,0x1D, - 0x8D,0x1C,0x58,0x74,0x58,0xC4,0xDD,0x06,0x8E,0x80,0x91,0x36, - 0x2D,0x42,0x3D,0xF0,0x11,0xEC,0xDF,0x02,0xFD,0x84,0x54,0x32, - 0x90,0xFE,0x7C,0x74,0x3A,0x5F,0x87,0xBA,0xD3,0x21,0x0E,0xDD, - 0xF4,0xB3,0xFD,0xF9,0x89,0x8F,0x96,0x59,0x90,0x74,0xE8,0x45, - 0x5A,0x3A,0x7C,0x88,0x7F,0xD8,0x5F,0xD2,0x32,0x57,0x46,0x29, - 0x6B,0xA1,0x0A,0x05,0x1E,0xB6,0x49,0x8A,0x68,0xB4,0xEE,0x84, - 0x45,0xEF,0x56,0x7E,0x59,0x83,0x67,0x20,0x85,0x63,0x69,0x6B, - 0x39,0xCA,0x24,0x46,0x68,0x51,0x94,0x9E,0x3E,0xB4,0x69,0x1F, - 0x63,0x07,0x40,0x0E,0x84,0x8B,0x26,0x98,0xCE,0xE5,0x48,0x2C, - 0xD8,0xF9,0x6A,0x3F,0x20,0xFA,0xFA,0xDC,0x4E,0xFA,0xBD,0xC3, - 0x81,0x09,0x4D,0xCF,0x07,0xEF,0xE8,0x32,0x9B,0x63,0x32,0x5B, - 0x06,0x59,0x4F,0xE7,0x5B,0xD2,0xFC,0x25,0xC6,0x2C,0xA3,0xE8, - 0x05,0xE5,0x8D,0xC2,0x94,0x76,0x90,0x63,0x29,0xB4,0xEE,0x2D, - 0xD6,0x50,0x83,0x8B, - }; - static unsigned char dh2048_g[]={ - 0x02, - }; - DH *dh; - - if ((dh=DH_new()) == NULL) return(NULL); - dh->p=BN_bin2bn(dh2048_p,sizeof(dh2048_p),NULL); - dh->g=BN_bin2bn(dh2048_g,sizeof(dh2048_g),NULL); - if ((dh->p == NULL) || (dh->g == NULL)) - { DH_free(dh); return(NULL); } - return(dh); -} - -DH *get_dh1024() -{ - static unsigned char dh1024_p[]={ - 0x87,0xF4,0xE5,0x5A,0x1E,0x7F,0x98,0x83,0xFD,0x23,0x6A,0xF3, - 0x8C,0xE8,0x2F,0x35,0x64,0x3D,0x13,0x34,0x5B,0x0A,0x52,0xEC, - 0x0B,0x3A,0xBF,0x92,0xE4,0x67,0x14,0x47,0x86,0x55,0x2C,0x83, - 0x1B,0xDD,0x0E,0xC8,0x2D,0x98,0x72,0x2A,0xB6,0x68,0xF1,0x32, - 0xD8,0xBD,0x6B,0x17,0x23,0x46,0x08,0xB6,0x19,0x58,0x01,0x30, - 0x32,0x68,0x60,0x78,0xD1,0x5B,0x5C,0x88,0x3F,0x20,0xD7,0xEB, - 0xE8,0xD5,0x80,0xB0,0x23,0x75,0xAE,0x97,0x26,0xBD,0xA5,0x11, - 0x7F,0x83,0x8C,0x21,0xD4,0x39,0x52,0xE0,0x25,0x1F,0x03,0xA9, - 0x69,0xF8,0x07,0x4F,0x33,0x17,0x72,0xCC,0xEB,0xBD,0x77,0xD1, - 0x9C,0x40,0xA6,0x55,0xE3,0x87,0x76,0x66,0x3B,0xE3,0xE4,0x6A, - 0x4B,0x6B,0xF1,0x92,0x1A,0x3A,0x25,0xC3, - }; - static unsigned char dh1024_g[]={ - 0x02, - }; - DH *dh; - - if ((dh=DH_new()) == NULL) return(NULL); - dh->p=BN_bin2bn(dh1024_p,sizeof(dh1024_p),NULL); - dh->g=BN_bin2bn(dh1024_g,sizeof(dh1024_g),NULL); - if ((dh->p == NULL) || (dh->g == NULL)) - { DH_free(dh); return(NULL); } - return (dh); -} - - -static DH *tmp_dh_callback(SSL *s, int is_export, int keylength); - - -// Setup dh params -static void setup_dh_parms(SSL_CTX *sslContext) -{ - /* Set up ephemeral DH stuff */ - SSL_CTX_set_tmp_dh_callback(sslContext, tmp_dh_callback); -} - -static DH *tmp_dh_callback(SSL *s, int is_export, int keylength) -{ - static DH *dh_2048 = NULL; - static DH *dh_1024 = NULL; - DH *dh_tmp=NULL; - switch (keylength) { - case 2048: - if (!dh_2048) - dh_2048 = get_dh2048(); - dh_tmp = dh_2048; - break; - case 1024: - if (!dh_1024) - dh_1024 = get_dh1024(); - dh_tmp = dh_1024; - break; - default: - /* Generating a key on the fly is very costly, so use what is there */ - printf("UNEXPECTED: Keylength %d \n", keylength); - } - return(dh_tmp); -} -// dh_callback }}} - - - -static int protocol_select ( - SSL *ssl, - const unsigned char **out, - unsigned char *outlen, - const unsigned char *in, - unsigned int inlen, - void *arg) -{ - // Oh well, C is a verbose beast - connection_t* conn = (connection_t*) arg; - static char output[64]; - - -#if TRACE_ALPN_NEGOTIATION - printf("protocol check starts, offered %d bytes for protocols ^^^^^^^^^^^^^ \n", inlen); - int first_run = 1; -#endif - char* stored_cursor = conn->protocol_list; - - while( stored_cursor < conn->protocol_list + conn->protocol_list_length) - { - char* incursor = (char*) in; - int sto_protocol = 0; - char sublen2 = *stored_cursor; - - while (incursor < (char*)in + inlen ) - { - // Got a protocol.... can I satisfy it? - char sublen = *incursor; - -#if TRACE_ALPN_NEGOTIATION - if (first_run) - printf("offered prot %.*s \n", sublen, incursor+1); -#endif - - if (sublen != sublen2) - { - // No match, just continue - } else { - int cmpresult = strncmp( incursor + 1, stored_cursor + 1, sublen); - if (cmpresult == 0) - { - // They are equal, choose this one... - strncpy( output, stored_cursor+1, sublen); - *outlen = sublen; - *out = (unsigned char*)output; -#if TRACE_ALPN_NEGOTIATION - printf("protocol check ends by match vvvvvvvvvvv \n"); -#endif - return SSL_TLSEXT_ERR_OK; - } - } - - incursor += (1+sublen); - } - -#if TRACE_ALPN_NEGOTIATION - first_run = 0; -#endif - - sto_protocol += 1; - stored_cursor += (1+sublen2); - - } - -#if TRACE_ALPN_NEGOTIATION - printf("protocol check ends without match vvvvvvvvvvv \n"); -#endif - // I think this is what should be returned - return -1; -} - - -int lookup_protocol( - char* selected, int selected_len, - char* myprotocol_list, int mpl_len - ) -{ - char* incursor = selected; - - char* stored_cursor = myprotocol_list; - int sto_protocol = 0; - - if (selected_len == 0) - { - // No protocol was selected - return -2; - } - - while( stored_cursor < myprotocol_list + mpl_len) - { - char sublen2 = *stored_cursor; - - if (sublen2 != selected_len) - { - // It is not this cone, continue - } else { - int cmpresult = strncmp( selected, stored_cursor + 1, sublen2); - if (cmpresult == 0) - { - // They are equal, choose this one... - return sto_protocol; - } - } - sto_protocol += 1; - stored_cursor += (1+sublen2); - } - - // I think this is what should be returned - return -1; -} - -static int ssl_servername_cb(SSL *s, int *ad, void *arg) -{ - // TODO: Use this for something .... although I'm not sure what... - - // tlsextctx *p = (tlsextctx *) arg; - // const char *servername = SSL_get_servername(s, TLSEXT_NAMETYPE_host_name); - // if (servername && p->biodebug) - // BIO_printf(p->biodebug, "Hostname in TLS extension: \"%s\"\n", - // servername); - - // if (!p->servername) - // return SSL_TLSEXT_ERR_NOACK; - - // if (servername) { - // if (strcasecmp(servername, p->servername)) - // return p->extension_error; - // if (ctx2) { - // BIO_printf(p->biodebug, "Switching server context.\n"); - // SSL_set_SSL_CTX(s, ctx2); - // } - // } - return SSL_TLSEXT_ERR_OK; -} - - -// Establish a connection using an SSL layer -static connection_t *sslStart ( - char* certificate_filename, char* privkey_filename, char* hostname, int portno, - char* protocol_list, int protocol_list_length - ) -{ - int result; - connection_t *c; - - // Ok, here it is in the open, for everybody - // to see: - signal(SIGPIPE, SIG_IGN); - - if (! threads_are_up) - { - threads_are_up = 1; - thread_setup(); - } - - c = malloc (sizeof (connection_t)); - c->sslContext = NULL; - c->protocol_list = (char*) malloc(protocol_list_length); - strncpy( c->protocol_list, protocol_list, protocol_list_length ); - c->protocol_list_length = protocol_list_length; - c->socket = tcpStart (hostname, portno, &result); - - if ( result ) - { - return 0; - } - - if (c->socket) - { - // Register the error strings for libcrypto & libssl - SSL_load_error_strings (); - // Register the available ciphers and digests - SSL_library_init (); - - // New context saying we are a server, and using SSL 2 or 3 - c->sslContext = SSL_CTX_new( TLSv1_2_server_method() ); - if (c->sslContext == NULL) - { - ERR_print_errors_fp (stderr); - perror("Could not create context"); - return 0; - } - - - // Now I set a few options.... - /*SSL_CTX_set_verify(c->sslContext, NULL );*/ - const long flags = - SSL_OP_NO_SSLv2 | SSL_OP_NO_SSLv3 | SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION; - // const long flags = - // SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION | SSL_OP_NO_COMPRESSION; - SSL_CTX_set_options(c->sslContext, flags); - setup_dh_parms( c->sslContext ); - SSL_CTX_set_ecdh_auto (c->sslContext, 1); - - // Give the impression that we are using SNI - SSL_CTX_set_tlsext_servername_callback(c->sslContext, ssl_servername_cb); - - // Disable the session cache - SSL_CTX_set_session_cache_mode(c->sslContext, SSL_SESS_CACHE_OFF); - - - // The only cipher supported by HTTP/2 ... sort of. - result = SSL_CTX_set_cipher_list(c->sslContext, - "ECDHE-RSA-AES128-GCM-SHA256" // -- ibidem - ":ECDHE-RSA-AES256-GCM-SHA384" // <-- Good for Chrome and firefox - // ---- These suites will fail HTTP/2 - ":ECDHE-RSA-AES128-SHA256" // -- Not good for HTTP/2 - ":ECDHE-RSA-AES-128-CBC-SHA256" - ":ECDHE-ECDSA-AES256-SHA384" - ); - /*result = SSL_CTX_set_cipher_list(c->sslContext, "DEFAULT");*/ - - // Be sure we are able to do ALPN - // void SSL_CTX_set_alpn_select_cb(SSL_CTX *ctx, - // int (*cb) (SSL *ssl, - // const unsigned char **out, - // unsigned char *outlen, - // const unsigned char *in, - // unsigned int inlen, - // void *arg), void *arg); - SSL_CTX_set_alpn_select_cb( c->sslContext, protocol_select, c); - - if ( result != 1 ) - { - ERR_print_errors_fp (stderr); - perror("Could not set cipher"); - return 0; - } - // Load a certificate in .pem format. - SSL_CTX_use_certificate_chain_file(c->sslContext, certificate_filename); - SSL_CTX_use_PrivateKey_file(c->sslContext, privkey_filename, SSL_FILETYPE_PEM); - // Check the private key - result = SSL_CTX_check_private_key(c->sslContext); - if ( result != 1) - { - char msg[600]; - snprintf(msg, 600, "Check certificate file %s and privkey %s failed", certificate_filename, - privkey_filename); - perror(msg); - return 0; - } - // ////////////////////////////////////////// - - } - else - { - perror ("Connect failed"); - } - - return c; -} - - -connection_t* make_connection(char* certificate_filename, char* privkey_filename, char* hostname, int portno, - char* my_protocol_list, int protocol_list_length - ) -{ - const int len = strlen(hostname); - if ( len > 0 && hostname[len-1] == '\n' ) - { - printf("HELLO THERE. I found some weird characters\n"); - *( (int*) 0) = 42; // <-- This is the answer - } - - - return sslStart( - certificate_filename, privkey_filename, hostname, - portno, my_protocol_list, protocol_list_length); -} - -int wait_for_connection( - connection_t* c, - int microseconds, - wired_session_t** wired_session) -{ - int clilen, newsockfd; - // Don't return anything if there's a failure... - *wired_session = 0; - - // Wait for a connection - struct sockaddr_in cli_addr; - clilen = sizeof(cli_addr); - - // Use select to get "interruptible" accepts - fd_set rfds; - - int can_go = 0; - - while( ! can_go ) - { - FD_ZERO(&rfds); - FD_SET(c->socket, &rfds); - struct timeval tv; - tv.tv_sec = microseconds / 1000000; - tv.tv_usec = microseconds % 1000000; - - - int retval = select(FD_SETSIZE, &rfds, NULL, NULL, &tv); - - - if ( retval == -1 ) - { - if ( errno == EINTR ) - { - // printf("."); - // I get a lot of these signals due to the fact of the - // Haskell runtime having its own use for signals. - return TIMEOUT_REACHED; - } else { - perror("select()"); - return BAD_HAPPENED; - } - } else if (retval > 0) - { - // We got data, just let it go... - // printf("letitgo\n"); - can_go = 1; - } else - { - // We didn't get data, finish and terminate - // printf("timeo\n"); - return TIMEOUT_REACHED; - } - - } - - wired_session_t* result = (wired_session_t*) malloc(sizeof(wired_session_t) ); - if ( result == 0 ) - { - perror("Malloc failed"); - return BAD_HAPPENED; - } - - /* Accept actual connection from the client */ - newsockfd = accept(c->socket, (struct sockaddr *)&cli_addr, &clilen); - - if (newsockfd < 0) - { - perror("ERROR on accept"); - return BAD_HAPPENED; - } - - int flag = 1; - int nresult = setsockopt(newsockfd, /* socket affected */ - IPPROTO_TCP, /* set option at TCP level */ - TCP_NODELAY, /* name of option */ - (char *) &flag, /* the cast is historical - cruft */ - sizeof(int)); /* length of option value */ - if ( nresult < 0) - { - perror("Couldn't set TCP_NODELAY"); - return BAD_HAPPENED; - } - - // Create an SSL struct for the connection - - result->socket = newsockfd; - result->sslHandle = SSL_new (c->sslContext); - if (result->sslHandle == NULL) - { - perror("No handle on SSL new"); - ERR_print_errors_fp (stderr); - return BAD_HAPPENED; - } - - // Connect the SSL struct to our connection - if (!SSL_set_fd (result->sslHandle, result->socket)) - { - perror("Could not associate"); - ERR_print_errors_fp (stderr); - return BAD_HAPPENED; - } - - // Initiate SSL handshake - if (SSL_accept (result->sslHandle) != 1) - { - perror("Could not accept"); - ERR_print_errors_fp (stderr); - return BAD_HAPPENED; - } - - // After this one is okej, see which protocol was selected - const unsigned char* out_protocol; unsigned pr_len; - SSL_get0_alpn_selected(result->sslHandle, &out_protocol, - &pr_len); - // Wonder who is in charge of releasing that buffer... - result -> protocol_index = lookup_protocol( - (char*)out_protocol, pr_len, - c->protocol_list, c->protocol_list_length); - - *wired_session = result; - - return ALL_OK; -} - -// Disconnect & free connection struct -/*static void sslDisconnect (connection *c)*/ -/*{*/ -/*if (c->socket)*/ -/*close (c->socket);*/ -/*if (c->sslHandle)*/ -/*{*/ -/*SSL_shutdown (c->sslHandle);*/ -/*SSL_free (c->sslHandle);*/ -/*}*/ -/*if (c->sslContext)*/ -/*SSL_CTX_free (c->sslContext);*/ - -/*free (c);*/ -/*}*/ - - -int send_data(wired_session_t* ws, char* buffer, int buffer_size) -{ - if ( buffer_size == 0 ) - { - return ALL_OK; - } - if (ws) - { - int result = SSL_write( ws->sslHandle, buffer, buffer_size); - if ( result > 0 ) - { - return ALL_OK; - } else { - return BAD_HAPPENED; - } - } else - { - return BAD_HAPPENED; - } -} - -// Now this function does a very good effort to get as much data as requested, and it -// doesn't return until then. That works well for HTTP/2 sessions which are almost -// never closed naturally. It is however more tricky for EOF cases.... -int recv_data(wired_session_t* ws, char* inbuffer, int buffer_size, int* data_recvd) -{ - int received=0, count = 0; - - // printf("Recvd entered\n"); - - while ( count < buffer_size ) - { - if (ws) - { - received = SSL_read (ws->sslHandle, inbuffer+count, buffer_size - count ); - } - if ( received <= 0 ) - { - ERR_print_errors_fp (stderr); - return BAD_HAPPENED; - } else - { - // Continue reading - count += received ; - } - } - - // printf("Recvd exited\n"); - *data_recvd=count ; - return ALL_OK; -} - - -int recv_data_best_effort(wired_session_t* ws, char* inbuffer, int buffer_size, int can_wait, int* data_recvd) -{ - int received=0, count = 0; - - if (ws && ( can_wait || SSL_pending(ws->sslHandle) ) ) - { - received = SSL_read (ws->sslHandle, inbuffer+count, buffer_size - count ); - } - if ( received <= 0 ) - { - ERR_print_errors_fp (stderr); - return BAD_HAPPENED; - } else - { - // Continue reading - count += received ; - } - - *data_recvd=count ; - return ALL_OK; -} - - -#define MUTEX_TYPE pthread_mutex_t -#define MUTEX_SETUP(x) pthread_mutex_init(&(x), NULL) -#define MUTEX_CLEANUP(x) pthread_mutex_destroy(&(x)) -#define MUTEX_LOCK(x) pthread_mutex_lock(&(x)) -#define MUTEX_UNLOCK(x) pthread_mutex_unlock(&(x)) -#define THREAD_ID pthread_self( ) - - -void handle_error(const char *file, int lineno, const char *msg){ - fprintf(stderr, "** %s:%d %s\n", file, lineno, msg); - ERR_print_errors_fp(stderr); - /* exit(-1); */ -} - -/* This array will store all of the mutexes available to OpenSSL. */ -static MUTEX_TYPE *mutex_buf= NULL; - - -static void locking_function(int mode, int n, const char * file, int line) -{ - if (mode & CRYPTO_LOCK) - MUTEX_LOCK(mutex_buf[n]); - else - MUTEX_UNLOCK(mutex_buf[n]); -} - -static unsigned long id_function(void) -{ - return ((unsigned long)THREAD_ID); -} - -void dispose_wired_session(wired_session_t* ws) -{ - if (ws == 0) - return ; - - if ( ws-> sslHandle ) - { - int rr = SSL_shutdown( ws->sslHandle ); - // printf("rr=%d\n", rr); - int err = SSL_get_error(ws->sslHandle, rr); - if ( err < 0) - { - if ( err == SSL_ERROR_WANT_READ || err == SSL_ERROR_WANT_WRITE ) - { - printf("error when closing socket / wait-for-data\n"); - } else if (err != 0 ){ - printf("cause openssl error code %d \n",err); - } - } - } - - SSL_free(ws->sslHandle); - ws -> sslHandle = 0; - if (ws->socket) - { - close(ws->socket); - ws -> socket = 0; - } - - free(ws); -} - - -int thread_setup(void) -{ - int i; - - // printf("Threads setup\n"); - - mutex_buf = malloc(CRYPTO_num_locks( ) * sizeof(MUTEX_TYPE)); - if (!mutex_buf) - return 0; - for (i = 0; i < CRYPTO_num_locks( ); i++) - MUTEX_SETUP(mutex_buf[i]); - CRYPTO_set_id_callback(id_function); - CRYPTO_set_locking_callback(locking_function); - return 1; -} - -int thread_cleanup(void) -{ - int i; - - if (!mutex_buf) - return 0; - CRYPTO_set_id_callback(NULL); - CRYPTO_set_locking_callback(NULL); - for (i = 0; i < CRYPTO_num_locks( ); i++) - MUTEX_CLEANUP(mutex_buf[i]); - free(mutex_buf); - mutex_buf = NULL; - return 1; -} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,23 @@ + +- 0.10.0.0 : + * The AwareWorker interface was modified to include prompt resource + termination. That is, AwareWorkers can register finalizers for critical + resources now. But this breaks backward compatibility. + * The internals pipe architecture was overhauled to have even less + unbounded chans and more MVar(s) acting as channels. This should result + in better behaviour regarding memory consumption. + +- 0.9.0.0 : + * New tidal session manager to keep the number of connections + that clients make in check. + * Added support for loading certs from memory. + * HTTP/1.1 supports chunked transfer-encodings now + * Mac build works + +- 0.8.0.0 : + * All threads exceptions are reported + * Reverse proxy functionality from HTTP/2 to HTTP/1.1 + - 0.7.1.0 : * A few important memory leaks got fixed * Changed I/O interface to live in IOCallbacks diff --git a/hs-src/SecondTransfer.hs b/hs-src/SecondTransfer.hs --- a/hs-src/SecondTransfer.hs +++ b/hs-src/SecondTransfer.hs @@ -159,32 +159,19 @@ , FinalizationHeaders -- ** How to couple bidirectional data channels to sessions - ,Attendant - ,http11Attendant - ,http2Attendant - ,coherentToAwareWorker + , Attendant + , http11Attendant + , http2Attendant + , coherentToAwareWorker -#ifndef DISABLE_OPENSSL_TLS -- * High level OpenSSL functions. -- -- | Use these functions to create your TLS-compliant -- HTTP/2 server in a snap. - ,tlsServeWithALPN - ,tlsServeWithALPNAndFinishOnRequest - - ,TLSLayerGenericProblem(..) - ,FinishRequest(..) -#endif -- DISABLE_OPENSSL_TLS + , tlsServeWithALPN + , botanTLS - ,dropIncomingData - -- * Logging - -- - -- | The library uses hslogger for its logging. Since logging is - -- expensive, most of the instrumentation needs to be activated - -- at compile time by activating the "debug" flag. And then you - -- need to configure the loggers. The function `enableConsoleLogging` - -- configures them to output a lot of information to standard output. - ,enableConsoleLogging + , dropIncomingData ) where import SecondTransfer.Http1 (http11Attendant) @@ -192,4 +179,5 @@ import SecondTransfer.MainLoop import SecondTransfer.MainLoop.CoherentWorker import SecondTransfer.Types +import SecondTransfer.TLS.Botan (botanTLS) import SecondTransfer.Utils.DevNull (dropIncomingData) diff --git a/hs-src/SecondTransfer/ConstantsAndLimits.hs b/hs-src/SecondTransfer/ConstantsAndLimits.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/ConstantsAndLimits.hs @@ -0,0 +1,8 @@ +module SecondTransfer.ConstantsAndLimits ( + maxUrlLength + ) where + + +-- To be reviewed in the future +maxUrlLength :: Int +maxUrlLength = 4096 diff --git a/hs-src/SecondTransfer/Exception.hs b/hs-src/SecondTransfer/Exception.hs --- a/hs-src/SecondTransfer/Exception.hs +++ b/hs-src/SecondTransfer/Exception.hs @@ -1,34 +1,51 @@ -{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, ScopedTypeVariables #-} {-| Module : SecondTransfer.Exception -} module SecondTransfer.Exception ( -- * Exceptions thrown by the HTTP/2 sessions - HTTP2SessionException (..) - ,FramerException (..) - ,BadPrefaceException (..) - ,HTTP11Exception (..) - ,HTTP11SyntaxException (..) - ,ClientSessionAbortedException(..) - ,HTTP500PrecursorException (..) - ,ConnectionCloseReason(..) - ,convertHTTP500PrecursorExceptionToException - ,getHTTP500PrecursorExceptionFromException - ,ContentLengthMissingException (..) + HTTP2SessionException (..) + , FramerException (..) + , BadPrefaceException (..) + , HTTP11Exception (..) + , HTTP11SyntaxException (..) + , ClientSessionAbortedException (..) + , HTTP500PrecursorException (..) + , GatewayAbortedException (..) + , ConnectionCloseReason (..) + , convertHTTP500PrecursorExceptionToException + , getHTTP500PrecursorExceptionFromException + , ContentLengthMissingException (..) - -- * Exceptions related to the IO layer - ,IOProblem(..) - ,GenericIOProblem(..) - ,StreamCancelledException(..) + -- * Exceptions related to the IO layer + , IOProblem (..) + , GenericIOProblem (..) + , StreamCancelledException (..) + , NoMoreDataException (..) + -- * Exceptions related to SOCKS5 + , SOCKS5ProtocolException (..) - -- * Internal exceptions - ,HTTP2ProtocolException(..) + -- * Internal exceptions + , HTTP2ProtocolException (..) + + -- * Utility functions + , ignoreException + , reportExceptions + , keyedReportExceptions + , forkIOExc + + -- * Proxies + , blockedIndefinitelyOnMVar + , noMoreDataException + , ioProblem + , gatewayAbortedException + , ioException ) where import Control.Exception import Data.Typeable - +import Control.Concurrent (forkIO, ThreadId) -- | Abstract exception. All HTTP/2 exceptions derive from here @@ -40,14 +57,17 @@ instance Exception HTTP2SessionException + convertHTTP2SessionExceptionToException :: Exception e => e -> SomeException convertHTTP2SessionExceptionToException = toException . HTTP2SessionException + getHTTP2SessionExceptionFromException :: Exception e => SomeException -> Maybe e getHTTP2SessionExceptionFromException x = do HTTP2SessionException a <- fromException x cast a + -- | Concrete exception. Used internally to signal that the client violated -- the protocol. Clients of the library shall never see this exception. data HTTP2ProtocolException = HTTP2ProtocolException @@ -127,9 +147,12 @@ cast a -- | Abstract exception. It is an error if an exception of this type bubbles --- to this library, but we will do our best to handle it gracefully. +-- to this library, but we will do our best to handle it gracefully in the +-- Session engines. -- All internal error precursors at the workers can thus inherit from here --- to have a fallback option in case they forget to handle the error. +-- to have a fallback option in case they forget to handle the error. It should +-- also be used for the case of streaming requests that are interrupted by the +-- upstream server. -- This exception inherits from HTTP11Exception data HTTP500PrecursorException = forall e . Exception e => HTTP500PrecursorException e deriving Typeable @@ -154,6 +177,17 @@ toException = convertHTTP11ExceptionToException fromException = getHTTP11ExceptionFromException +-- | Used by the ReverseProxy to signal an error from the upstream/Gateway +data GatewayAbortedException = GatewayAbortedException + deriving (Typeable, Show) + +instance Exception GatewayAbortedException where + toException = convertHTTP500PrecursorExceptionToException + fromException = getHTTP11ExceptionFromException + +gatewayAbortedException :: Proxy GatewayAbortedException +gatewayAbortedException = Proxy + -- | Thrown with HTTP/1.1 over HTTP/1.1 sessions when the response body -- or the request body doesn't include a Content-Length header field, -- given that should have included it @@ -164,6 +198,8 @@ toException = convertHTTP11ExceptionToException fromException = getHTTP11ExceptionFromException + +-- Concrete exception data HTTP11SyntaxException = HTTP11SyntaxException String deriving (Typeable, Show) @@ -181,20 +217,35 @@ instance Exception IOProblem +ioProblem :: Proxy IOProblem +ioProblem = Proxy + -- | A concrete case of the above exception. Throw one of this -- if you don't want to implement your own type. Use -- `IOProblem` in catch signatures. data GenericIOProblem = GenericIOProblem deriving (Show, Typeable) - instance Exception GenericIOProblem where toException = toException . IOProblem fromException x = do IOProblem a <- fromException x cast a +-- | This is raised by the IOCallbacks when the endpoint +-- is not willing to return or to accept more data +data NoMoreDataException = NoMoreDataException + deriving (Show, Typeable) +instance Exception NoMoreDataException where + toException = toException . IOProblem + fromException x = do + IOProblem a <- fromException x + cast a + +noMoreDataException :: Proxy NoMoreDataException +noMoreDataException = Proxy + -- | This exception will be raised inside a `CoherentWorker` when the underlying -- stream is cancelled (STREAM_RESET in HTTP\/2). Do any necessary cleanup -- in a handler, or simply use the fact that the exception is asynchronously @@ -205,3 +256,61 @@ deriving (Show, Typeable) instance Exception StreamCancelledException + + +-- | Exception to denote that something failed with the SOCKS5 protocol +data SOCKS5ProtocolException = SOCKS5ProtocolException + deriving (Show, Typeable) + + +instance Exception SOCKS5ProtocolException + + +-- | Simple utility function that ignores an exception. Good to work +-- on threads when we know stuff. It takes as a first parameter a +-- proxy. +ignoreException :: Exception e => Proxy e -> a -> IO a -> IO a +ignoreException prx default_value comp = + let + predicate :: Proxy e -> e -> Maybe () + predicate _prx _ = Just () + in catchJust (predicate prx ) comp (const $ return default_value) + + +-- | Simple utility function that reports exceptions +reportExceptions :: forall a . IO a -> IO a +reportExceptions comp = + do + ei <- try comp + case (ei :: Either SomeException a) of + Left e@(SomeException ee) -> do + putStrLn $ "Bubbling exc " ++ displayException e ++ " (with type " ++ (show $ typeOf ee) ++ ")" + throwIO e + + Right a -> do + return a + + +keyedReportExceptions :: forall a . String -> IO a -> IO a +keyedReportExceptions key comp = + do + ei <- try comp + case (ei :: Either SomeException a) of + Left e@(SomeException ee) -> do + putStrLn $ "Bubbling exc " ++ displayException e ++ " (with type " ++ (show $ typeOf ee) ++ ") at " ++ key + throwIO e + + Right a -> do + return a + +-- | Just report all unhandled and un-ignored exceptions +--- in forked threads +forkIOExc :: String -> IO () -> IO ThreadId +forkIOExc msg comp = forkIO $ keyedReportExceptions msg comp + + +blockedIndefinitelyOnMVar :: Proxy BlockedIndefinitelyOnMVar +blockedIndefinitelyOnMVar = Proxy + +ioException :: Proxy IOException +ioException = Proxy diff --git a/hs-src/SecondTransfer/Http1/Parse.hs b/hs-src/SecondTransfer/Http1/Parse.hs --- a/hs-src/SecondTransfer/Http1/Parse.hs +++ b/hs-src/SecondTransfer/Http1/Parse.hs @@ -9,8 +9,15 @@ ,locateCRLFs ,splitByColon ,stripBs - ,headerListToHTTP11Text + ,headerListToHTTP1RequestText + ,headerListToHTTP1ResponseText ,serializeHTTPResponse + ,methodHasRequestBody + ,methodHasResponseBody + ,chunkParser + ,transferEncodingIsChunked + ,wrapChunk + ,unwrapChunks ,IncrementalHttp1Parser ,Http1ParserCompletion(..) @@ -23,7 +30,10 @@ -- import Control.Lens import qualified Control.Lens as L import Control.Applicative +--import Control.DeepSeq (deepseq) +import Numeric as Nm + import qualified Data.ByteString as B import Data.List (foldl') import qualified Data.ByteString.Builder as Bu @@ -31,29 +41,36 @@ import qualified Data.ByteString.Char8 as Ch8 import qualified Data.ByteString.Lazy as Lb import Data.Char (toLower) -import Data.Maybe (isJust) -#ifndef IMPLICIT_MONOID -import Data.Monoid (mappend, - mempty, - mconcat) -#endif +import Data.Maybe (isJust, fromMaybe) + import qualified Data.Attoparsec.ByteString as Ap +import qualified Data.Attoparsec.ByteString.Char8 as Ap8 import Data.Foldable (find) import Data.Word (Word8) import qualified Data.Map as M +import Data.Conduit +import Text.Read (readEither) + +import qualified Network.URI as U + import qualified SecondTransfer.Utils.HTTPHeaders as E +import qualified SecondTransfer.Utils.HTTPHeaders as He import SecondTransfer.Exception import SecondTransfer.MainLoop.CoherentWorker (Headers) import SecondTransfer.Utils (subByteString) +import qualified SecondTransfer.ConstantsAndLimits as Constant +-- import Debug.Trace + data IncrementalHttp1Parser = IncrementalHttp1Parser { _fullText :: Bu.Builder ,_stateParser :: HeaderParseClosure } + type HeaderParseClosure = (B.ByteString -> ([Int], Int, Word8)) -- L.makeLenses ''IncrementalHttp1Parser @@ -73,28 +90,32 @@ data Http1ParserCompletion = -- | No, not even headers are done. Use the returned -- value to continue - MustContinue_H1PC IncrementalHttp1Parser + MustContinue_H1PC !IncrementalHttp1Parser -- | Headers were completed. For some HTTP methods that's all -- there is, and that's what this case represents. The second - -- argument is a left-overs string. - |OnlyHeaders_H1PC Headers B.ByteString + -- argument is a left-overs string, that should be completed + -- with any other data required + |OnlyHeaders_H1PC !Headers !B.ByteString -- | For requests with a body. The second argument is a condition -- to stop receiving the body, the third is leftovers from -- parsing the headers. - |HeadersAndBody_H1PC Headers BodyStopCondition B.ByteString - -- | Some requests are mal-formed. We can check those cases + |HeadersAndBody_H1PC !Headers !BodyStopCondition !B.ByteString + -- | Some requests are ill-formed. We can check those cases -- here. - |RequestIsMalformed_H1PC + |RequestIsMalformed_H1PC String deriving Show --- | Stop condition when parsing the body. Right now only length --- is supported, given with Content-Length. +-- | Stop condition when parsing the body. +-- Tons and tons of messages in the internet go without a Content-Length +-- header, in those cases there is a long chain of conditions to determine the +-- message length, and at the end of those, there is CloseConnection -- --- TODO: Support "chunked" transfer encoding for classical --- HTTP/1.1, uploads will need it. data BodyStopCondition = - UseBodyLength_BSC Int + UseBodyLength_BSC Int -- ^ There is a content-length header, and a length + | ConnectionClosedByPeer_BSC -- ^ We expect the connection to be closed by the peer when the stream finishes + | Chunked_BSC -- ^ It's a chunked transfer, use the corresponding parser + | SemanticAbort_BSC -- ^ Terrible things have happened, close the connection deriving (Show, Eq) @@ -112,16 +133,48 @@ (positions, length_so_far, last_char ) = header_parse_closure new_bytes new_full_text = full_text `mappend` (Bu.byteString new_bytes) could_finish = twoCRLFsAreConsecutive positions + total_length_now = B.length new_bytes + length_so_far + full_text_lbs = (Bu.toLazyByteString new_full_text) + -- This will only trigger for ill-formed heads, if the head is parsed successfully, this + -- flag will be ignored. + head_is_suspicious = + if total_length_now > 399 then + if total_length_now < Constant.maxUrlLength + then looksSuspicious full_text_lbs + else True + else False in - case could_finish of - Just at_position -> elaborateHeaders new_full_text positions at_position + case (could_finish, head_is_suspicious) of + (Just at_position, _) -> elaborateHeaders new_full_text positions at_position - Nothing -> MustContinue_H1PC + (Nothing, True ) -> RequestIsMalformed_H1PC "Head is suspicious" + + (Nothing, False) -> MustContinue_H1PC $ IncrementalHttp1Parser new_full_text (locateCRLFs length_so_far positions last_char) +-- Look for suspicious patterns in the bs, like tab characters, or \r or \n +-- which are alone +looksSuspicious :: Lb.ByteString -> Bool +looksSuspicious bs = + let + have_weird_characters = isJust $ Lb.find (\w8 -> w8 < 32 && w8 /= 10 && w8 /= 13 ) bs + have_lone_n = let + ei = Lb.elemIndices 13 bs + eii = Lb.elemIndices 10 bs + zp = zip ei eii + f ((i,j):rest) | i+1 == j = f rest + | i == Lb.length bs - 1 = False + | otherwise = True + f [] = False + in f zp || abs ( length ei - length eii) > 1 + result = have_lone_n || have_weird_characters + in result + + +-- This function takes care of retrieving headers.... elaborateHeaders :: Bu.Builder -> [Int] -> Int -> Http1ParserCompletion elaborateHeaders full_text crlf_positions last_headers_position = let @@ -130,19 +183,22 @@ full_headers_text = Lb.toStrict $ Bu.toLazyByteString full_text -- Filter out CRLF pairs corresponding to multiline headers. - no_cont_positions_reverse = filter - (\ pos -> if pos >= last_headers_position then True else - not . isWsCh8 $ - (Ch8.index - full_headers_text - (pos + 2) - ) - ) - crlf_positions + no_cont_positions_reverse = + filter + (\ pos -> if pos == last_headers_position then True else + if pos > last_headers_position then False else + not . isWsCh8 $ + (Ch8.index + full_headers_text + (pos + 2) + ) + ) + crlf_positions - no_cont_positions = reverse . tail $ no_cont_positions_reverse + no_cont_positions = reverse no_cont_positions_reverse -- Now get the headers as slices from the original string. + headers_pre :: [B.ByteString] headers_pre = map (\ (start, stop) -> subByteString start stop full_headers_text @@ -152,32 +208,40 @@ 0 (map ( + 2 ) - no_cont_positions + (init no_cont_positions) ) ) no_cont_positions ) - -- TODO: We must reject header names ending in space. - headers_0 = map splitByColon $ tail headers_pre + no_empty_headers ::[B.ByteString] + no_empty_headers = filter (\x -> B.length x > 0) headers_pre + -- We remove the first "header" because it is actually the + -- initial HTTP request/response line + headers_0 = map splitByColon $ tail no_empty_headers + -- The first line is not actually a header, but contains the method, the version -- and the URI - request_or_response = parseFirstLine (head headers_pre) + maybe_request_or_response = parseFirstLine (head headers_pre) - headers_1 = headers_0 + headers_1 = [ + ( (stripBsHName . bsToLower $ hn), stripBs hv ) | (hn, hv) <- headers_0 + ] + Just request_or_response = maybe_request_or_response + (headers_2, has_body) = case request_or_response of Request_RoRL uri method -> let -- No lowercase, methods are case sensitive -- lc_method = bsToLower method - has_body' = case method of - "POST" -> True - "PUT" -> True - _ -> False + -- + -- TODO: There is a bug here, according to Section 3.3 of RFC 7230 + has_body' = methodHasRequestBody method in + -- TODO: We should probably add the "scheme" pseudo header here ( (":path", uri):(":method",method):headers_1, has_body' ) Response_RoRL status -> @@ -192,40 +256,84 @@ -- Still we need to lower-case header names, and trim them headers_3 = [ - ( (stripBs . bsToLower $ hn), stripBs hv ) | (hn, hv) <- headers_2 + ( (stripBsHName . bsToLower $ hn), stripBs hv ) | (hn, hv) <- headers_2 ] - content_length :: Int - content_length = + content_stop :: BodyStopCondition + content_stop = let - cnt_length_header = find (\ x -> (fst x) == "content-length" ) headers_3 - in case cnt_length_header of - Just (_, hv) -> read . unpack $ hv - Nothing -> throw ContentLengthMissingException + cnt_length_header = find (\ x -> (fst x) == "content-length" ) headers_3 + transfer_encoding = find (\ x -> (fst x) == "transfer-encoding" ) headers_3 + in + case transfer_encoding of + Nothing -> + case cnt_length_header of + Just (_, hv) -> case readEither . unpack $ hv of + Left _ -> SemanticAbort_BSC + Right n -> UseBodyLength_BSC n + Nothing -> ConnectionClosedByPeer_BSC + Just (_, tre_value) + | transferEncodingIsChunked tre_value -> + Chunked_BSC + | otherwise -> + SemanticAbort_BSC + + leftovers = B.drop (last_headers_position + 4) full_headers_text + all_headers_ok = all verifyHeaderSyntax headers_1 in - if has_body - then - HeadersAndBody_H1PC headers_3 (UseBodyLength_BSC content_length) leftovers - else - OnlyHeaders_H1PC headers_3 leftovers + if isJust maybe_request_or_response then + (if all_headers_ok then + if has_body + then + HeadersAndBody_H1PC headers_3 content_stop leftovers + else + OnlyHeaders_H1PC headers_3 leftovers + else + RequestIsMalformed_H1PC "InvalidSyntaxOnHeaders") + else + RequestIsMalformed_H1PC "InvalidFirstLineOnRequest" splitByColon :: B.ByteString -> (B.ByteString, B.ByteString) splitByColon = L.over L._2 (B.tail) . Ch8.break (== ':') -parseFirstLine :: B.ByteString -> RequestOrResponseLine +transferEncodingIsChunked :: B.ByteString -> Bool +transferEncodingIsChunked x = x == "chunked" + + +verifyHeaderName :: B.ByteString -> Bool +verifyHeaderName = + B.all ( \ w8 -> + ( ( w8 >= 48 && w8 <=57 ) || ( w8 >= 65 && w8 <= 90) + || ( w8 >= 97 && w8 <= 122) ) + || ( w8 == 43 ) || ( w8 == 95) -- "extensions" for our local tooling + || ( w8 == 45) -- Standard dash + ) + + +verifyHeaderValue :: B.ByteString -> Bool +verifyHeaderValue = B.all ( \ w8 -> + w8 >= 32 && w8 < 127 + ) + + +verifyHeaderSyntax :: (B.ByteString, B.ByteString) -> Bool +verifyHeaderSyntax (a,b) = verifyHeaderName a && verifyHeaderValue b + + +parseFirstLine :: B.ByteString -> Maybe RequestOrResponseLine parseFirstLine s = let - either_error_or_rrl = Ap.parseOnly httpFirstLine s - exc = HTTP11SyntaxException "BadMessageFirstLine" + either_error_or_rrl = Ap.parseOnly (httpFirstLine <* Ap.endOfInput ) s in case either_error_or_rrl of - Left _ -> throw exc - Right rrl -> rrl + Left _ -> Nothing + Right rrl -> Just rrl + bsToLower :: B.ByteString -> B.ByteString bsToLower = Ch8.map toLower @@ -249,6 +357,11 @@ (Ch8.dropWhile isWsCh8 s, ' ') +stripBsHName :: B.ByteString -> B.ByteString +stripBsHName s = + Ch8.dropWhile isWsCh8 s + + locateCRLFs :: Int -> [Int] -> Word8 -> B.ByteString -> ([Int], Int, Word8) locateCRLFs initial_offset other_positions prev_last_char next_chunk = let @@ -266,26 +379,34 @@ in (positions_list, strlen, last_char) +-- Parses the given list of positions, which is a reversed list. If +-- we find that the two latest positions of CRLF are consecutive, +-- then we are ok. and return it twoCRLFsAreConsecutive :: [Int] -> Maybe Int -twoCRLFsAreConsecutive (p2:p1:_) | p2 - p1 == 2 = Just p1 -twoCRLFsAreConsecutive _ = Nothing +twoCRLFsAreConsecutive positions = + let + -- This function is moving from tail to head + go seen (p2:p1:r) | p2 - p1 == 2 = go (Just p1) (p1:r) + | otherwise = go seen (p1:r) + go seen _ = seen + in go Nothing positions isWsCh8 :: Char -> Bool -isWsCh8 s = isJust (Ch8.elemIndex - s +isWsCh8 ch = isJust (Ch8.elemIndex + ch " \t" ) + isWs :: Word8 -> Bool -isWs s = isJust (B.elemIndex - s - " \t" - ) +isWs ch = (ch == 32) || (ch == 9) + http1Token :: Ap.Parser B.ByteString http1Token = Ap.string "HTTP/1.1" <|> Ap.string "HTTP/1.0" + http1Method :: Ap.Parser B.ByteString http1Method = Ap.string "GET" @@ -296,6 +417,7 @@ <|> Ap.string "TRACE" <|> Ap.string "CONNECT" + unspacedUri :: Ap.Parser B.ByteString unspacedUri = Ap.takeWhile (not . isWs) @@ -303,6 +425,7 @@ space :: Ap.Parser Word8 space = Ap.word8 32 + requestLine :: Ap.Parser RequestOrResponseLine requestLine = flip Request_RoRL @@ -314,9 +437,11 @@ <* space <* http1Token + digit :: Ap.Parser Word8 digit = Ap.satisfy (Ap.inClass "0-9") + responseLine :: Ap.Parser RequestOrResponseLine responseLine = (pure Response_RoRL) @@ -331,12 +456,77 @@ <* Ap.takeByteString + httpFirstLine :: Ap.Parser RequestOrResponseLine httpFirstLine = requestLine <|> responseLine +-- A parser for chunked messages .... +chunkParser :: Ap.Parser B.ByteString +chunkParser = do + lng_bs <- Ap8.hexadecimal :: Ap.Parser Int + Ap.option () ( + do + _ <- Ap.sepBy (Ap8.many1 $ Ap8.satisfy (Ap8.notInClass ";\r\n") ) (Ap8.char ';') + return () + ) + _ <- Ap8.char '\r' + _ <- Ap8.char '\n' + cnt <- Ap.take lng_bs + _ <- Ap8.char '\r' + _ <- Ap8.char '\n' + return cnt -headerListToHTTP11Text :: Headers -> Bu.Builder -headerListToHTTP11Text headers = + +wrapChunk :: B.ByteString -> Lb.ByteString +wrapChunk bs = let + lng = B.length bs + lng_str = showHex lng "" + a0 = Bu.byteString . pack $ lng_str + a1 = Bu.byteString bs + in Bu.toLazyByteString $ a0 `mappend` "\r\n" `mappend` a1 `mappend` "\r\n" + + +unwrapChunks :: Monad m => Conduit B.ByteString m B.ByteString +unwrapChunks = + do + input <- await + case input of + Nothing -> return () + Just bs -> + let + parse_result = Ap.parse chunkParser bs + in onresult parse_result + where + onresult parse_result = + case parse_result of + Ap.Fail _ _ _ -> throw $ HTTP11SyntaxException "ChunkedParsingFailed" + Ap.Partial fn -> go fn + Ap.Done leftovers payload -> do + payload `seq` yield payload + if (B.length payload > 0) + then + restart leftovers + else + leftover leftovers + go fn = do + input <- await + case input of + Nothing -> throw $ HTTP11SyntaxException "ChunkedParsingLeftUnfinished" + + Just bs -> + let + parse_result = fn bs + in onresult parse_result + restart leftovers = + let + parse_result = Ap.parse chunkParser leftovers + in onresult parse_result + + +-- This is a serialization function: it goes from content to string +-- It is not using during parse, but during the inverse process. +headerListToHTTP1ResponseText :: Headers -> Bu.Builder +headerListToHTTP1ResponseText headers = case headers of -- According to the specs, :status can be only -- the first header @@ -368,7 +558,37 @@ ] +-- | Converts a list of headers to a request head. +-- Invoke with the request data. Don't forget to clean the headers first. +-- NOTICE that this function doesn't add the \r\n extra-token for the empty +-- line at the end of headers. +headerListToHTTP1RequestText :: Headers -> Bu.Builder +headerListToHTTP1RequestText headers = + go1 Nothing Nothing mempty headers + where + go1 mb_method mb_local_uri assembled_body [] = + (fromMaybe "GET" mb_method) `mappend` " " `mappend` (fromMaybe "*" mb_local_uri) `mappend` " " `mappend` "HTTP/1.1" `mappend` "\r\n" + `mappend` assembled_body + go1 _ mb_local_uri assembled_body ((hn,hv): rest) + | hn == ":method" = + go1 (Just . Bu.byteString . validMethod $ hv) mb_local_uri assembled_body rest + + go1 mb_method _mb_local_uri assembled_body ((hn,hv): rest) + | hn == ":path" = + go1 mb_method (Just . Bu.byteString . cleanupAbsoluteUri $ hv) assembled_body rest + + -- Authority pseudo-header becomes a host header. + go1 mb_method _mb_local_uri assembled_body ((hn,hv): rest) + | hn == ":authority" = + go1 mb_method (Just . Bu.byteString . cleanupAbsoluteUri $ hv) (assembled_body `mappend` "host" `mappend` ":" `mappend` (Bu.byteString hv) `mappend` "\r\n") rest + + go1 mb_method mb_local_uri assembled_body ((hn,hv):rest) -- Ignore any strange pseudo-headers + | He.headerIsPseudo hn = go1 mb_method mb_local_uri assembled_body rest + | otherwise = go1 mb_method mb_local_uri (assembled_body `mappend` (Bu.byteString hn) `mappend` ":" `mappend` (Bu.byteString hv) `mappend` "\r\n") rest + + + serializeHTTPResponse :: Headers -> [B.ByteString] -> Lb.ByteString serializeHTTPResponse response_headers fragments = let @@ -393,7 +613,7 @@ headers_editor h3 = E.toList he2 -- Next, I must serialize the headers.... - headers_text_as_builder = headerListToHTTP11Text h3 + headers_text_as_builder = headerListToHTTP1ResponseText h3 -- We dump the headers first... unfortunately when talking -- HTTP/1.1 the most efficient way to write those bytes is @@ -416,6 +636,57 @@ body_builder +validMethod :: B.ByteString -> B.ByteString +validMethod mth | mth == "GET" = mth + | mth == "POST" = mth + | mth == "HEAD" = mth + | mth == "OPTIONS" = mth + | mth == "PUT" = mth + | mth == "DELETE" = mth + | mth == "TRACE" = mth + | otherwise = "GET" + + +methodHasRequestBody :: B.ByteString -> Bool +methodHasRequestBody mth | mth == "GET" = False + | mth == "POST" = True + | mth == "HEAD" = False + | mth == "OPTIONS" = False + | mth == "PUT" = True + | mth == "DELETE" = False + | mth == "TRACE" = False + | otherwise = False + + +-- These are most likely wrong TODO: fix +methodHasResponseBody :: B.ByteString -> Bool +methodHasResponseBody mth | mth == "GET" = True + | mth == "POST" = True + | mth == "HEAD" = False + | mth == "OPTIONS" = False + | mth == "PUT" = True + | mth == "DELETE" = False + | mth == "TRACE" = False + | otherwise = False + + +cleanupAbsoluteUri :: B.ByteString -> B.ByteString +-- Just trigger a 404 with an informative message (perhaps) +cleanupAbsoluteUri u + | B.length u == 0 + = "/client-gives-invalid-uri/" + | B.head u /= 47 + = "/client-gives-invalid-uri/" + | otherwise + = + let + str = unpack u + ok = U.isRelativeReference str + in if ok then u else "/client-gives-invalid-uri/" + + + + httpStatusTable :: M.Map Int Bu.Builder httpStatusTable = M.fromList [ @@ -460,15 +731,3 @@ (504, "Gateway Timeout"), (505, "HTTP Version Not Supported") ] - --- For testing purposes... -------------------------------------------------------------- ------------------------------------------------------------------------------------------ - --- assertEqual :: Eq a => String -> a -> a -> IO () --- assertEqual label v1 v2 = do --- putStrLn label --- if v1 == v2 --- then --- putStrLn "Ok" --- else --- putStrLn "NoOk" diff --git a/hs-src/SecondTransfer/Http1/Proxy.hs b/hs-src/SecondTransfer/Http1/Proxy.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Http1/Proxy.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, FunctionalDependencies, Rank2Types #-} +module SecondTransfer.Http1.Proxy ( + ioProxyToConnection + ) where + +import Control.Lens +import qualified Control.Exception as E +import Control.Monad (when) +--import Control.Monad.Morph (hoist, lift) +import Control.Monad.IO.Class (liftIO, MonadIO) +--import qualified Control.Monad.Trans.Resource as ReT + +import qualified Data.ByteString as B +--import Data.List (foldl') +import qualified Data.ByteString.Builder as Bu +--import Data.ByteString.Char8 (pack, unpack) +--import qualified Data.ByteString.Char8 as Ch8 +import qualified Data.ByteString.Lazy as LB +--import Data.Char (toLower) +import Data.Maybe (fromMaybe) + +import Data.Conduit + +--import SecondTransfer.MainLoop.CoherentWorker (Headers) + +import qualified SecondTransfer.Utils.HTTPHeaders as He +import SecondTransfer.Http1.Types +import SecondTransfer.Http1.Parse ( + headerListToHTTP1RequestText + , methodHasRequestBody + , methodHasResponseBody + , newIncrementalHttp1Parser + --, IncrementalHttp1Parser + , Http1ParserCompletion(..) + , addBytes + , unwrapChunks + , BodyStopCondition(..) + ) +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.IOCallbacks.Coupling (sendSourceToIO) +import SecondTransfer.Exception ( + HTTP11SyntaxException(..) + , NoMoreDataException + , IOProblem (..) + , GatewayAbortedException (..) + , keyedReportExceptions + -- , ignoreException + -- , ioProblem + ) + +#include "instruments.cpphs" + + + +fragmentMaxLength :: Int +fragmentMaxLength = 16384 + + +-- | Takes an IOCallbacks and serializes a request (encoded HTTP/2 style in headers and streams) +-- on top of the callback, waits for the results, and returns the response. Notice that this proxy +-- may fail for any reason, do take measures and handle exceptions. Also, must headers manipulations +-- (e.g. removing the Connection header) are left to the upper layers. And this doesn't include +-- managing any kind of pipelining in the http/1.1 connection, however, close is not done, so +-- keep-alive (not pipelineing) should be OK. +ioProxyToConnection :: forall m . MonadIO m => IOCallbacks -> HttpRequest m -> m (HttpResponse m, IOCallbacks) +ioProxyToConnection ioc request = + do + let + h1 = request ^. headers_Rq + he1 = He.fromList h1 + he2 = He.combineAuthorityAndHost he1 + h3 = He.toList he2 + headers_bu = headerListToHTTP1RequestText h3 + separator = "\r\n" + + -- Contents of the head, including the separator, which should always + -- be there. + cnt1 = headers_bu `mappend` separator + cnt1_lbz = Bu.toLazyByteString cnt1 + + method = fromMaybe "GET" $ He.fetchHeader h3 ":method" + + -- Send the headers and the separator + + -- This code can throw an exception, in that case, just let it + -- bubble. But the upper layer should deal with it. + --LB.putStr cnt1_lbz + --LB.putStr "\n" + liftIO $ (ioc ^. pushAction_IOC) cnt1_lbz + + -- Send the rest only if the method has something .... + if methodHasRequestBody method + then + -- We also need to send the body + sendSourceToIO (mapOutput LB.fromStrict $ request ^. body_Rq) ioc + else + return () + + -- So, say that we are here, that means we haven't exploded + -- in the process of sending this request. now let's Try to + -- fetch the answer... + let + incremental_http_parser = newIncrementalHttp1Parser + + -- pump0 :: IncrementalHttp1Parser -> m Http1ParserCompletion + pump0 p = + do + some_bytes <- liftIO $ (ioc ^. bestEffortPullAction_IOC) True + let completion = addBytes p some_bytes + case completion of + MustContinue_H1PC new_parser -> pump0 new_parser + + -- In any other case, just return + a -> return a + + pumpout :: MonadIO m => B.ByteString -> Int -> Source m B.ByteString + pumpout fragment n = do + when (B.length fragment > 0) $ yield fragment + when (n > 0 ) $ pull n + + pull :: MonadIO m => Int -> Source m B.ByteString + pull n + | n > fragmentMaxLength = do + + either_ioproblem_or_s <- liftIO $ keyedReportExceptions "pll-" $ E.try $ (ioc ^. pullAction_IOC ) fragmentMaxLength + s <- case either_ioproblem_or_s :: Either IOProblem B.ByteString of + Left _exc -> liftIO $ E.throwIO GatewayAbortedException + Right datum -> return datum + yield s + pull ( n - fragmentMaxLength ) + + | otherwise = do + + either_ioproblem_or_s <- liftIO $ keyedReportExceptions "pla-" $ E.try $ (ioc ^. pullAction_IOC ) n + s <- case either_ioproblem_or_s :: Either IOProblem B.ByteString of + Left _exc -> liftIO $ E.throwIO GatewayAbortedException + Right datum -> return datum + yield s + -- and finish... + + pull_forever :: MonadIO m => Source m B.ByteString + pull_forever = do + either_ioproblem_or_s <- liftIO $ keyedReportExceptions "plc-" $ E.try $ (ioc ^. bestEffortPullAction_IOC ) True + s <- case either_ioproblem_or_s :: Either IOProblem B.ByteString of + Left _exc -> liftIO $ E.throwIO GatewayAbortedException + Right datum -> return datum + yield s + + unwrapping_chunked :: MonadIO m => B.ByteString -> Source m B.ByteString + unwrapping_chunked leftovers = + (do + yield leftovers + pull_forever + ) =$= unwrapChunks + + pump_until_exception fragment = do + + if B.length fragment > 0 + then do + yield fragment + pump_until_exception mempty + else do + s <- liftIO $ keyedReportExceptions "ue-" $ E.try $ (ioc ^. bestEffortPullAction_IOC) True + case (s :: Either NoMoreDataException B.ByteString) of + Left _ -> do + return () + + Right datum -> do + yield datum + pump_until_exception mempty + + parser_completion <- pump0 incremental_http_parser + + case parser_completion of + + OnlyHeaders_H1PC headers leftovers -> do + when (B.length leftovers > 0) $ do + return () + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = return () + }, ioc) + + HeadersAndBody_H1PC headers (UseBodyLength_BSC n) leftovers -> do + -- HEADs must be handled differently! + if methodHasResponseBody method + then + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = pumpout leftovers (n - (fromIntegral $ B.length leftovers ) ) + }, ioc) + else + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = return () + }, ioc) + + + HeadersAndBody_H1PC headers Chunked_BSC leftovers -> do + -- HEADs must be handled differently! + if methodHasResponseBody method + then + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = unwrapping_chunked leftovers + },ioc) + else + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = return () + },ioc) + + + HeadersAndBody_H1PC _headers SemanticAbort_BSC _leftovers -> do + -- HEADs must be handled differently! + liftIO . E.throwIO $ HTTP11SyntaxException "SemanticAbort:SomethingAboutHTTP/1.1WasNotRight" + + + HeadersAndBody_H1PC headers ConnectionClosedByPeer_BSC leftovers -> do + -- The parser will assume that most responses have a body in the absence of + -- content-length, and that's probably as well. We work around that for + -- "HEAD" kind responses + if methodHasResponseBody method + then + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = pump_until_exception leftovers + },ioc) + else + return (HttpResponse { + _headers_Rp = headers + , _body_Rp = return () + },ioc) + + MustContinue_H1PC _ -> + error "UnexpectedIncompleteParse" + + -- TODO: See what happens when this exception passes from place to place. + RequestIsMalformed_H1PC msg -> do + liftIO . E.throwIO $ HTTP11SyntaxException msg diff --git a/hs-src/SecondTransfer/Http1/Session.hs b/hs-src/SecondTransfer/Http1/Session.hs --- a/hs-src/SecondTransfer/Http1/Session.hs +++ b/hs-src/SecondTransfer/Http1/Session.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} module SecondTransfer.Http1.Session( http11Attendant @@ -6,60 +6,103 @@ import Control.Lens -import Control.Exception (catch) -import Control.Concurrent (forkIO) -import Control.Monad.IO.Class (liftIO) +import Control.Exception (catch, try, throwIO) +--import Control.Concurrent (forkIO) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad (when) +import qualified Control.Monad.Trans.Resource as ReT +import Control.Monad.Morph (hoist, lift) import qualified Data.ByteString as B --- import qualified Data.ByteString.Lazy as LB --- import Data.ByteString.Char8 (unpack) --- import qualified Data.ByteString.Builder as Bu +import qualified Data.ByteString.Lazy as LB +import Data.ByteString.Char8 (unpack, + -- pack + ) +import qualified Data.ByteString.Builder as Bu +import Data.Foldable (find) import Data.Conduit -import Data.Conduit.List (consume) +import qualified Data.Conduit.List as CL import Data.IORef +import qualified Data.Attoparsec.ByteString as Ap -- import Data.Monoid (mconcat, mappend) import SecondTransfer.MainLoop.CoherentWorker -import SecondTransfer.MainLoop.PushPullType import SecondTransfer.MainLoop.Protocol import SecondTransfer.Sessions.Internal (SessionsContext, acquireNewSessionTag, sessionsConfig) --- Logging utilities -import System.Log.Logger +import SecondTransfer.IOCallbacks.Types + -- And we need the time import System.Clock import SecondTransfer.Http1.Parse -import SecondTransfer.Exception (IOProblem) +import SecondTransfer.Exception ( + IOProblem, + NoMoreDataException, + HTTP11SyntaxException (..), + forkIOExc + ) import SecondTransfer.Sessions.Config import qualified SecondTransfer.Utils.HTTPHeaders as He + -- import Debug.Trace (traceShow) +-- | Used to report metrics of the session for Http/1.1 +newtype SimpleSessionMetrics = SimpleSessionMetrics TimeSpec + +instance ActivityMeteredSession SimpleSessionMetrics where + sessionLastActivity (SimpleSessionMetrics t) = return t + + -- | Session attendant that speaks HTTP/1.1 -- +-- This attendant should be OK with keep-alive, but not with pipelining. http11Attendant :: SessionsContext -> AwareWorker -> Attendant -http11Attendant sessions_context coherent_worker attendant_callbacks +http11Attendant sessions_context coherent_worker connection_info attendant_callbacks = do new_session_tag <- acquireNewSessionTag sessions_context + started_time <- getTime Monotonic -- infoM "Session.Session_HTTP11" $ "Starting new session with tag: " ++(show new_session_tag) - forkIO $ go new_session_tag (Just "") 1 + _ <- forkIOExc "Http1Go" $ do + let + handle = SimpleSessionMetrics started_time + case maybe_hashable_addr of + Just hashable_addr -> + new_session + hashable_addr + (Partial_SGH handle attendant_callbacks) + push_action + + Nothing -> + putStrLn "Warning, created session without registering it" + + go started_time new_session_tag (Just "") 1 return () where + maybe_hashable_addr = connection_info ^. addr_CnD + push_action = attendant_callbacks ^. pushAction_IOC -- pull_action = attendant_callbacks ^. pullAction_IOC close_action = attendant_callbacks ^. closeAction_IOC best_effort_pull_action = attendant_callbacks ^. bestEffortPullAction_IOC - go :: Int -> Maybe B.ByteString -> Int -> IO () - go session_tag (Just leftovers) reuse_no = do - -- infoM "Session.Session_HTTP11" $ "(Re)Using session with tag: " ++ (show session_tag) + new_session :: HashableSockAddr -> SessionGenericHandle -> forall a . a -> IO () + new_session a b c = case maybe_callback of + Just (NewSessionCallback callback) -> callback a b c + Nothing -> return () + where + maybe_callback = + (sessions_context ^. (sessionsConfig . sessionsCallbacks . newSessionCallback_SC) ) + + go :: TimeSpec -> Int -> Maybe B.ByteString -> Int -> IO () + go started_time session_tag (Just leftovers) reuse_no = do maybe_leftovers <- add_data newIncrementalHttp1Parser leftovers session_tag reuse_no - go session_tag maybe_leftovers (reuse_no + 1) + go started_time session_tag maybe_leftovers (reuse_no + 1) - go _ Nothing _ = + go _ _ Nothing _ = return () -- This function will invoke itself as long as data is coming for the currently-being-parsed @@ -71,8 +114,15 @@ -- completion = addBytes parser $ traceShow ("At session " ++ (show session_tag) ++ " Received: " ++ (unpack bytes) ) bytes case completion of - MustContinue_H1PC new_parser -> - -- print "MustContinue_H1PC" + RequestIsMalformed_H1PC _msg -> do + --putStrLn $ "Syntax Error: " ++ msg + -- This is a syntactic error..., so just close the connection + close_action + -- We exit by returning nothing + return Nothing + + MustContinue_H1PC new_parser -> do + --putStrLn "MustContinue_H1PC" catch (do -- Try to get at least 16 bytes. For HTTP/1 requests, that may not be always @@ -88,9 +138,8 @@ return Nothing ) :: IOProblem -> IO (Maybe B.ByteString) ) - - OnlyHeaders_H1PC headers leftovers -> do - -- print "OnlyHeaders_H1PC" + OnlyHeaders_H1PC headers _leftovers -> do + -- putStrLn $ "OnlyHeaders_H1PC " ++ (show leftovers) -- Ready for action... -- ATTENTION: Not use for pushed streams here.... -- We must decide what to do if the user return those @@ -107,27 +156,18 @@ _streamId_Pr = reuse_no, _sessionId_Pr = session_tag, _protocol_Pr = Http11_HPV, - _anouncedProtocols_Pr = Nothing + _anouncedProtocols_Pr = Nothing, + _peerAddress_Pr = maybe_hashable_addr } } - let - data_and_conclusion = principal_stream ^. dataAndConclusion_PS - response_headers = principal_stream ^. headers_PS - (_, fragments) <- runConduit $ fuseBoth data_and_conclusion consume - let - response_text = - serializeHTTPResponse response_headers fragments + ReT.runResourceT $ answer_by_principal_stream principal_stream + -- Will discard leftovers, but can continue + return $ Just "" - catch - (do - push_action response_text - return $ Just leftovers - ) - ((\ _e -> do - -- debugM "Session.HTTP1" "Session abandoned" - close_action - return Nothing - ) :: IOProblem -> IO (Maybe B.ByteString) ) + -- We close the connection if any of the delimiting headers could not be parsed. + HeadersAndBody_H1PC _headers SemanticAbort_BSC _recv_leftovers -> do + close_action + return Nothing HeadersAndBody_H1PC headers stopcondition recv_leftovers -> do let @@ -135,63 +175,188 @@ started_time <- getTime Monotonic set_leftovers <- newIORef "" + let + source :: Source AwareWorkerStack B.ByteString + source = hoist lift $ case stopcondition of + UseBodyLength_BSC n -> counting_read recv_leftovers n set_leftovers + ConnectionClosedByPeer_BSC -> readforever recv_leftovers + Chunked_BSC -> readchunks recv_leftovers + _ -> error "ImplementMe" + principal_stream <- coherent_worker Request { _headers_RQ = modified_headers, - _inputData_RQ = Just $ counting_read recv_leftovers stopcondition set_leftovers, + _inputData_RQ = Just source, _perception_RQ = Perception { _startedTime_Pr = started_time, _streamId_Pr = reuse_no, _sessionId_Pr = session_tag, _protocol_Pr = Http11_HPV, - _anouncedProtocols_Pr = Nothing + _anouncedProtocols_Pr = Nothing, + _peerAddress_Pr = maybe_hashable_addr } } - let - data_and_conclusion = principal_stream ^. dataAndConclusion_PS - response_headers = principal_stream ^. headers_PS - (_, fragments) <- runConduit $ fuseBoth data_and_conclusion consume - channel_leftovers <- readIORef set_leftovers - let - response_text = - serializeHTTPResponse response_headers fragments + ReT.runResourceT $ answer_by_principal_stream principal_stream + return $ Just "" - catch - (do - push_action response_text - return $ Just channel_leftovers - ) - ((\ _e -> do - -- debugM "Session.HTTP1" "Session abandoned" - close_action - return Nothing - ) :: IOProblem -> IO (Maybe B.ByteString) ) - counting_read :: B.ByteString -> BodyStopCondition -> IORef B.ByteString -> Source IO B.ByteString - counting_read leftovers un@(UseBodyLength_BSC n) set_leftovers = do + counting_read :: B.ByteString -> Int -> IORef B.ByteString -> Source IO B.ByteString + counting_read leftovers n set_leftovers = do -- Can I continue? - if n == 0 then - do + if n == 0 + then do liftIO $ writeIORef set_leftovers leftovers return () - else - do - let - lngh_leftovers = B.length leftovers - if lngh_leftovers > 0 then - if lngh_leftovers <= n then - do - yield leftovers - counting_read "" (UseBodyLength_BSC (n - lngh_leftovers )) set_leftovers + else + do + let + lngh_leftovers = B.length leftovers + if lngh_leftovers > 0 + then + if lngh_leftovers <= n + then do + yield leftovers + counting_read "" (n - lngh_leftovers ) set_leftovers + else + do + let + (pass, new_leftovers) = B.splitAt n leftovers + yield pass + counting_read new_leftovers 0 set_leftovers else do + more_text <- liftIO $ best_effort_pull_action True + counting_read more_text n set_leftovers + + readforever :: B.ByteString -> Source IO B.ByteString + readforever leftovers = + if B.length leftovers > 0 + then do + yield leftovers + readforever mempty + else do + more_text_or_error <- liftIO . try $ best_effort_pull_action True + case more_text_or_error :: Either NoMoreDataException B.ByteString of + Left _ -> return () + Right bs -> do + when (B.length bs > 0) $ yield bs + readforever mempty + + readchunks :: B.ByteString -> Source IO B.ByteString + readchunks leftovers = do + let + gorc :: B.ByteString -> (B.ByteString -> Ap.IResult B.ByteString B.ByteString ) -> Source IO B.ByteString + gorc lo f = case f lo of + Ap.Fail _ _ _ -> + return () + Ap.Partial continuation -> + do + more_text_or_error <- liftIO . try $ best_effort_pull_action True + case more_text_or_error :: Either NoMoreDataException B.ByteString of + Left _ -> return () + Right bs + | B.length bs > 0 -> gorc bs continuation + | otherwise -> return () + Ap.Done i piece -> + do + if B.length piece > 0 + then do + yield piece + gorc i (Ap.parse chunkParser) + else + return () + gorc leftovers (Ap.parse chunkParser) + + maybepushtext :: MonadIO m => LB.ByteString -> m Bool + maybepushtext txt = liftIO $ + catch + (do + push_action txt + return True + ) + ((\ _e -> do + -- debugM "Session.HTTP1" "Session abandoned" + close_action + return False + ) :: IOProblem -> IO Bool ) + + piecewiseconsume :: MonadIO m => Sink LB.ByteString m Bool + piecewiseconsume = do + maybe_text <- await + case maybe_text of + Just txt -> do + can_continue <- liftIO $ maybepushtext txt + if can_continue + then + piecewiseconsume + else + return False + + Nothing -> return True + + piecewiseconsumecounting :: MonadIO m => Int -> Sink LB.ByteString m Bool + piecewiseconsumecounting n + | n > 0 = do + maybe_text <- await + case maybe_text of + Just txt -> do + let + send_txt = LB.take (fromIntegral n) txt + can_continue <- liftIO $ maybepushtext send_txt + if can_continue + then do let - (pass, new_leftovers) = B.splitAt n leftovers - yield pass - counting_read new_leftovers (UseBodyLength_BSC 0) set_leftovers - else - do - more_text <- liftIO $ best_effort_pull_action True - counting_read more_text un set_leftovers + left_to_take = ( n - fromIntegral (LB.length send_txt)) + piecewiseconsumecounting left_to_take + else + return False + + Nothing -> return True + | otherwise = + return True + + answer_by_principal_stream :: PrincipalStream -> AwareWorkerStack () + answer_by_principal_stream principal_stream = do + let + data_and_conclusion = principal_stream ^. dataAndConclusion_PS + response_headers = principal_stream ^. headers_PS + transfer_encoding = find (\ x -> (fst x) == "transfer-encoding" ) response_headers + cnt_length_header = find (\ x -> (fst x) == "content-length" ) response_headers + headers_text_as_lbs = Bu.toLazyByteString $ headerListToHTTP1ResponseText response_headers `mappend` "\r\n" + + close_release_key <- ReT.register close_action + case (transfer_encoding, cnt_length_header) of + + (Just (_, enc), _ ) + | transferEncodingIsChunked enc -> do + -- TODO: Take care of footers + liftIO $ push_action headers_text_as_lbs + -- Will run the conduit. If it fails, the connection will be closed. + (_maybe_footers, _did_ok) <- runConduit $ data_and_conclusion `fuseBothMaybe` (CL.map wrapChunk =$= piecewiseconsume) + -- Don't forget the zero-length terminating chunk... + _ <- maybepushtext $ wrapChunk "" + -- If I got to this point, I can keep the connection alive for a future request + _ <- ReT.unprotect close_release_key + return () + + | otherwise -> do + -- This is a pretty bad condition, I don't know how to use + -- any other encoding... + liftIO . throwIO . HTTP11SyntaxException $ "UnhandledTransferEncoding" + + (Nothing, (Just (_,content_length_str))) -> do + -- Use the provided chunks, as naturally as possible + let + content_length :: Int + content_length = read . unpack $ content_length_str + liftIO $ push_action headers_text_as_lbs + (_maybe_footers, _did_ok) <- runConduit $ data_and_conclusion `fuseBothMaybe` (CL.map LB.fromStrict =$= piecewiseconsumecounting content_length) + -- Got here, keep the connection open + _ <- ReT.unprotect close_release_key + return () + + (Nothing, Nothing) -> do + -- What? + liftIO . throwIO $ HTTP11SyntaxException "ApplicationMustProvideContentLengthOrSpecifiyTransferEncoding" addExtraHeaders :: SessionsContext -> Headers -> Headers diff --git a/hs-src/SecondTransfer/Http1/Types.hs b/hs-src/SecondTransfer/Http1/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Http1/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, FunctionalDependencies #-} +module SecondTransfer.Http1.Types ( + HttpRequest (..) + , headers_Rq + , body_Rq + + + , HttpResponse (..) + , headers_Rp + , body_Rp + + , Http1CycleController (..) + , ProxyToHttpServer (..) + + + ) where + +import Control.Lens +import qualified Data.ByteString as B +import Data.Conduit + +import SecondTransfer.MainLoop.CoherentWorker (Headers) + +----- Types--- I may move some of the types here later to CoherentWorker -------- +-- ... or to some other common-use file. + +-- | Request. This is an old-fashioned HTTP request, with less data than that +-- defined at CoherentWorker: just headers and perhaps a request streaming body. +-- As in other places in this library, we expect method and path to be +-- given as pseudo-headers +data HttpRequest m = HttpRequest { + _headers_Rq :: Headers + , _body_Rq :: Source m B.ByteString + } + +makeLenses ''HttpRequest + + +-- | Response. Status should be given as a pseudo-header +data HttpResponse m = HttpResponse { + _headers_Rp :: Headers + , _body_Rp :: Source m B.ByteString + } + +makeLenses ''HttpResponse + +-- Used for early release of resources +class Monad m => Http1CycleController m contrl where + releaseResponseResources :: contrl -> m () + +-- | Something that can talk to a HTTP 1.1 server by using a connection and sending +-- the request to it +class (Http1CycleController m contrl, Monad m) => ProxyToHttpServer m conn contrl | conn -> contrl m where + -- Sends the request to server, gets the response + proxyToConnection :: + conn + -> HttpRequest m + -> m (HttpResponse m, contrl) diff --git a/hs-src/SecondTransfer/Http2.hs b/hs-src/SecondTransfer/Http2.hs --- a/hs-src/SecondTransfer/Http2.hs +++ b/hs-src/SecondTransfer/Http2.hs @@ -6,3 +6,4 @@ ) where import SecondTransfer.Http2.MakeAttendant(http2Attendant) +import SecondTransfer.Sessions.Internal() diff --git a/hs-src/SecondTransfer/Http2/CalmState.hs b/hs-src/SecondTransfer/Http2/CalmState.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Http2/CalmState.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} + +module SecondTransfer.Http2.CalmState ( + CalmState + , newCalmState + , getCurrentCalm + , advanceCalm + + , CalmEnhacementMap + ) where + +--import Control.Lens +--import Data.Word (Word) + +--- How to enhance the calm as word boundaries are crossed. +type CalmEnhacementMap = [(Word, Word)] + + +-- Struct is private, +data CalmState = CalmState { + _restOfMap :: !CalmEnhacementMap + , _currentOffset :: !Int + , _currentCalm :: !Int + } + deriving (Show, Eq) + +newCalmState :: Int -> CalmEnhacementMap -> CalmState +newCalmState start_calm cemap = CalmState cemap 0 start_calm + + +getCurrentCalm :: CalmState -> Int +getCurrentCalm CalmState{_currentCalm} = _currentCalm + + +advanceCalm :: CalmState -> Int -> CalmState +advanceCalm cs@CalmState{ _restOfMap = [] } _advance_bytes = cs +advanceCalm _cs@CalmState{ _restOfMap = rom@((offset, bump):r), + _currentOffset, + _currentCalm } advance_bytes = + let + new_offset = _currentOffset + advance_bytes + crosses_boundary = fromIntegral new_offset > offset + in + CalmState { + _restOfMap = if crosses_boundary then r else rom , + _currentOffset = new_offset, + _currentCalm = if crosses_boundary then _currentCalm + fromIntegral bump else _currentCalm + } diff --git a/hs-src/SecondTransfer/Http2/Framer.hs b/hs-src/SecondTransfer/Http2/Framer.hs --- a/hs-src/SecondTransfer/Http2/Framer.hs +++ b/hs-src/SecondTransfer/Http2/Framer.hs @@ -18,36 +18,35 @@ import Control.Concurrent hiding (yield) -import qualified Control.Concurrent as CC(yield) -import qualified Control.Concurrent.MSem as MS -import Control.Concurrent.STM.TMVar -import qualified Control.Concurrent.STM as STM + import Control.Exception import qualified Control.Exception as E import Control.Lens (view, (^.) ) import qualified Control.Lens as L -import Control.Monad (unless, when, replicateM_) +import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO) -import qualified Control.Monad.Catch as C +--import qualified Control.Monad.Catch as C import Control.Monad.Trans.Class (lift) -import Control.DeepSeq (($!!)) +-- import Control.DeepSeq (($!!)) import Control.Monad.Trans.Reader import Data.Binary (decode) import qualified Data.ByteString as B -import Data.ByteString.Char8 (pack) +--import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Builder as Bu import Data.Conduit import Data.Foldable (find) -import qualified Data.PQueue.Min as PQ -import Data.Maybe (fromMaybe) +--import qualified Data.PQueue.Min as PQ +--import Data.Maybe (fromMaybe) import qualified Network.HTTP2 as NH2 --- Logging utilities -import System.Log.Logger import qualified Data.HashTable.IO as H -import System.Clock (Clock(..),getTime) +import System.Clock ( + Clock(..) + , getTime + , TimeSpec + ) -- import System.Mem.Weak import SecondTransfer.Sessions.Internal ( @@ -57,18 +56,27 @@ SessionsContext) import SecondTransfer.Sessions.Config import SecondTransfer.Http2.Session -import SecondTransfer.MainLoop.CoherentWorker (AwareWorker, fragmentDeliveryCallback_Ef, priorityEffect_Ef) +import SecondTransfer.MainLoop.CoherentWorker (AwareWorker , + Effect , + PriorityEffect (..), + fragmentDeliveryCallback_Ef , + priorityEffect_Ef) import qualified SecondTransfer.MainLoop.Framer as F -import SecondTransfer.MainLoop.PushPullType +import SecondTransfer.IOCallbacks.Types import SecondTransfer.Utils (Word24, word24ToInt) import SecondTransfer.Exception -import SecondTransfer.MainLoop.Logging (logWithExclusivity, logit) -import Debug.Trace (trace) +import SecondTransfer.Http2.TransferTypes +import SecondTransfer.Http2.OutputTray +import SecondTransfer.Http2.CalmState -#include "Logging.cpphs" +#ifdef SECONDTRANSFER_MONITORING +import SecondTransfer.MainLoop.Logging (logit) +#endif +--import Debug.Trace (traceStack) + http2PrefixLength :: Int http2PrefixLength = B.length NH2.connectionPreface @@ -77,75 +85,41 @@ type HashTable k v = H.CuckooHashTable k v -type GlobalStreamId = Int - - data FlowControlCommand = AddBytes_FCM Int - |Finish_FCM +-- |Finish_FCM -- A hashtable from stream id to channel of availabiliy increases -type Stream2AvailSpace = HashTable GlobalStreamId (MVar FlowControlCommand) +type Stream2AvailSpace = HashTable GlobalStreamId (Chan FlowControlCommand) -data CanOutput = CanOutput - -data NoHeadersInChannel = NoHeadersInChannel - - --- Maximum number of packets in the priority queue waiting for --- delivery. More than this, and I will simply block... -maxPacketsInQueue :: Int -maxPacketsInQueue = 32 - - ------In this implementation, this v- and this v- member should not change during the lieftime ------ of the stream. ------------------------------------v--priority, v-- stream_id ----|------v-ordinal -newtype PrioPacket = PrioPacket ( (Int , Int, Int ), LB.ByteString) - deriving Show - -instance Eq PrioPacket where - (==) (PrioPacket (a,_)) (PrioPacket (b,_)) = a == b - -instance Ord PrioPacket where - compare (PrioPacket (a,_)) (PrioPacket (b,_)) = compare a b - - -- Simple thread to prioritize frames in the session data PrioritySendState = PrioritySendState { - -- We need a semaphore so that this doesn't get stagnated waiting on writes - _semToSend :: MS.MSem Int - ,_prioQ :: TMVar (PQ.MinQueue PrioPacket) + _outputTray_PSS :: MVar OutputTray + , _dataReady_PSS :: MVar () + , _spaceReady_PSS :: MVar () } +L.makeLenses ''PrioritySendState + data FramerSessionData = FramerSessionData { -- A dictionary (protected by a lock) from stream id to flow control command. _stream2flow :: MVar Stream2AvailSpace - -- Two members below: the place where you put data which is going to be flow-controlled, - -- and the place with the ordinal - -- Flow control dictionary. It goes from stream id to the stream data-output gate (an-mvar) - -- and to a mutable register for the ordinal. The ordinal for packets inside a stream is used - -- for priority and reporting - , _stream2outputBytes :: MVar ( HashTable GlobalStreamId (MVar LB.ByteString, MVar Int) ) - -- The default flow-control window advertised by the peer (e.g., the browser) , _defaultStreamWindow :: MVar Int - -- Wait variable to output bytes to the channel. This is needed to avoid output data races. - , _canOutput :: MVar CanOutput + -- The max frame size that I'm willing to receive, (including frame header). This size can't be less + -- than 16384 nor greater than 16777215. But it is decided here in the server + , _maxRecvSize :: Int -- Flag that says if the session has been unwound... if such, -- threads are adviced to exit as early as possible , _outputIsForbidden :: MVar Bool - -- Exclusive lock for headers, needed since the specs forbid interleaving header and data - , _noHeadersInChannel :: MVar NoHeadersInChannel - -- The push action , _pushAction :: PushAction @@ -165,7 +139,7 @@ , _lastInputStream :: MVar Int -- We update this one as soon as an outgoing frame is seen with such a -- high output number. - , _lastOutputStream :: MVar Int + --, _lastOutputStream :: MVar Int -- For sending data orderly , _prioritySendState :: PrioritySendState @@ -183,23 +157,36 @@ AwareWorker_SP AwareWorker -- I'm a server |ClientState_SP ClientState -- I'm a client + +newtype SimpleSessionControl = SimpleSessionControl (TimeSpec, IO () ) + + +instance ActivityMeteredSession SimpleSessionControl where + sessionLastActivity (SimpleSessionControl (t,_button)) = return t + + +-- | This is a special "mark" priority that when used causes the connection +-- to be closed. It is used because is clean. +goAwayPriority :: Int +goAwayPriority = (-15) + + wrapSession :: SessionPayload -> SessionsContext -> Attendant -wrapSession session_payload sessions_context io_callbacks = do +wrapSession session_payload sessions_context connection_info io_callbacks = do let session_id_mvar = view nextSessionId sessions_context push_action = io_callbacks ^. pushAction_IOC pull_action = io_callbacks ^. pullAction_IOC close_action = io_callbacks ^. closeAction_IOC - -- best_effort_pull_action = io_callbacks ^. bestEffortPullAction_IOC - new_session_id <- modifyMVarMasked session_id_mvar $ \ session_id -> return $ session_id `seq` (session_id + 1, session_id) (session_input, session_output) <- case session_payload of AwareWorker_SP aware_worker -> http2ServerSession + connection_info aware_worker new_session_id sessions_context @@ -217,44 +204,42 @@ -- TODO : Add type annotations.... s2f <- H.new stream2flow_mvar <- newMVar s2f - s2o <- H.new - stream2output_bytes_mvar <- newMVar s2o default_stream_size_mvar <- newMVar 65536 - can_output <- newMVar CanOutput - no_headers_in_channel <- newMVar NoHeadersInChannel last_stream_id <- newMVar 0 - last_output_stream_id <- newMVar 0 + -- last_output_stream_id <- newMVar 0 output_is_forbidden <- newMVar False - prio_mvar <- STM.atomically $ newTMVar PQ.empty - sem_to_send <- MS.new maxPacketsInQueue - + output_tray_mvar <- newMVar . newOutputTray . ( ^. sessionsConfig . trayMaxSize ) $ sessions_context + data_ready_mvar <- newEmptyMVar + space_ready_mvar <- newMVar () + -- TODO: this one should be comming from the SessionsConfig struct at Sessions/Config.hs + let max_recv_frame_size = 16384 -- We need some shared state let framer_session_data = FramerSessionData { _stream2flow = stream2flow_mvar - ,_stream2outputBytes = stream2output_bytes_mvar ,_defaultStreamWindow = default_stream_size_mvar - ,_canOutput = can_output - ,_noHeadersInChannel = no_headers_in_channel + ,_maxRecvSize = max_recv_frame_size ,_pushAction = push_action ,_closeAction = close_action ,_sessionIdAtFramer = new_session_id ,_sessionsContext = sessions_context ,_lastInputStream = last_stream_id - ,_lastOutputStream = last_output_stream_id + --,_lastOutputStream = last_output_stream_id ,_outputIsForbidden = output_is_forbidden ,_prioritySendState = PrioritySendState { - _semToSend = sem_to_send, - _prioQ = prio_mvar + _outputTray_PSS = output_tray_mvar + , _dataReady_PSS = data_ready_mvar + , _spaceReady_PSS = space_ready_mvar } ,_sessionRole_FSD = session_role } let - -- TODO: Dodgy exception handling here... + + close_on_error :: Int -> SessionsContext -> IO () -> IO () close_on_error session_id session_context comp = E.finally ( E.catch @@ -267,29 +252,44 @@ ) close_action + -- dont_close_on_error :: Int -> SessionsContext -> IO () -> IO () + -- dont_close_on_error session_id session_context comp = + -- E.catch + -- ( + -- E.catch + -- comp + -- (exc_handler session_id session_context) + -- ) + -- (io_exc_handler session_id session_context) + + ensure_close :: IO a -> IO a + ensure_close c = E.finally c close_action + + -- Invokes the specialized error callbacks configured in the session. + -- TODO: I don't think much is being done here exc_handler :: Int -> SessionsContext -> FramerException -> IO () exc_handler x y e = do modifyMVar_ output_is_forbidden (\ _ -> return True) - -- INSTRUMENTATION( errorM "HTTP2.Framer" "Exception went up" ) sessionExceptionHandler Framer_HTTP2SessionComponent x y e io_exc_handler :: Int -> SessionsContext -> IOProblem -> IO () - io_exc_handler _x _y _e = + io_exc_handler _x _y _e = do + -- putStrLn $ show _e modifyMVar_ output_is_forbidden (\ _ -> return True) - -- !!! These exceptions are way too common for we to care.... - -- errorM "HTTP2.Framer" "Exception went up" - -- sessionExceptionHandler Framer_HTTP2SessionComponent x y e - forkIO - $ close_on_error new_session_id sessions_context + _ <- forkIOExc "inputGathererHttp2" + $ {-# SCC inputGatherer #-} close_on_error new_session_id sessions_context + $ ignoreException blockedIndefinitelyOnMVar () $ runReaderT (inputGatherer pull_action session_input ) framer_session_data - forkIO - $ close_on_error new_session_id sessions_context + _ <- forkIOExc "outputGathererHttp2" + $ {-# SCC outputGatherer #-} close_on_error new_session_id sessions_context + $ ignoreException blockedIndefinitelyOnMVar () $ runReaderT (outputGatherer session_output ) framer_session_data -- Actual data is reordered before being sent - forkIO - $ close_on_error new_session_id sessions_context + _ <- forkIOExc "sendReorderingHttp2" + $ ensure_close + $ {-# SCC sendReordering #-} close_on_error new_session_id sessions_context $ runReaderT sendReordering framer_session_data return () @@ -313,28 +313,34 @@ -- By the specs, a WINDOW_UPDATE with 0 of credit should be considered a protocol -- error return False -addCapacity 0 delta_cap = +addCapacity 0 _delta_cap = -- TODO: Implement session flow control return True addCapacity stream_id delta_cap = - do - table_mvar <- view stream2flow - val <- liftIO $ withMVar table_mvar $ \ table -> - H.lookup table stream_id - last_stream_mvar <- view lastInputStream - last_stream <- liftIO . readMVar $ last_stream_mvar - case val of - Nothing | stream_id > last_stream -> - return False - | otherwise -> -- If the stream was seen already, interpret this as a - -- rogue WINDOW_UPDATE and do nothing - return True + do + table_mvar <- view stream2flow + val <- liftIO $ withMVar table_mvar $ \ table -> + H.lookup table stream_id + last_stream_mvar <- view lastInputStream + last_stream <- liftIO . readMVar $ last_stream_mvar + case val of + Nothing | stream_id > last_stream -> + return False + | otherwise -> do + -- Maybe we arrive here and the stream is still running :-( + -- it is hard to know during a session what's the state of a stream + -- without "remembering" it :-( + -- TODO: this is actually a bug, think better how to man + command_chan <- startStreamOutputComandQueueIfNeeded stream_id + liftIO $ writeChan command_chan $ AddBytes_FCM delta_cap + return True - Just command_chan -> do - liftIO $ putMVar command_chan $ AddBytes_FCM delta_cap - return True + Just command_chan -> do + liftIO $ writeChan command_chan $ AddBytes_FCM delta_cap + return True + finishFlowControlForStream :: GlobalStreamId -> FramerSession () finishFlowControlForStream stream_id = do @@ -345,43 +351,57 @@ -- Weird Nothing -> return () - Just command_chan -> do + Just _command_chan -> do liftIO $ H.delete table stream_id return () - table2_mvar <- view stream2outputBytes - liftIO . withMVar table2_mvar $ \ table -> do - val <- H.lookup table stream_id - case val of - Nothing -> return () - Just _ -> - liftIO $ H.delete table stream_id - -readNextFrame :: Monad m => - (Int -> m B.ByteString) -- ^ Generator action - -> Source m (Maybe NH2.Frame) -- ^ Packet and leftovers, if we could get them -readNextFrame pull_action = do +readNextFrame :: + Int + -> (Int -> IO B.ByteString) -- ^ Generator action + -> Source IO (Maybe NH2.Frame) -- ^ Packet and leftovers, if we could get them +readNextFrame max_acceptable_size pull_action = do -- First get 9 bytes with the frame header - frame_header_bs <- lift $ pull_action 9 - -- decode it - let - (frame_type_id, frame_header) = NH2.decodeFrameHeader frame_header_bs - NH2.FrameHeader payload_length _ _ = frame_header - -- Get as many bytes as the payload length identifies - payload_bs <- lift $ pull_action payload_length - -- Return the entire frame, or raise an exception... - let - either_frame = NH2.decodeFramePayload frame_type_id frame_header payload_bs - case either_frame of - Right frame_payload -> do - yield . Just $ NH2.Frame frame_header frame_payload - readNextFrame pull_action - Left _ -> - yield Nothing + either_frame_header_bs <- lift $ E.try $ pull_action 9 + case either_frame_header_bs :: Either IOProblem B.ByteString of + Left _ -> do + return () + Right frame_header_bs -> do + -- decode it + let + (frame_type_id, frame_header) = NH2.decodeFrameHeader frame_header_bs + NH2.FrameHeader payload_length _ _ = frame_header + -- liftIO . putStrLn $ "payload length: " ++ (show payload_length) ++ " max sz " ++ show max_acceptable_size + if payload_length + 9 > max_acceptable_size + then do + liftIO $ putStrLn "Frame too big" + return () + else do + -- Get as many bytes as the payload length identifies + -- liftIO . putStrLn $ "Payload length requested " ++ show payload_length + either_payload_bs <- lift $ E.try (pull_action payload_length) + case either_payload_bs :: Either IOProblem B.ByteString of + Left _ -> do + return () + Right payload_bs + | B.length payload_bs == 0 && payload_length > 0 -> do + return () + + | otherwise -> do + -- Return the entire frame, or raise an exception... + let + either_frame = NH2.decodeFramePayload frame_type_id frame_header payload_bs + case either_frame of + Right frame_payload -> do + yield . Just $ NH2.Frame frame_header frame_payload + readNextFrame max_acceptable_size pull_action + Left _ -> + yield Nothing + + -- This works by pulling bytes from the input side of the pipeline and converting them to frames. -- The frames are then put in the SessionInput. In the other end of the SessionInput they can be -- interpreted according to their HTTP/2 meaning. @@ -395,6 +415,8 @@ session_role <- view sessionRole_FSD + max_recv_size <- view maxRecvSize + when (session_role == Server_SR) $ do -- We can start by reading off the prefix.... prefix <- liftIO $ pull_action http2PrefixLength @@ -407,11 +429,10 @@ let source::Source FramerSession (Maybe NH2.Frame) - source = transPipe liftIO $ readNextFrame pull_action + source = transPipe liftIO $ readNextFrame max_recv_size pull_action source $$ consume True where - sendToSession :: Bool -> InputFrame -> IO () sendToSession starting frame = -- print(NH2.streamId $ NH2.frameHeader frame) @@ -422,7 +443,8 @@ sendMiddleFrameToSession session_input frame abortSession :: Sink a FramerSession () - abortSession = + abortSession = do + liftIO $ putStrLn "Framer called Abort Session" lift $ do sendGoAwayFrame NH2.ProtocolError -- Inform the session that it can tear down itself @@ -436,6 +458,8 @@ consume starting = do maybe_maybe_frame <- await + -- liftIO . putStrLn . show $ maybe_maybe_frame + output_is_forbidden_mvar <- view outputIsForbidden output_is_forbidden <- liftIO $ readMVar output_is_forbidden_mvar @@ -443,27 +467,27 @@ -- attacks where a peer refuses to close its socket. unless output_is_forbidden $ case maybe_maybe_frame of - Just Nothing -> - -- Only way to get here is by a closed connection condition I guess. + Just Nothing -> do + -- Only way to get here is by a closed connection condition, or because some decoding failed + -- in a very bad way, or because frame size was exceeded. All of those are error conditions, + -- and therefore we should undo the session abortSession Just (Just right_frame) -> do case right_frame of - (NH2.Frame (NH2.FrameHeader _ _ stream_id) (NH2.WindowUpdateFrame credit) ) -> do + frame@(NH2.Frame (NH2.FrameHeader _ _ stream_id) (NH2.WindowUpdateFrame credit) ) -> do -- Bookkeep the increase on bytes on that stream - -- liftIO $ putStrLn $ "Extra capacity for stream " ++ (show stream_id) succeeded <- lift $ addCapacity stream_id (fromIntegral credit) if not succeeded then - abortSession - else - consume_continue - + abortSession + else do + liftIO $ sendToSession starting $! frame + consume_continue frame@(NH2.Frame _ (NH2.SettingsFrame settings_list) ) -> do -- Increase all the stuff.... case find (\(i,_) -> i == NH2.SettingsInitialWindowSize) settings_list of - Just (_, new_default_stream_size) -> do old_default_stream_size_mvar <- view defaultStreamWindow old_default_stream_size <- liftIO $ takeMVar old_default_stream_size_mvar @@ -472,15 +496,12 @@ -- Add capacity to everybody's windows liftIO . withMVar stream_to_flow $ \ stream_to_flow' -> H.mapM_ (\ (k,v) -> - when (k /=0 ) $ putMVar v (AddBytes_FCM $! general_delta) + when (k /=0 ) $ writeChan v (AddBytes_FCM $! general_delta) ) stream_to_flow' - - -- And set a new value liftIO $ putMVar old_default_stream_size_mvar $! new_default_stream_size - Nothing -> -- This is a silenced internal error return () @@ -505,8 +526,9 @@ -- We may as well exit this thread return () +type DeliveryNotifyCallback = GlobalStreamId -> Effect -> Int -> FramerSession () --- All the output frames come this way first +-- | All the output frames come this way first outputGatherer :: SessionOutput -> FramerSession () outputGatherer session_output = do @@ -523,19 +545,39 @@ dataDeliveryCallback_SC session_id <- view sessionIdAtFramer + let + delivery_notify :: GlobalStreamId -> Effect -> Int -> FramerSession () + delivery_notify stream_id effect ordinal = + liftIO $ do + case (frame_sent_report_callback, effect ^. fragmentDeliveryCallback_Ef ) of + (Just c1, Just c2) -> liftIO $ do + -- Here we invoke the client's callback. + when_delivered <- getTime Monotonic + c1 session_id stream_id ordinal when_delivered + c2 ordinal when_delivered + (Nothing, Just c2) -> liftIO $ do + when_delivered <- getTime Monotonic + c2 ordinal when_delivered + (Just c1, Nothing) -> liftIO $ do + when_delivered <- getTime Monotonic + c1 session_id stream_id ordinal when_delivered + (Nothing, Nothing) -> return () - dataForFrame p1 p2 = - LB.fromStrict $ NH2.encodeFrame p1 p2 + let - cont = loopPart session_id frame_sent_report_callback + -- dataForFrame p1 p2 = + -- LB.fromStrict $ NH2.encodeFrame p1 p2 - loopPart :: Int -> Maybe DataFrameDeliveryCallback -> FramerSession () - loopPart session_id frame_sent_report_callback = do + cont = loopPart + + loopPart :: FramerSession () + loopPart = do command_or_frame <- liftIO $ getFrameFromSession session_output + -- liftIO . putStrLn . show $ command_or_frame case command_or_frame of - Left (CancelSession_SOC error_code) -> do + Command_StFB (CancelSession_SOC error_code) -> do -- The session wants to cancel things as harshly as possible, send a GoAway frame with -- the information I have here. sendGoAwayFrame error_code @@ -544,125 +586,83 @@ -- are taken from the session. Correspondingly, an exception is raised in -- the session if it tries to write another frame - Left (SpecificTerminate_SOC last_stream_id) -> do + Command_StFB (SpecificTerminate_SOC last_stream_id error_code) -> do -- This is used when the session wants to finish in a specific way. - sendSpecificTerminateGoAway last_stream_id + sendSpecificTerminateGoAway last_stream_id error_code releaseFramer - Left (FinishStream_SOC stream_id ) -> do - -- Session knows that we are done with the given stream, and that we can release - -- the flow control structures - finishFlowControlForStream stream_id - cont - - Right ( p1@(NH2.EncodeInfo _ stream_idii _), p2@(NH2.DataFrame _), ef ) -> do - -- This frame is flow-controlled... I may be unable to send this frame in - -- some circumstances... + HeadersTrain_StFB (stream_id, frames, effect , stream_bytes_mvar) -> do let - stream_id = stream_idii - priority = fromMaybe stream_id $ ef ^. priorityEffect_Ef - - startStreamOutputQueueIfNotExists stream_id $ priority - - stream2output_mvar <- view stream2outputBytes - lookup_result <- liftIO $ withMVar stream2output_mvar $ \ s2o -> H.lookup s2o stream_id - (stream_bytes_chan, frame_ordinal_mvar) <- case lookup_result of - Nothing -> - error "It is the end of the world at Framer.hs" - Just x -> return x - - -- All the dance below is to avoid a system call if there is no need - case (frame_sent_report_callback, ef ^. fragmentDeliveryCallback_Ef ) of - (Just c1, Just c2) -> liftIO $ do - -- Here we invoke the client's callback. - when_delivered <- getTime Monotonic - ordinal <- modifyMVar frame_ordinal_mvar $ \ o -> return (o+1, o) - c1 session_id stream_id ordinal when_delivered - c2 ordinal when_delivered - (Nothing, Just c2) -> liftIO $ do - when_delivered <- getTime Monotonic - ordinal <- modifyMVar frame_ordinal_mvar $ \ o -> return (o+1, o) - c2 ordinal when_delivered - (Just c1, Nothing) -> liftIO $ do - when_delivered <- getTime Monotonic - ordinal <- modifyMVar frame_ordinal_mvar $ \ o -> return (o+1, o) - c1 session_id stream_id ordinal when_delivered - (Nothing, Nothing) -> return () - - liftIO $ putMVar stream_bytes_chan $! dataForFrame p1 p2 - cont - - - Right (p1, p2@(NH2.PushPromiseFrame _ _), _effect ) -> do - handleHeadersOfStream p1 p2 - cont - - Right (p1, p2@(NH2.HeadersFrame _ _), _effect ) -> do - handleHeadersOfStream p1 p2 + bs = serializeMany frames + -- Send the headers first + withHighPrioritySend bs + startStreamOutputQueue effect stream_bytes_mvar stream_id delivery_notify cont - Right (p1, p2@(NH2.ContinuationFrame _), _effect ) -> do - handleHeadersOfStream p1 p2 + PriorityTrain_StFB frames -> do + -- Serialize the entire train + let + bs = serializeMany frames + -- Put it in the output tray + withHighPrioritySend bs + -- and continue cont - Right (p1, p2, _effect) -> do - -- Most other frames go right away... as long as no headers are in process... - no_headers <- view noHeadersInChannel - liftIO $ takeMVar no_headers - pushFrame p1 p2 - liftIO $ putMVar no_headers NoHeadersInChannel - cont + -- case_ -> error $ "Error: case not spefified " - -- We start by sending a settings frame - pushFrame + -- We start by sending a settings frame... NOTICE that this settings frame + -- should be configurable TODO!! + pushControlFrame (NH2.EncodeInfo NH2.defaultFlags 0 Nothing) - (NH2.SettingsFrame []) - + (NH2.SettingsFrame [ + (NH2.SettingsMaxConcurrentStreams, 100) + ]) -- And then we continue... - loopPart session_id frame_sent_report_callback + loopPart updateLastInputStream :: GlobalStreamId -> FramerSession () updateLastInputStream stream_id = do last_stream_id_mvar <- view lastInputStream - liftIO $ modifyMVar_ last_stream_id_mvar (\ x -> return $ max x stream_id) - + liftIO $ modifyMVar_ last_stream_id_mvar (\ x -> let y = max x stream_id in y `seq` return y) -updateLastOutputStream :: GlobalStreamId -> FramerSession () -updateLastOutputStream stream_id = do - last_stream_id_mvar <- view lastOutputStream - liftIO $ modifyMVar_ last_stream_id_mvar (\ x -> return $ max x stream_id) +-- updateLastOutputStream :: GlobalStreamId -> FramerSession () +-- updateLastOutputStream stream_id = do +-- last_stream_id_mvar <- view lastOutputStream +-- liftIO $ modifyMVar_ last_stream_id_mvar (\ x -> return $ max x stream_id) -startStreamOutputQueueIfNotExists :: GlobalStreamId -> Int -> FramerSession () -startStreamOutputQueueIfNotExists stream_id priority = do - table_mvar <- view stream2flow - val <- liftIO . withMVar table_mvar $ \ table -> H.lookup table stream_id - case val of - Nothing | stream_id /= 0 -> do - startStreamOutputQueue stream_id priority - return () +-- | Sometimes the browser gives capacity before we even have seen the first +-- data frame going back from here from the server, so the flow control +-- command place should be started first... +startStreamOutputComandQueueIfNeeded :: Int -> FramerSession (Chan FlowControlCommand) +startStreamOutputComandQueueIfNeeded stream_id = + do + stream2flow_mvar <- view stream2flow + liftIO . withMVar stream2flow_mvar $ \s2c -> do + lookup_result <- H.lookup s2c stream_id + case lookup_result of + Nothing -> do + command_chan <- newChan + H.insert s2c stream_id command_chan + return command_chan - _ -> - return () + Just command_chan -> + return command_chan --- Handles only Data frames. -startStreamOutputQueue :: Int -> Int -> FramerSession (MVar LB.ByteString, MVar FlowControlCommand) -startStreamOutputQueue stream_id priority = do - -- New thread for handling outputs of this stream is needed - bytes_chan <- liftIO newEmptyMVar - ordinal_num <- liftIO $ newMVar 0 - command_chan <- liftIO newEmptyMVar - - s2o_mvar <- view stream2outputBytes +-- | Handles only Data frames. +startStreamOutputQueue :: Effect -> MVar OutputDataFeed -> GlobalStreamId -> DeliveryNotifyCallback -> FramerSession () +startStreamOutputQueue effect stream_bytes_mvar stream_id delivery_notify = do - liftIO . withMVar s2o_mvar $ {-# SCC e1 #-} \ s2o -> H.insert s2o stream_id (bytes_chan, ordinal_num) + -- s2o_mvar <- view stream2outputBytes - stream2flow_mvar <- view stream2flow + -- liftIO . withMVar s2o_mvar $ + -- {-# SCC hashtable_e1 #-} \ s2o -> H.insert s2o stream_id (stream_bytes_mvar, ordinal_num) + -- Some commands come before the output of the stream itself, so this may exist already + command_chan <- startStreamOutputComandQueueIfNeeded stream_id - liftIO . withMVar stream2flow_mvar $ {-# SCC e2 #-} \ s2c -> H.insert s2c stream_id command_chan -- initial_cap_mvar <- view defaultStreamWindow initial_cap <- liftIO $ readMVar initial_cap_mvar @@ -686,75 +686,28 @@ sessionExceptionHandler Framer_HTTP2SessionComponent x y e close_action + -- The starting value of the calm, as dicated by the effects + calm_0 = case effect ^. priorityEffect_Ef of + NoEffect_PrEf -> newCalmState 0 [] + Uniform_PrEf default_calm -> newCalmState default_calm [] + PerYield_PrEf start_calm cmap -> newCalmState start_calm cmap read_state <- ask - liftIO $ forkIO $ close_on_error session_id' sessions_context $ runReaderT - ({-# SCC forkFlowControlOutput #-} flowControlOutput stream_id priority initial_cap 0 "" command_chan bytes_chan) - read_state - - return (bytes_chan , command_chan) - - --- This works in the output side of the HTTP/2 framing session, and it acts as a --- semaphore ensuring that headers are output without any interleaved frames. --- --- There are more synchronization mechanisms in Http2.Session that ensure we --- only get here frames from one and the same stream. -handleHeadersOfStream :: NH2.EncodeInfo -> NH2.FramePayload -> FramerSession () -handleHeadersOfStream p1@(NH2.EncodeInfo {}) frame_payload - | frameIsHeadersAndOpensStream frame_payload && not (frameEndsHeaders p1 frame_payload) = do - -- Take it - no_headers <- view noHeadersInChannel - liftIO $ takeMVar no_headers - pushFrame p1 frame_payload - -- Don't put the MvAR HERE - - | frameIsHeadersAndOpensStream frame_payload && frameEndsHeaders p1 frame_payload = do - no_headers <- view noHeadersInChannel - liftIO $ takeMVar no_headers - pushFrame p1 frame_payload - -- Since we finish.... - liftIO $ putMVar no_headers NoHeadersInChannel - - | frameEndsHeaders p1 frame_payload = do - -- I can only get here for a continuation frame after something else that is a headers - no_headers <- view noHeadersInChannel - pushFrame p1 frame_payload - liftIO $ putMVar no_headers NoHeadersInChannel - return () - - | otherwise = - -- Nothing to do with the mvar, the no_headers should be empty - pushFrame p1 frame_payload - - --- Used to know when we need to switch the channel to "exclusive" mode. -frameIsHeadersAndOpensStream :: NH2.FramePayload -> Bool -frameIsHeadersAndOpensStream (NH2.HeadersFrame _ _ ) = True -frameIsHeadersAndOpensStream (NH2.PushPromiseFrame _ _) = True -frameIsHeadersAndOpensStream _ = False - - -frameEndsHeaders :: NH2.EncodeInfo -> NH2.FramePayload -> Bool -frameEndsHeaders (NH2.EncodeInfo flags _ _) (NH2.HeadersFrame _ _) = NH2.testEndHeader flags -frameEndsHeaders (NH2.EncodeInfo flags _ _) (NH2.ContinuationFrame _) = NH2.testEndHeader flags -frameEndsHeaders (NH2.EncodeInfo flags _ _) (NH2.PushPromiseFrame _ _) = NH2.testEndHeader flags -frameEndsHeaders _ _ = False - + _ <- liftIO $ forkIOExc "streamOutputQueue" + $ ignoreException blockedIndefinitelyOnMVar () + $ close_on_error session_id' sessions_context + $ runReaderT (flowControlOutput stream_id initial_cap 0 calm_0 "" command_chan stream_bytes_mvar delivery_notify effect) + read_state --- Push a frame into the output channel... this waits for the --- channel to be free to send. -pushFrame :: NH2.EncodeInfo - -> NH2.FramePayload -> FramerSession () -pushFrame p1 p2 = do - let bs = LB.fromStrict $ NH2.encodeFrame p1 p2 - sendBytes bs + return () pushPrefix :: FramerSession () pushPrefix = do let bs = LB.fromStrict NH2.connectionPreface - sendBytes bs + -- We will send the data, mixing as needed, with the incredible priority + -- of -20 + withPrioritySend_ (-20) 0 0 0 bs -- Default sendGoAwayFrame. This one assumes that actions are taken as soon as stream is @@ -764,69 +717,153 @@ sendGoAwayFrame error_code = do last_stream_id_mvar <- view lastInputStream last_stream_id <- liftIO $ readMVar last_stream_id_mvar - pushFrame + pushGoAwayFrame (NH2.EncodeInfo NH2.defaultFlags 0 Nothing) (NH2.GoAwayFrame last_stream_id error_code "") -sendSpecificTerminateGoAway :: GlobalStreamId -> FramerSession () -sendSpecificTerminateGoAway last_stream = - pushFrame +sendSpecificTerminateGoAway :: GlobalStreamId -> NH2.ErrorCodeId -> FramerSession () +sendSpecificTerminateGoAway last_stream error_code = + pushGoAwayFrame (NH2.EncodeInfo NH2.defaultFlags 0 Nothing) - (NH2.GoAwayFrame last_stream NH2.NoError "") + (NH2.GoAwayFrame last_stream error_code "") --- From this point on data is really serialized, -sendBytes :: LB.ByteString -> FramerSession () -sendBytes bs = do +-- Only one caller to this: the output tray functionality!! +sendBytesN :: LB.ByteString -> FramerSession () +sendBytesN bs = do push_action <- view pushAction -- I don't think I need to lock here... - can_output <- view canOutput - liftIO $ - bs `seq` - C.bracket - (takeMVar can_output) - (const $ push_action bs) - (putMVar can_output) + liftIO $ push_action bs --- A thread in charge of doing flow control transmission....This sends already --- formatted frames (ByteStrings), not the frames themselves. And it doesn't --- mess with the structure of the packets. +-- | A thread in charge of doing flow control transmission....This +-- Reads payload data and formats it to DataFrames... -- --- There is one of these for each stream +-- There is one of these for each stream. -- -flowControlOutput :: Int - -> Int - -> Int - -> Int - -> LB.ByteString - -> MVar FlowControlCommand - -> MVar LB.ByteString - -> FramerSession () -flowControlOutput stream_id priority capacity ordinal leftovers commands_chan bytes_chan = +-- This function will read from an MVar (and block on that), and will write to +-- the output tray (and occassionally also block on that, if the output tray +-- doesn't have enough space). +-- +flowControlOutput :: Int -- Stream id + -> Int -- Capacity + -> Int -- Ordinal + -> CalmState -- Calm + -> LB.ByteString + -> Chan FlowControlCommand + -> MVar OutputDataFeed + -> DeliveryNotifyCallback + -> Effect + -> FramerSession () +flowControlOutput stream_id capacity ordinal calm leftovers commands_chan bytes_chan delivery_notify last_effect = ordinal `seq` if leftovers == "" then {-# SCC fcOBranch1 #-} do - -- Get more data (possibly block waiting for it) + -- Get more data (possibly block waiting for it)... there will be an + -- exception here from time to time... + + -- TODO: If an exception is raised here (because the thread pulling data fromt he Coherent Worker + -- died), it would be a wait on deadlock MVar thingy... in that case take care of ending things + -- properly ... bytes_to_send <- liftIO $ {-# SCC perfectlyHarmlessExceptionPoint #-} takeMVar bytes_chan - flowControlOutput stream_id priority capacity ordinal bytes_to_send commands_chan bytes_chan + let + bytes_length = B.length bytes_to_send + if bytes_length == 0 + then do + -- Signal end of data on stream, format and exit + let + + formatted = LB.fromStrict $ NH2.encodeFrame + (NH2.EncodeInfo { + NH2.encodeFlags = NH2.setEndStream NH2.defaultFlags + ,NH2.encodeStreamId = stream_id + ,NH2.encodePadding = Nothing }) + (NH2.DataFrame "") + + priority = getCurrentCalm calm + + withNormalPrioritySend priority stream_id ordinal formatted + delivery_notify stream_id last_effect ordinal + -- And just before returning, be sure to release the structures related to this + -- stream + finishFlowControlForStream stream_id + else do + -- We have got more data, and we need to send it down the way. Use this space to + -- adjust the calm as required + let + new_calm = advanceCalm calm bytes_length + + -- And now, re-invoke + flowControlOutput + stream_id + capacity + ordinal + new_calm + (LB.fromStrict bytes_to_send) + commands_chan + bytes_chan + delivery_notify + last_effect else {-# SCC fcOBranch2 #-} do - -- Length? - let amount = fromIntegral (LB.length leftovers - 9) - if amount <= capacity + -- Ok, here is the data, from real + let + amount = fromIntegral $ LB.length leftovers + + -- TODO: This hacks forbids the session to handle out larger frames, even if + -- the peer would allow them. + -- The correct way goes through pulling some data from the session: + -- + -- use_size_ioref <- view (sessionSettings_WTE . frameSize_SeS) + -- use_size <- liftIO $ DIO.readIORef use_size_ioref + -- + (use_amount, new_leftover, to_send) = + if amount > 16384 + then (16384, LB.drop 16384 leftovers, LB.take 16384 leftovers) + else (amount, "", leftovers) + + if use_amount <= capacity then do - -- Is - -- I can send ... if no headers are in process.... - -- liftIO . logit $ "set-priority (stream_id, prio, ordinal) " `mappend` (pack . show) (__stream_id, priority, ordinal) - withPrioritySend priority stream_id ordinal leftovers - flowControlOutput stream_id priority (capacity - amount) (ordinal+1 ) "" commands_chan bytes_chan + -- Can send, but must format first... + let + priority = getCurrentCalm calm + formatted = LB.fromStrict $ NH2.encodeFrame + (NH2.EncodeInfo { + NH2.encodeFlags = NH2.defaultFlags + ,NH2.encodeStreamId = stream_id + ,NH2.encodePadding = Nothing + } + ) + (NH2.DataFrame $ LB.toStrict to_send) + withNormalPrioritySend priority stream_id ordinal formatted + -- Notify any interested party about the frame being "delivered" (but it may still be at + -- the latest queue) + delivery_notify stream_id last_effect ordinal + flowControlOutput + stream_id + (capacity - use_amount) + (ordinal+1 ) + calm + new_leftover + commands_chan + bytes_chan + + delivery_notify + last_effect else do -- I can not send because flow-control is full, wait for a command instead - command <- liftIO $ {-# SCC t2 #-} takeMVar commands_chan + command <- liftIO $ {-# SCC t2 #-} readChan commands_chan case {-# SCC t3 #-} command of - AddBytes_FCM delta_cap -> - -- liftIO $ putStrLn $ "Flow control delta_cap stream " ++ (show stream_id) - flowControlOutput stream_id priority (capacity + delta_cap) ordinal leftovers commands_chan bytes_chan + AddBytes_FCM delta_cap -> do + flowControlOutput + stream_id + (capacity + delta_cap) + ordinal + calm + leftovers + commands_chan + bytes_chan + delivery_notify + last_effect releaseFramer :: FramerSession () @@ -837,52 +874,155 @@ return () +-- | Puts output wagons in the tray. This function blocks if there is not +-- enough space in the tray and the system priority is not negative. +-- For negative system priority, the packets are always queued, so that +-- then can be sent as soon as possible. +-- -- This prioritizes DATA packets, in some rudimentary way. -- This code will be replaced in due time for something compliant. -withPrioritySend :: Int -> Int -> Int -> LB.ByteString -> FramerSession () -withPrioritySend priority stream_id packet_ordinal datum = do - PrioritySendState {_semToSend = s, _prioQ = pqm } <- view prioritySendState +-- +-- +-- System priority: +-- -20 : the prefix, absolutely most important guy +-- -15 : A request to close the connection +-- -10 : PING frame +-- -1 : All packets except data packets +-- 0 : data packets. +withPrioritySend_ :: Int -> Int -> Int -> Int -> LB.ByteString -> FramerSession () +withPrioritySend_ system_priority priority stream_id packet_ordinal datum = do + pss <- view prioritySendState let - new_record = PrioPacket ( (priority, stream_id, packet_ordinal), datum) + new_entry = TrayEntry { + _systemPriority_TyE = system_priority -- Ordinary data packets go after everybody else + , _streamPriority_TyE = priority + , _streamOrdinal_TyE = packet_ordinal + , _payload_TyE = datum + , _streamId_TyE = stream_id + } + attempt = do + could_add <- modifyMVar (pss ^. outputTray_PSS) $ \ ot1 -> do + _ <- tryTakeMVar (pss ^. spaceReady_PSS) + let + + filling_level = ot1 ^. filling_OuT + max_length_out = ot1 ^. maxLength_OuT + + very_low_priority = priority >= 512 + (_ot2, lowest_calm_value) = lowestCalmValue ot1 + can_add = if very_low_priority then + ( (max_length_out - filling_level) >= 4 ) && (lowest_calm_value >= priority ) + else + filling_level < max_length_out + + if can_add || (system_priority < (-1) ) + then do + let new_ot = addEntry ot1 new_entry + return (new_ot, True) + else do + return (ot1, False) + if could_add + then do + _ <- tryPutMVar (pss ^. dataReady_PSS) () + return () + else do + readMVar (pss ^. spaceReady_PSS) + attempt -- Now, for this to work, I need to have enough capacity to add something to the queue - liftIO $ do - -- We are using a semaphore to avoid overflowing this place. Notice that the flow - -- control output is till using an unbounded queue!!! - MS.wait s - -- And add it to the queue.... - STM.atomically $ do - pq <- takeTMVar pqm - putTMVar pqm $ PQ.insert new_record pq + liftIO $ attempt --- In charge of actually sending the data frames, in a special thread (create in the caller) +-- | Blocks if there is not enough space in the tray +withNormalPrioritySend :: Int -> Int -> Int -> LB.ByteString -> FramerSession () +withNormalPrioritySend = withPrioritySend_ 0 + + +-- | Blocks if there is not enough space in the tray. +withHighPrioritySend :: LB.ByteString -> FramerSession () +withHighPrioritySend datum = withPrioritySend_ (-1) 0 0 0 datum + +-- Just be sure to send it with some specific priority +goAwaySend :: LB.ByteString -> FramerSession () +goAwaySend datum = + do + withPrioritySend_ goAwayPriority 0 0 0 datum + + +serializeMany :: [OutputFrame] -> LB.ByteString +serializeMany frames = + Bu.toLazyByteString $ mconcat (map (\ (a,b,_) -> Bu.byteString $ NH2.encodeFrame a b ) frames) + +-- Needed here and there +pushControlFrame :: NH2.EncodeInfo -> NH2.FramePayload -> FramerSession () +pushControlFrame frame_encode_info frame_payload = + do + let datum = LB.fromStrict $ NH2.encodeFrame frame_encode_info frame_payload + withHighPrioritySend datum + +-- | Pushes a GoAway frame with the highest priority, so that everything else +-- will be overrided (except perhaps any header trains that are already being sent.) +pushGoAwayFrame :: NH2.EncodeInfo -> NH2.FramePayload -> FramerSession () +pushGoAwayFrame frame_encode_info frame_payload = + do + let datum = LB.fromStrict $ NH2.encodeFrame frame_encode_info frame_payload + goAwaySend datum + + +-- | In charge of actually sending the frames, in a special thread (create said thread +-- in the caller). +-- +-- This thread invokes the data push action, so IOCallbacks problems will bubble as +-- exceptions through this thread. +-- +-- As long as all the pipes connecting components of the system are bound, terminating +-- this function and it's thread should propagate as blocked-indefinitely errors to +-- all the other threads to pipes. sendReordering :: FramerSession () -sendReordering = do - PrioritySendState {_semToSend = s, _prioQ = pqm } <- view prioritySendState - no_headers <- view noHeadersInChannel - -- Get a packet, if possible, or wait for it - PrioPacket ( (priority_, stream_id, packed_ordinal_), datum) <- liftIO . STM.atomically $ do - pq <- takeTMVar pqm - if PQ.null pq - then STM.retry - else do - let - (record, thinner) = PQ.deleteFindMin pq - putTMVar pqm thinner - return record - -- liftIO . logit $ "prio-send (prio,stream_id, ordinal) " `mappend` (pack . show) (priority, stream_id, packed_ordinal_) - -- Since I got something to send, I can let one of the guys to put more stuff - liftIO $ MS.signal s - -- Now we do the tries and locks for headers - C.bracket - (liftIO $ takeMVar no_headers) - (\ _ -> liftIO $ putMVar no_headers NoHeadersInChannel) - (\ _ -> sendBytes datum ) +sendReordering = {-# SCC sndReo #-} do + pss <- view prioritySendState + close_action <- view closeAction + use_size <- view (sessionsContext . sessionsConfig . networkChunkSize) + -- Get a set of packets (that is, their reprs) to send + let - -- Sleep for a little bit, we dont' want too many frames - -- here too fast. BIG TODO: We need a better way to handle this - liftIO $ replicateM_ 10 CC.yield - --liftIO $ threadDelay 100 + get_sendable_data = do + maybe_entries <- modifyMVar (pss ^. outputTray_PSS) $ \ ot1 -> do + _ <- tryTakeMVar (pss ^. dataReady_PSS) + if (ot1 ^. filling_OuT) <= 0 + then do + return (ot1 ,Nothing) + else do + let + (ot2, entries) = splitOverSize use_size ot1 + return (ot2, Just entries) - -- And tail-recurse - sendReordering + case maybe_entries of + Just entries -> do + -- The entries vector is already sorted by priority. if the first entry + -- has priority goAwayPriority, it means that we should only send that one and close + -- the connection immediately.... + -- + -- Also, this code should guarantee that no empty vector is ever seen + -- here (look for the (ot1 ^. filling_OuT) line above) + -- liftIO $ putStrLn $ "sent " ++ (show . length $ entries ) + _ <- tryPutMVar (pss ^. spaceReady_PSS) () + let + first_entry = head entries + if first_entry ^. systemPriority_TyE == goAwayPriority + then + return . Left $ first_entry ^. payload_TyE + else + return . Right . Bu.toLazyByteString . mconcat . map (Bu.lazyByteString . ( ^. payload_TyE) ) $ entries + Nothing -> do + _ <- readMVar (pss ^. dataReady_PSS) + get_sendable_data + either_entries_data <- liftIO get_sendable_data + case either_entries_data of + Right entries_data -> do + sendBytesN entries_data + sendReordering + + Left entries_data -> do + sendBytesN entries_data + liftIO $ putStrLn "AboutToProduceCleanClose" + liftIO close_action diff --git a/hs-src/SecondTransfer/Http2/MakeAttendant.hs b/hs-src/SecondTransfer/Http2/MakeAttendant.hs --- a/hs-src/SecondTransfer/Http2/MakeAttendant.hs +++ b/hs-src/SecondTransfer/Http2/MakeAttendant.hs @@ -7,15 +7,19 @@ import SecondTransfer.Http2.Framer (wrapSession, SessionPayload(..)) import SecondTransfer.Sessions.Internal (SessionsContext) import SecondTransfer.MainLoop.CoherentWorker -import SecondTransfer.MainLoop.PushPullType (Attendant) +import SecondTransfer.IOCallbacks.Types (Attendant) + -- | -- --- Given an `AwareWorker`, this function wraps it with flow control, multiplexing, +-- @ +-- http2Attendant :: AwareWorker -> AttendantCallbacks -> IO () +-- @ +-- +-- Given a `AwareWorker`, this function wraps it with flow control, multiplexing, -- and state maintenance needed to run an HTTP/2 session. -- --- Notice that this function is using HTTP/2 over TLS. There is an equivalent for HTTP --- 1.1. +-- Notice that this function is using HTTP/2 over TLS. http2Attendant :: SessionsContext -> AwareWorker -> Attendant http2Attendant sessions_context coherent_worker attendant_callbacks = do let diff --git a/hs-src/SecondTransfer/Http2/OutputTray.hs b/hs-src/SecondTransfer/Http2/OutputTray.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Http2/OutputTray.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +module SecondTransfer.Http2.OutputTray ( + TrayEntry (..) + , systemPriority_TyE + , streamPriority_TyE + , streamOrdinal_TyE + , payload_TyE + , streamId_TyE + + , OutputTray (..) + , filling_OuT + , maxLength_OuT + , entries_OuT + + , newOutputTray + , splitOverSize + , addEntry + , lowestCalmValue + ) where + +import Control.Lens +--import Control.Concurrent + +-- import qualified Data.Vector.Mutable as MVec +import qualified Data.Vector as DVec +import qualified Data.Vector.Algorithms.Merge as Dam + + +--import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB + + +-- | The output tray.... all data is sorted according to the priority +-- assigned here .... +-- +-- +-- System priorities: 0 for data frames +-- -1 for header and other HTTP/2 low level +-- -2 for go-away frame. The deliverer is expected to close +-- the connection inmmediately after. +-- - something_else for the PingFrame (have to look it put) +-- +-- Stream Ordinary priorities are assigned by the worker. +-- +data TrayEntry = TrayEntry { + _systemPriority_TyE :: !Int + , _streamPriority_TyE :: !Int + , _streamOrdinal_TyE :: !Int + + -- Informative .... + , _payload_TyE :: !LB.ByteString + , _streamId_TyE :: !Int + -- Maybe: delivery callback + } + deriving (Show) + +makeLenses ''TrayEntry + +type EntryListBuilder = [TrayEntry] -> [TrayEntry] + +data OutputTray = OutputTray { + _filling_OuT :: Int + , _maxLength_OuT :: Int + , _entries_OuT :: !EntryListBuilder + } + +makeLenses ''OutputTray + +trayCompareKey :: TrayEntry -> (Int, Int) +trayCompareKey te = + (te ^. systemPriority_TyE, te ^. streamPriority_TyE ) + + +trayEntryCompare :: TrayEntry -> TrayEntry -> Ordering +trayEntryCompare te0 te1 = compare (trayCompareKey te0) (trayCompareKey te1) + + +newOutputTray :: Int -> OutputTray +newOutputTray max_length = + OutputTray { + _filling_OuT = 0 + , _maxLength_OuT = max_length + , _entries_OuT = id + } + + +-- You are in carge of protecting the access to the tray! +addEntry :: OutputTray -> TrayEntry -> OutputTray +addEntry tray entry = + let + ot1 = over entries_OuT ( . (entry : ) ) tray + ot2 = over filling_OuT ( + 1 ) ot1 + in ot2 + + +-- Returns the highest value of the calm (aka priority). +-- Unfortunately fetching this value drops the structure into a concrete +-- state.... +lowestCalmValue :: OutputTray -> (OutputTray, Int) +lowestCalmValue output_tray = + let + entries_list = (output_tray ^. entries_OuT) [] + + result = foldl (\ hc entry -> + let + stream_priority = entry ^. streamPriority_TyE + in if (entry ^. systemPriority_TyE >= 0) + && + stream_priority < hc + then + stream_priority + else + hc + ) ( 4000000000 ) entries_list + + new_tray_fn incoming = + foldr (:) incoming entries_list + + new_tray = + set entries_OuT new_tray_fn output_tray + in (new_tray, result ) + + +splitOverSize :: Int -> OutputTray -> (OutputTray, [TrayEntry]) +splitOverSize sz ot0 = + let + entries_list = (ot0 ^. entries_OuT) [] + -- First let's get a vector from here + entries_vector = DVec.fromList entries_list + had_entries_count = DVec.length entries_vector + -- Then let's sort it, stably so that ordinals are automatically + -- kept (otherwise the data will break), but system and high priority + -- ones go before everybody else + sorted_entries :: DVec.Vector TrayEntry + sorted_entries = + DVec.modify + (\ mvec -> Dam.sortBy trayEntryCompare mvec) + entries_vector + + -- And let' returns the ones which are interesting.... + go :: Int -> Int -> Int + go taken_size idx + | taken_size < sz && idx < DVec.length sorted_entries + = go (taken_size + (sorted_entries DVec.! idx) ^. payload_TyE . to (fromIntegral . LB.length) ) (idx+1) + | taken_size >= sz + = idx + | otherwise + = idx + + take_this_many = go 0 0 + entries_to_take = DVec.toList . DVec.take take_this_many $ sorted_entries + entries_to_leave = DVec.drop take_this_many sorted_entries + + entries_to_leave_list_builder :: [TrayEntry] -> [TrayEntry] + entries_to_leave_list_builder incoming = DVec.foldr' (:) incoming entries_to_leave + new_tray = + (set filling_OuT (had_entries_count - take_this_many) ) . + (set entries_OuT entries_to_leave_list_builder) + $ ot0 + in (new_tray, entries_to_take) diff --git a/hs-src/SecondTransfer/Http2/Session.hs b/hs-src/SecondTransfer/Http2/Session.hs --- a/hs-src/SecondTransfer/Http2/Session.hs +++ b/hs-src/SecondTransfer/Http2/Session.hs @@ -1,1809 +1,1979 @@ -- Session: links frames to streams, and helps in ordering the header frames -- so that they don't get mixed with header frames from other streams when -- resources are being served concurrently. -{-# LANGUAGE FlexibleContexts, Rank2Types, TemplateHaskell, OverloadedStrings #-} -{-# OPTIONS_HADDOCK hide #-} -module SecondTransfer.Http2.Session( - http2ServerSession - ,http2ClientSession - ,getFrameFromSession - ,sendFirstFrameToSession - ,sendMiddleFrameToSession - ,sendCommandToSession - ,makeClientState - ,pendingRequests_ClS - - ,CoherentSession - ,SessionInput(..) - ,SessionInputCommand(..) - ,SessionOutput(..) - ,SessionOutputCommand(..) - ,SessionCoordinates(..) - ,SessionComponent(..) - ,SessionsCallbacks(..) - ,SessionsConfig(..) - ,ErrorCallback - ,ClientState(..) - ,SessionRole(..) - - -- Internal stuff - ,OutputFrame - ,InputFrame - ) where - -#include "Logging.cpphs" - --- System grade utilities -import Control.Concurrent (ThreadId, forkIO) -import Control.Concurrent.Chan -import Control.Exception (throwTo) -import qualified Control.Exception as E -import Control.Monad (forever,unless, when, mapM_, forM, forM_) -import Control.Monad.IO.Class (liftIO) -import Control.DeepSeq ( ($!!), deepseq ) -import Control.Monad.Trans.Reader --- import Control.Monad.Catch (throwM) - -import Control.Concurrent.MVar -import qualified Data.ByteString as B -import Data.ByteString.Char8 (pack,unpack) -import qualified Data.ByteString.Builder as Bu -import qualified Data.ByteString.Lazy as Bl -import Data.Conduit -import qualified Data.HashTable.IO as H -import qualified Data.IntSet as NS -import Data.Maybe (isJust) -import Data.Typeable -#ifndef IMPLICIT_MONOID -import Data.Monoid (mappend) -#endif - -import Control.Lens - --- No framing layer here... let's use Kazu's Yamamoto library -import qualified Network.HPACK as HP -import qualified Network.HTTP2 as NH2 - --- Logging utilities -import System.Log.Logger - -import System.Clock (getTime, TimeSpec, Clock(..)) - --- Imports from other parts of the program -import SecondTransfer.MainLoop.CoherentWorker -import SecondTransfer.MainLoop.Tokens -import SecondTransfer.MainLoop.Protocol -import SecondTransfer.MainLoop.ClientPetitioner - -import SecondTransfer.Sessions.Config -import SecondTransfer.Sessions.Internal (sessionExceptionHandler, - SessionsContext, - sessionsConfig) -import SecondTransfer.Utils (unfoldChannelAndSource) -import SecondTransfer.Exception -import qualified SecondTransfer.Utils.HTTPHeaders as He -import SecondTransfer.MainLoop.Logging (logit) - ---import Debug.Trace - --- Unfortunately the frame encoding API of Network.HTTP2 is a bit difficult to --- use :-( -type OutputFrame = (NH2.EncodeInfo, NH2.FramePayload, Effect) -type InputFrame = NH2.Frame - - ---useChunkLength :: Int --- useChunkLength = 2048 - - --- Singleton instance used for concurrency -data HeadersSent = HeadersSent - --- All streams put their data bits here. A "Nothing" value signals --- end of data. Middle value is delay in microseconds -type DataOutputToConveyor = (GlobalStreamId, Maybe B.ByteString, Effect) - --- What to do regarding headers -data HeaderOutputMessage = - -- Send the headers of the principal stream - NormalResponse_HM (GlobalStreamId, MVar HeadersSent, Headers, Effect) - -- Send a push-promise - |PushPromise_HM (GlobalStreamId, GlobalStreamId, Headers, Effect) - -- Send a reset stream notification for the stream given below - |ResetStream_HM (GlobalStreamId, Effect) - -- Send a GoAway, where last-stream is the stream given below. - |GoAway_HM (GlobalStreamId, Effect) - - --- Settings imposed by the peer -data SessionSettings = SessionSettings { - _pushEnabled :: Bool - } - -makeLenses ''SessionSettings - - - --- Whatever a worker thread is going to need comes here.... --- this is to make refactoring easier, but not strictly needed. -data WorkerThreadEnvironment = WorkerThreadEnvironment { - -- What's the header stream id? - _streamId :: GlobalStreamId - - -- A full block of headers can come here... the mvar in the middle should - -- be populate to signal end of headers transmission. A thread will be suspended - -- waiting for that - , _headersOutput :: Chan HeaderOutputMessage - - -- And regular contents can come this way and thus be properly mixed - -- with everything else.... for now... - ,_dataOutput :: MVar DataOutputToConveyor - - ,_streamsCancelled_WTE :: MVar NS.IntSet - - ,_sessionSettings_WTE :: MVar SessionSettings - - ,_nextPushStream_WTE :: MVar Int - } - -makeLenses ''WorkerThreadEnvironment - - --- An HTTP/2 session. Basically a couple of channels ... -type Session = (SessionInput, SessionOutput) - - --- From outside, one can only write to this one ... the newtype is to enforce --- this. -newtype SessionInput = SessionInput ( Chan SessionInputCommand ) -sendMiddleFrameToSession :: SessionInput -> InputFrame -> IO () -sendMiddleFrameToSession (SessionInput chan) frame = writeChan chan $ MiddleFrame_SIC frame - -sendFirstFrameToSession :: SessionInput -> InputFrame -> IO () -sendFirstFrameToSession (SessionInput chan) frame = writeChan chan $ FirstFrame_SIC frame - -sendCommandToSession :: SessionInput -> SessionInputCommand -> IO () -sendCommandToSession (SessionInput chan) command = writeChan chan command - -type SessionOutputPacket = Either SessionOutputCommand OutputFrame - -type SessionOutputChannelAbstraction = Chan SessionOutputPacket - --- From outside, one can only read from this one -newtype SessionOutput = SessionOutput SessionOutputChannelAbstraction -getFrameFromSession :: SessionOutput -> IO SessionOutputPacket -getFrameFromSession (SessionOutput chan) = readChan chan - - -type HashTable k v = H.CuckooHashTable k v - - -type Stream2HeaderBlockFragment = HashTable GlobalStreamId Bu.Builder - - -type WorkerMonad = ReaderT WorkerThreadEnvironment IO - - --- Have to figure out which are these...but I would expect to have things --- like unexpected aborts here in this type. -data SessionInputCommand = - FirstFrame_SIC InputFrame -- This frame is special - |MiddleFrame_SIC InputFrame -- Ordinary frame - |InternalAbort_SIC -- Internal abort from the session itself - |CancelSession_SIC -- Cancel request from the framer - deriving Show - - --- Session output commands indicating something to the Framer -data SessionOutputCommand = - -- Command sent to the framer to close the session as harshly as possible. The framer - -- will pick its own last valid stream. - CancelSession_SOC NH2.ErrorCodeId - -- Command sent to the framer to close the session specifying a specific last-stream. - -- The reason used will be "NoError" - |SpecificTerminate_SOC GlobalStreamId - -- Command sent to the framer to notify it of a normal end of stream - -- condition, this is used to naturally close each stream. - |FinishStream_SOC GlobalStreamId - deriving Show - - --- The role of a session is either server or client. There are small --- differences between both. -data SessionRole = - Client_SR - |Server_SR - deriving (Eq,Show) - --- Here is how we make a session -type SessionMaker = SessionsContext -> IO Session - - --- Here is how we make a session wrapping a CoherentWorker -type CoherentSession = AwareWorker -> SessionMaker - -data PostInputMechanism = PostInputMechanism (MVar (Maybe B.ByteString), InputDataStream) - -------------- Regarding client state -type Message = (Headers,InputDataStream) - -type RequestResult = Either ConnectionCloseReason Message - -data ClientState = ClientState { - -- Holds a queue. The client here puts the message (the request) and an VAR - -- where it will receive the response. - _pendingRequests_ClS :: MVar (Message, MVar RequestResult) - - -- This is the id of the next available stream - ,_nextStream_ClS :: MVar Int - - -- Says if the client has been closed - ,_clientIsClosed_ClS :: MVar Bool - - -- A dictionary from stream id to the client which is waiting for the - -- message - ,_response2Waiter_ClS ::HashTable GlobalStreamId (MVar RequestResult) - } - -makeLenses ''ClientState - - -makeClientState :: IO ClientState -makeClientState = do - request_chan <- newEmptyMVar - next_stream_mvar <- newMVar 3 - client_is_closed_mvar <- newMVar False - new_h <- H.new - - return ClientState { - _pendingRequests_ClS = request_chan - ,_nextStream_ClS = next_stream_mvar - ,_response2Waiter_ClS = new_h - ,_clientIsClosed_ClS = client_is_closed_mvar - } - - -handleRequest' :: ClientState -> Headers -> InputDataStream -> IO (Headers,InputDataStream) -handleRequest' client_state headers input_data = runReaderT (handleRequest headers input_data) client_state - -type ClientMonad = ReaderT ClientState IO - -handleRequest :: Headers -> InputDataStream -> ClientMonad Message -handleRequest headers input_data = do - pending_requests <- view pendingRequests_ClS - response_mvar <- liftIO $ newEmptyMVar - - liftIO $ E.catch - (do - {-# SCC cause1 #-} putMVar pending_requests ((headers,input_data),response_mvar) - either_reason_or_message <- {-# SCC cause2 #-} liftIO $ takeMVar response_mvar - case either_reason_or_message of - Left break_reason -> E.throw $ ClientSessionAbortedException break_reason - Right message -> return message - ) - ( ( \ _ -> E.throw $ ClientSessionAbortedException SessionAlreadyClosed_CCR ):: E.BlockedIndefinitelyOnMVar -> IO Message ) - - - - -instance ClientPetitioner ClientState where - - request = handleRequest' - --------------- Regarding client state - - --- SessionData is the actual state of the session, including the channels to the framer --- outside. --- --- NH2.Frame != Frame -data SessionData = SessionData { - -- ATTENTION: Ignore the warning coming from here for now - _sessionsContext :: SessionsContext - - ,_sessionInput :: Chan SessionInputCommand - - -- We need to lock this channel occassionally so that we can order multiple - -- header frames properly....that's the reason for the outer MVar - ,_sessionOutput :: MVar SessionOutputChannelAbstraction - - -- Use to encode - ,_toEncodeHeaders :: MVar HP.DynamicTable - - -- And used to decode - ,_toDecodeHeaders :: MVar HP.DynamicTable - - -- While I'm receiving headers, anything which - -- is not a header should end in the connection being - -- closed - ,_receivingHeaders :: MVar (Maybe Int) - - -- _lastGoodStream is used both to report the last good stream in the - -- GoAwayFrame and to keep track of streams oppened by the client. In - -- other words, it contains the stream_id of the last valid client - -- stream and is updated as soon as the first frame of that stream is - -- received. - ,_lastGoodStream :: MVar Int - - -- Used for decoding the headers - ,_stream2HeaderBlockFragment :: Stream2HeaderBlockFragment - - -- Used for worker threads... this is actually a pre-filled template - -- I make copies of it in different contexts, and as needed. - ,_forWorkerThread :: WorkerThreadEnvironment - - -- When acting as a server, this is the handler for processing requests - ,_awareWorker :: AwareWorker - - -- When acting as a client, this is where new requests are taken - -- from - ,_simpleClient :: ClientState - - -- Some streams may be cancelled - ,_streamsCancelled :: MVar NS.IntSet - - -- Data input mechanism corresponding to some threads - ,_stream2PostInputMechanism :: HashTable Int PostInputMechanism - - -- Worker thread register. This is a dictionary from stream id to - -- the ThreadId of the thread with the worker thread. I use this to - -- raise asynchronous exceptions in the worker thread if the stream - -- is cancelled by the client. This way we get early finalization. - ,_stream2WorkerThread :: HashTable Int ThreadId - - -- Use to retrieve/set the session id - ,_sessionIdAtSession :: Int - - -- And used to keep peer session settings - ,_sessionSettings :: MVar SessionSettings - - -- What is the next stream available for push? - ,_nextPushStream :: MVar Int - - -- What role does this session has? - ,_sessionRole :: SessionRole - - } - - -makeLenses ''SessionData - - -http2ServerSession :: AwareWorker -> Int -> SessionsContext -> IO Session -http2ServerSession a i sctx = http2Session Server_SR a (error "NotAClient") i sctx - - -http2ClientSession :: ClientState -> Int -> SessionsContext -> IO Session -http2ClientSession client_state session_id sctx = - http2Session Client_SR (error "NotAServer") client_state session_id sctx - - --- v- {headers table size comes here!!} -http2Session :: SessionRole -> AwareWorker -> ClientState -> Int -> SessionsContext -> IO Session -http2Session session_role aware_worker client_state session_id sessions_context = do - session_input <- newChan - session_output <- newChan - session_output_mvar <- newMVar session_output - - - -- For incremental construction of headers... - stream_request_headers <- H.new :: IO Stream2HeaderBlockFragment - - -- Warning: we should find a way of coping with different table sizes. - decode_headers_table <- HP.newDynamicTableForDecoding 4096 - decode_headers_table_mvar <- newMVar decode_headers_table - - encode_headers_table <- HP.newDynamicTableForEncoding 4096 - encode_headers_table_mvar <- newMVar encode_headers_table - - -- These ones need independent threads taking care of sending stuff - -- their way... - headers_output <- newChan :: IO (Chan HeaderOutputMessage) - data_output <- newEmptyMVar :: IO (MVar DataOutputToConveyor) - - stream2postinputmechanism <- H.new - stream2workerthread <- H.new - last_good_stream_mvar <- newMVar (-1) - - receiving_headers <- newMVar Nothing - session_settings <- newMVar $ SessionSettings { _pushEnabled = True } - next_push_stream <- newMVar 8 - - -- What about stream cancellation? - cancelled_streams_mvar <- newMVar $ NS.empty :: IO (MVar NS.IntSet) - - let for_worker_thread = WorkerThreadEnvironment { - _streamId = error "NotInitialized" - ,_headersOutput = headers_output - ,_dataOutput = data_output - ,_streamsCancelled_WTE = cancelled_streams_mvar - ,_sessionSettings_WTE = session_settings - ,_nextPushStream_WTE = next_push_stream - } - - let session_data = SessionData { - _sessionsContext = sessions_context - ,_sessionInput = session_input - ,_sessionOutput = session_output_mvar - ,_toDecodeHeaders = decode_headers_table_mvar - ,_toEncodeHeaders = encode_headers_table_mvar - ,_stream2HeaderBlockFragment = stream_request_headers - ,_forWorkerThread = for_worker_thread - ,_awareWorker = aware_worker - ,_simpleClient = client_state - ,_streamsCancelled = cancelled_streams_mvar - ,_stream2PostInputMechanism = stream2postinputmechanism - ,_stream2WorkerThread = stream2workerthread - ,_sessionIdAtSession = session_id - ,_receivingHeaders = receiving_headers - ,_sessionSettings = session_settings - ,_lastGoodStream = last_good_stream_mvar - ,_nextPushStream = next_push_stream - ,_sessionRole = session_role - } - - let - io_exc_handler :: SessionComponent -> E.BlockedIndefinitelyOnMVar -> IO () - io_exc_handler _component _e = do - case session_role of - Server_SR -> do - -- sessionExceptionHandler component session_id sessions_context e - -- Just ignore this kind of exceptions here, very explicitly, as they should naturally - -- happen when the framer is closed - return () - - Client_SR -> do - clientSideTerminate client_state IOChannelClosed_CCR - - - exc_handler :: SessionComponent -> HTTP2SessionException -> IO () - exc_handler component e = do - case session_role of - Server_SR -> - sessionExceptionHandler component session_id sessions_context e - - Client_SR -> do - let - maybe_client_session_aborted :: Maybe ClientSessionAbortedException - maybe_client_session_aborted | HTTP2SessionException ee <- e = cast ee - - maybe_protocol_error :: Maybe HTTP2ProtocolException - maybe_protocol_error | HTTP2SessionException ee <- e = cast ee - - case maybe_client_session_aborted of - Just (ClientSessionAbortedException reason) -> do - clientSideTerminate client_state reason - - - Nothing -> - if isJust maybe_protocol_error - then - clientSideTerminate client_state ProtocolError_CCR - else do - E.throw e - - exc_guard :: SessionComponent -> IO () -> IO () - exc_guard component action = - E.catch - (E.catch - action - (\e -> do - -- INSTRUMENTATION( errorM "HTTP2.Session" "Exception processed" ) - exc_handler component e - ) - ) - (io_exc_handler component) - - use_chunk_length = sessions_context ^. sessionsConfig . dataFrameSize - - -- Create an input thread that decodes frames... - forkIO $ exc_guard SessionInputThread_HTTP2SessionComponent - $ runReaderT sessionInputThread session_data - - -- Create a thread that captures headers and sends them down the tube - forkIO $ exc_guard SessionHeadersOutputThread_HTTP2SessionComponent - $ runReaderT (headersOutputThread headers_output session_output_mvar) session_data - - -- Create a thread that captures data and sends it down the tube. This is waiting for - -- stuff coming from all the workers. This function is also in charge of closing streams - forkIO $ exc_guard SessionDataOutputThread_HTTP2SessionComponent - $ dataOutputThread use_chunk_length data_output session_output_mvar - - -- If I'm a client, I also need a thread to poll for requests - when (session_role == Client_SR) $ do - forkIO $ exc_guard SessionClientPollThread_HTTP2SessionComponent - $ sessionPollThread session_data headers_output - return () - - - -- The two previous threads fill the session_output argument below (they write to it) - -- the session machinery in the other end is in charge of sending that data through the - -- socket. - - return ( (SessionInput session_input), - (SessionOutput session_output) ) - - --- TODO: Some ill clients can break this thread with exceptions. Make these paths a bit ---- more robust. -sessionInputThread :: ReaderT SessionData IO () -sessionInputThread = do - -- This is an introductory and declarative block... all of this is tail-executed - -- every time that a packet needs to be processed. It may be a good idea to abstract - -- these values in a closure... - session_input <- view sessionInput - - -- decode_headers_table_mvar <- view toDecodeHeaders - -- stream_request_headers <- view stream2HeaderBlockFragment - cancelled_streams_mvar <- view streamsCancelled - -- coherent_worker <- view awareWorker - - -- for_worker_thread_uns <- view forWorkerThread - stream2workerthread <- view stream2WorkerThread - -- receiving_headers_mvar <- view receivingHeaders - -- last_good_stream_mvar <- view lastGoodStream - -- current_session_id <- view sessionIdAtSession - - input <- {-# SCC session_input #-} liftIO $ readChan session_input - session_role <- view sessionRole - - case input of - - FirstFrame_SIC (NH2.Frame - (NH2.FrameHeader _ 1 null_stream_id ) _ )| 0 == null_stream_id -> do - -- This is a SETTINGS ACK frame, which is okej to have, - -- do nothing here - continue - - FirstFrame_SIC - (NH2.Frame - (NH2.FrameHeader _ 0 null_stream_id ) - (NH2.SettingsFrame settings_list) - ) | 0 == null_stream_id -> do - -- Good, handle - handleSettingsFrame settings_list - continue - - FirstFrame_SIC _ -> do - -- Bad, incorrect id or god knows only what .... - closeConnectionBecauseIsInvalid NH2.ProtocolError - return () - - CancelSession_SIC -> do - -- Good place to tear down worker threads... Let the rest of the finalization - -- to the framer. - -- - -- This message is normally got from the Framer - liftIO $ do - H.mapM_ - (\ (_, thread_id) -> do - throwTo thread_id StreamCancelledException - return () - ) - stream2workerthread - - -- We do not continue here, but instead let it finish - return () - - InternalAbort_SIC -> do - -- Message triggered because the worker failed to behave. - -- When this is sent, the connection is closed - closeConnectionBecauseIsInvalid NH2.InternalError - return () - - -- The block below will process both HEADERS and CONTINUATION frames. - -- TODO: As it stands now, the server will happily start a new stream with - -- a CONTINUATION frame instead of a HEADERS frame. That's against the - -- protocol. - MiddleFrame_SIC frame | Just (_stream_id, _bytes) <- isAboutHeaders frame -> - case session_role of - Server_SR -> do - -- Just append the frames to streamRequestHeaders - serverProcessIncomingHeaders frame - continue - - Client_SR -> do - clientProcessIncomingHeaders frame - continue - - -- Peer can order a stream aborted, meaning that we shall not send any more data - -- on it. - MiddleFrame_SIC frame@(NH2.Frame _ (NH2.RSTStreamFrame _error_code_id)) -> do - let stream_id = streamIdFromFrame frame - liftIO $ do - -- INSTRUMENTATION( infoM "HTTP2.Session" $ "Stream reset: " ++ (show _error_code_id) ) - cancelled_streams <- takeMVar cancelled_streams_mvar - -- INSTRUMENTATION( infoM "HTTP2.Session" $ "Cancelled stream was: " ++ (show stream_id) ) - putMVar cancelled_streams_mvar $ NS.insert stream_id cancelled_streams - maybe_thread_id <- H.lookup stream2workerthread stream_id - case maybe_thread_id of - Nothing -> - -- This is can actually happen in some implementations: we are asked to - -- cancel an stream we know nothing about. Log which stream it is - logit $ "InterruptingUnexistentStream " `mappend` (pack . show $ stream_id) - -- and don't get too crazy about it. - - Just thread_id -> do - -- INSTRUMENTATION( infoM "HTTP2.Session" $ "Stream successfully interrupted" ) - throwTo thread_id StreamCancelledException - - continue - - MiddleFrame_SIC frame@(NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.DataFrame somebytes)) - -> unlessReceivingHeaders $ do - -- So I got data to process - -- TODO: Handle end of stream - let stream_id = nh2_stream_id - -- TODO: Handle the cases where the stream_id doesn't match an already existent - -- stream. In such cases it is justified to reset the connection with a protocol_error. - - streamWorkerSendData stream_id somebytes - -- After that data has been received and forwarded downstream, we can issue a windows update - -- - -- TODO: We can use wider frames to avoid congestion... - -- .... and we can also be more compositional with these short bursts of data.... - -- - -- TODO: Consider that the best place to output these frames can be somewhere else... - -- - -- TODO: Use a special, with-quota queue here to do flow control. Don't send meaningless - -- WindowUpdateFrame's - sendOutFrame - (NH2.EncodeInfo - NH2.defaultFlags - nh2_stream_id - Nothing - ) - (NH2.WindowUpdateFrame - (fromIntegral (B.length somebytes)) - ) - - sendOutFrame - (NH2.EncodeInfo - NH2.defaultFlags - 0 - Nothing - ) - (NH2.WindowUpdateFrame - (fromIntegral (B.length somebytes)) - ) - - if frameEndsStream frame - then do - -- Good place to close the source ... - closePostDataSource stream_id - else - return () - - continue - - MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ flags _) (NH2.PingFrame _)) | NH2.testAck flags-> do - -- Deal with pings: this is an Ack, so do nothing - continue - - MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ _ _) (NH2.PingFrame somebytes)) -> do - -- Deal with pings: NOT an Ack, so answer - -- INSTRUMENTATION( debugM "HTTP2.Session" "Ping processed" ) - sendOutFrame - (NH2.EncodeInfo - (NH2.setAck NH2.defaultFlags) - 0 - Nothing - ) - (NH2.PingFrame somebytes) - - - continue - - MiddleFrame_SIC (NH2.Frame frame_header (NH2.SettingsFrame _)) | isSettingsAck frame_header -> do - -- Frame was received by the peer, do nothing here... - continue - - -- TODO: Do something with these settings!! - MiddleFrame_SIC (NH2.Frame _ (NH2.SettingsFrame settings_list)) -> do - -- INSTRUMENTATION( debugM "HTTP2.Session" $ "Received settings: " ++ (show settings_list) ) - -- Just acknowledge the frame.... for now - handleSettingsFrame settings_list - continue - - MiddleFrame_SIC (NH2.Frame _ (NH2.GoAwayFrame _ _ _ )) - | Server_SR <- session_role -> do - -- I was sent a go away, so go-away... - closeConnectionBecauseIsInvalid NH2.NoError - return () - - | Client_SR <- session_role -> do - -- I was sent a go away, so go-away, but use the kind of exception - -- that will unwind the stack gracefully - closeConnectionForClient NH2.NoError - return () - - - MiddleFrame_SIC somethingelse -> unlessReceivingHeaders $ do - -- An undhandled case here.... - -- liftIO . logit $ "Strange frame:" `mappend` (pack . show $ somethingelse) - continue - - where - continue = sessionInputThread - - -- TODO: Do use the settings!!! - handleSettingsFrame :: NH2.SettingsList -> ReaderT SessionData IO () - handleSettingsFrame _settings_list = do - let - enable_push = lookup NH2.SettingsEnablePush _settings_list - session_settings_mvar <- view sessionSettings - case enable_push of - Just 1 -> liftIO $ modifyMVar_ session_settings_mvar - $ \ old_settings -> return ( pushEnabled .~ True $ old_settings) - Just 0 -> liftIO $ modifyMVar_ session_settings_mvar - $ \ old_settings -> return ( pushEnabled .~ False $ old_settings) - Just _ -> closeConnectionBecauseIsInvalid NH2.ProtocolError - - Nothing -> return () - -- liftIO $ logit $ "Settings " `mappend` (pack . show $ _settings_list) - sendOutFrame - (NH2.EncodeInfo - (NH2.setAck NH2.defaultFlags) - 0 - Nothing - ) - (NH2.SettingsFrame []) - - -serverProcessIncomingHeaders :: NH2.Frame -> ReaderT SessionData IO () -serverProcessIncomingHeaders frame | Just (stream_id, bytes) <- isAboutHeaders frame = do - - -- Just append the frames to streamRequestHeaders - opens_stream <- appendHeaderFragmentBlock stream_id bytes - receiving_headers_mvar <- view receivingHeaders - last_good_stream_mvar <- view lastGoodStream - for_worker_thread_uns <- view forWorkerThread - decode_headers_table_mvar <- view toDecodeHeaders - stream_request_headers <- view stream2HeaderBlockFragment - coherent_worker <- view awareWorker - current_session_id <- view sessionIdAtSession - session_input <- view sessionInput - stream2workerthread <- view stream2WorkerThread - - if opens_stream - then do - maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar - case maybe_rcv_headers_of of - Just _ -> do - -- Bad peer, it is already sending headers - -- and trying to open another one - {-# SCC ccB1 #-} closeConnectionBecauseIsInvalid NH2.ProtocolError - -- An exception will be thrown above, so to not complicate - -- control flow here too much. - Nothing -> do - -- Signal that we are receiving headers now, for this stream - liftIO $ putMVar receiving_headers_mvar (Just stream_id) - -- And go to check if the stream id is valid - last_good_stream <- liftIO $ takeMVar last_good_stream_mvar - if (odd stream_id ) && (stream_id > last_good_stream) - then do - -- We are golden, set the new good stream - liftIO $ putMVar last_good_stream_mvar (stream_id) - else do - -- We are not golden - -- INSTRUMENTATION( errorM "HTTP2.Session" "Protocol error: bad stream id") - {-# SCC ccB2 #-} closeConnectionBecauseIsInvalid NH2.ProtocolError - -- So, now we know, we are ignoring priority frames at the moment - -- liftIO . logit $ "Priority: " `mappend` (pack . show $ getHeadersPriority frame) - else do - maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar - case maybe_rcv_headers_of of - Just a_stream_id | a_stream_id == stream_id -> do - -- Nothing to complain about - liftIO $ putMVar receiving_headers_mvar maybe_rcv_headers_of - - Nothing -> error "InternalError, this should be set" - - if frameEndsHeaders frame then - do - -- Ok, let it be known that we are not receiving more headers - liftIO $ modifyMVar_ - receiving_headers_mvar - (\ _ -> return Nothing ) - -- Lets get a time - headers_arrived_time <- liftIO $ getTime Monotonic - -- Let's decode the headers - let for_worker_thread = set streamId stream_id for_worker_thread_uns - headers_bytes <- getHeaderBytes stream_id - dyn_table <- liftIO $ takeMVar decode_headers_table_mvar - (new_table, header_list ) <- liftIO $ HP.decodeHeader dyn_table headers_bytes -#if LOGIT_SWITCH_TIMINGS - let - (Just path) = He.fetchHeader header_list ":path" - liftIO $ logit $ (pack . show $ stream_id ) `mappend` " -> " `mappend` path -#endif - -- /DEBUG - -- Good moment to remove the headers from the table.... we don't want a space - -- leak here - liftIO $ do - H.delete stream_request_headers stream_id - putMVar decode_headers_table_mvar new_table - - -- TODO: Validate headers, abort session if the headers are invalid. - -- Otherwise other invariants will break!! - -- THIS IS PROBABLY THE BEST PLACE FOR DOING IT. - let - headers_editor = He.fromList header_list - - maybe_good_headers_editor <- validateIncomingHeadersServer headers_editor - - good_headers <- case maybe_good_headers_editor of - Just yes_they_are_good -> return yes_they_are_good - Nothing -> {-# SCC ccB3 #-} closeConnectionBecauseIsInvalid NH2.ProtocolError - - -- Add any extra headers, on demand - headers_extra_good <- addExtraHeaders good_headers - let - header_list_after = He.toList headers_extra_good - -- liftIO $ putStrLn $ "header list after " ++ (show header_list_after) - - -- If the headers end the request.... - post_data_source <- if not (frameEndsStream frame) - then do - mechanism <- createMechanismForStream stream_id - let source = postDataSourceFromMechanism mechanism - return $ Just source - else do - return Nothing - - let - perception = Perception { - _startedTime_Pr = headers_arrived_time, - _streamId_Pr = stream_id, - _sessionId_Pr = current_session_id, - _protocol_Pr = Http2_HPV, - _anouncedProtocols_Pr = Nothing - } - request = Request { - _headers_RQ = header_list_after, - _inputData_RQ = post_data_source, - _perception_RQ = perception - } - - -- TODO: Handle the cases where a request tries to send data - -- even if the method doesn't allow for data. - - -- I'm clear to start the worker, in its own thread - -- - -- NOTE: Some late internal errors from the worker thread are - -- handled here by clossing the session. - -- - -- TODO: Log exceptions handled here. - liftIO $ do - thread_id <- forkIO $ E.catch - (runReaderT - (workerThread - request - coherent_worker) - for_worker_thread - ) - ( - ( \ _ -> do - -- Actions to take when the thread breaks.... - writeChan session_input InternalAbort_SIC - ) - :: HTTP500PrecursorException -> IO () - ) - - H.insert stream2workerthread stream_id thread_id - - return () - else - -- Frame doesn't end the headers... it was added before... so - -- probably do nothing - return () - - -clientProcessIncomingHeaders :: NH2.Frame -> ReaderT SessionData IO () -clientProcessIncomingHeaders frame | Just (stream_id, bytes) <- isAboutHeaders frame = do - - opens_stream <- appendHeaderFragmentBlock stream_id bytes - receiving_headers_mvar <- view receivingHeaders - last_good_stream_mvar <- view lastGoodStream - decode_headers_table_mvar <- view toDecodeHeaders - stream_request_headers <- view stream2HeaderBlockFragment - response2waiter <- view (simpleClient . response2Waiter_ClS) - - if opens_stream - then do - maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar - case maybe_rcv_headers_of of - Just _ -> do - -- Bad peer, it is already sending headers - -- and trying to open another one - closeConnectionBecauseIsInvalid NH2.ProtocolError - -- An exception will be thrown above, so to not complicate - -- control flow here too much. - Nothing -> do - -- Signal that we are receiving headers now, for this stream - liftIO $ putMVar receiving_headers_mvar (Just stream_id) - -- And go to check if the stream id is valid - last_good_stream <- liftIO $ takeMVar last_good_stream_mvar - stream_initiated_by_client <- streamInitiatedByClient stream_id - if (odd stream_id ) && stream_initiated_by_client - then do - -- We are golden, set the new good stream - liftIO $ putMVar last_good_stream_mvar (stream_id) - else do - -- We are not golden - -- TODO: Control for pushed streams here. - closeConnectionBecauseIsInvalid NH2.ProtocolError - -- So, now we know, we are ignoring priority frames at the moment - -- liftIO . logit $ "Priority: " `mappend` (pack . show $ getHeadersPriority frame) - else do - maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar - case maybe_rcv_headers_of of - Just a_stream_id | a_stream_id == stream_id -> do - -- Nothing to complain about - liftIO $ putMVar receiving_headers_mvar maybe_rcv_headers_of - - Nothing -> error "InternalError, this should be set" - - if frameEndsHeaders frame then - do - -- Ok, let it be known that we are not receiving more headers - liftIO $ modifyMVar_ - receiving_headers_mvar - (\ _ -> return Nothing ) - -- Lets get a time - -- headers_arrived_time <- liftIO $ getTime Monotonic - -- Let's decode the headers - headers_bytes <- getHeaderBytes stream_id - dyn_table <- liftIO $ takeMVar decode_headers_table_mvar - (new_table, header_list ) <- liftIO $ HP.decodeHeader dyn_table headers_bytes - - -- Good moment to remove the headers from the table.... we don't want a space - -- leak here - liftIO $ do - H.delete stream_request_headers stream_id - putMVar decode_headers_table_mvar new_table - - -- TODO: Validate headers, abort session if the headers are invalid. - -- Otherwise other invariants will break!! - -- THIS IS PROBABLY THE BEST PLACE FOR DOING IT. - let - headers_editor = He.fromList header_list - - maybe_good_headers_editor <- validateIncomingHeadersClient headers_editor - - good_headers <- case maybe_good_headers_editor of - Just yes_they_are_good -> return yes_they_are_good - Nothing -> closeConnectionBecauseIsInvalid NH2.ProtocolError - - - -- If the headers end the request.... - post_data_source <- if not (frameEndsStream frame) - then do - mechanism <- createMechanismForStream stream_id - return $ postDataSourceFromMechanism mechanism - else - return $ return () - - (Just response_mvar) <- liftIO $ H.lookup response2waiter stream_id - liftIO $ putMVar response_mvar $ Right (He.toList good_headers, post_data_source) - - return () - else - -- Frame doesn't end the headers... it was added before... so - -- probably do nothing - return () - - -streamInitiatedByClient :: GlobalStreamId -> ReaderT SessionData IO Bool -streamInitiatedByClient stream_id = do - response2waiter <- view (simpleClient . response2Waiter_ClS) - response_handle_maybe <- liftIO $ H.lookup response2waiter stream_id - return $ isJust response_handle_maybe - - -sendOutFrame :: NH2.EncodeInfo -> NH2.FramePayload -> ReaderT SessionData IO () -sendOutFrame encode_info payload = do - session_output_mvar <- view sessionOutput - - session_output <- liftIO $ takeMVar session_output_mvar - liftIO $ writeChan session_output $ Right ( - encode_info, - payload, - -- Not sending effects in this frame, since it is not related... - error "sendOutFrameNotFor") - liftIO $ putMVar session_output_mvar session_output - - --- TODO: This function, but using the headers editor, triggers --- some renormalization of the header order. A good thing, if --- I get that order well enough.... -addExtraHeaders :: He.HeaderEditor -> ReaderT SessionData IO He.HeaderEditor -addExtraHeaders headers_editor = do - let - enriched_lens = (sessionsContext . sessionsConfig .sessionsEnrichedHeaders ) - -- TODO: Figure out which is the best way to put this contact in the - -- source code - protocol_lens = He.headerLens "second-transfer-eh--used-protocol" - - add_used_protocol <- view (enriched_lens . addUsedProtocol ) - - -- liftIO $ putStrLn $ "AAA" ++ (show add_used_protocol) - - let - he1 = if add_used_protocol - then set protocol_lens (Just "HTTP/2") headers_editor - else headers_editor - - if add_used_protocol - -- Nothing will be computed here if the headers are not modified. - then return he1 - else return headers_editor - - --- TODO: Close connection on unexepcted pseudo-headers -validateIncomingHeadersServer :: He.HeaderEditor -> ReaderT SessionData IO (Maybe He.HeaderEditor) -validateIncomingHeadersServer headers_editor = do - -- Check that the headers block comes with all mandatory headers. - -- Right now I'm not checking that they come in the mandatory order though... - -- - -- Notice that this function will transform a "host" header to an ":authority" - -- one. - let - h1 = He.replaceHostByAuthority headers_editor - -- Check that headers are lowercase - headers_are_lowercase = He.headersAreLowercaseAtHeaderEditor headers_editor - -- Check that we have mandatory headers - maybe_authority = h1 ^. (He.headerLens ":authority") - maybe_method = h1 ^. (He.headerLens ":method") - maybe_scheme = h1 ^. (He.headerLens ":scheme") - maybe_path = h1 ^. (He.headerLens ":path") - - if - (isJust maybe_authority) && - (isJust maybe_method) && - (isJust maybe_scheme) && - (isJust maybe_path ) - then - return (Just h1) - else - return Nothing - -validateIncomingHeadersClient :: He.HeaderEditor -> ReaderT SessionData IO (Maybe He.HeaderEditor) -validateIncomingHeadersClient headers_editor = do - -- Check that the headers block comes with all mandatory headers. - -- Right now I'm not checking that they come in the mandatory order though... - -- - -- Notice that this function will transform a "host" header to an ":authority" - -- one. - let - h1 = He.replaceHostByAuthority headers_editor - -- Check that headers are lowercase - headers_are_lowercase = He.headersAreLowercaseAtHeaderEditor headers_editor - -- Check that we have mandatory headers - maybe_status = h1 ^. (He.headerLens ":status") - - if (isJust maybe_status) - then - return (Just h1) - else - return Nothing - - --- Sends a GO_AWAY frame and raises an exception, effectively terminating the input --- thread of the session. -closeConnectionBecauseIsInvalid :: NH2.ErrorCodeId -> ReaderT SessionData IO a -closeConnectionBecauseIsInvalid error_code = do - -- liftIO $ errorM "HTTP2.Session" "closeConnectionBecauseIsInvalid called!" - last_good_stream_mvar <- view lastGoodStream - last_good_stream <- liftIO $ takeMVar last_good_stream_mvar - session_output_mvar <- view sessionOutput - stream2workerthread <- view stream2WorkerThread - sendOutFrame - (NH2.EncodeInfo - NH2.defaultFlags - 0 - Nothing - ) - (NH2.GoAwayFrame - last_good_stream - error_code - "" - ) - - liftIO $ do - -- Close all active threads for this session - H.mapM_ - ( \(_stream_id, thread_id) -> - throwTo thread_id StreamCancelledException - ) - stream2workerthread - - -- Notify the framer that the session is closing, so - -- that it stops accepting frames from connected sources - -- (Streams?) - session_output <- takeMVar session_output_mvar - writeChan session_output $ Left (CancelSession_SOC error_code) - putMVar session_output_mvar session_output - - -- And unwind the input thread in the session, so that the - -- exception handler runs.... - E.throw HTTP2ProtocolException - - --- Sends a GO_AWAY frame and raises an exception, effectively terminating the input --- thread of the session. This one for the client is different because it throws --- an exception of type ClientSessionAbortedException -closeConnectionForClient :: NH2.ErrorCodeId -> ReaderT SessionData IO a -closeConnectionForClient error_code = do - let - use_reason = case error_code of - NH2.NoError -> NormalTermination_CCR - _ -> ProtocolError_CCR - - -- liftIO $ errorM "HTTP2.Session" "closeConnectionBecauseIsInvalid called!" - last_good_stream_mvar <- view lastGoodStream - last_good_stream <- liftIO $ takeMVar last_good_stream_mvar - session_output_mvar <- view sessionOutput - stream2workerthread <- view stream2WorkerThread - sendOutFrame - (NH2.EncodeInfo - NH2.defaultFlags - 0 - Nothing - ) - (NH2.GoAwayFrame - last_good_stream - error_code - "" - ) - - client_is_closed_mvar <- view (simpleClient . clientIsClosed_ClS ) - - liftIO $ do - -- Close all active threads for this session - H.mapM_ - ( \(_stream_id, thread_id) -> - throwTo thread_id StreamCancelledException - ) - stream2workerthread - - -- Notify the framer that the session is closing, so - -- that it stops accepting frames from connected sources - -- (Streams?) - session_output <- takeMVar session_output_mvar - writeChan session_output . Left . CancelSession_SOC $ error_code - putMVar session_output_mvar session_output - - -- Let's also mark the session as closed from the client side, so that - -- any further requests end with the correct exception - modifyMVar_ client_is_closed_mvar (\ _ -> return True) - - -- And unwind the input thread in the session, so that the - -- exception handler runs.... - E.throw $ ClientSessionAbortedException use_reason - - -frameEndsStream :: InputFrame -> Bool -frameEndsStream (NH2.Frame (NH2.FrameHeader _ flags _) _) = NH2.testEndStream flags - - --- Executes its argument, unless receiving --- headers, in which case the connection is closed. -unlessReceivingHeaders :: ReaderT SessionData IO a -> ReaderT SessionData IO a -unlessReceivingHeaders comp = do - receiving_headers_mvar <- view receivingHeaders - -- First check if we are receiving headers - maybe_recv_headers <- liftIO $ readMVar receiving_headers_mvar - if isJust maybe_recv_headers - then - -- So, this frame is highly illegal - closeConnectionBecauseIsInvalid NH2.ProtocolError - else - comp - - -createMechanismForStream :: GlobalStreamId -> ReaderT SessionData IO PostInputMechanism -createMechanismForStream stream_id = do - (chan, source) <- liftIO $ unfoldChannelAndSource - stream2postinputmechanism <- view stream2PostInputMechanism - let pim = PostInputMechanism (chan, source) - liftIO $ H.insert stream2postinputmechanism stream_id pim - return pim - - --- TODO: Can be optimized by factoring out the mechanism lookup --- TODO IMPORTANT: This is a good place to drop the postinputmechanism --- for a stream, so that unprocessed data can be garbage-collected. -closePostDataSource :: GlobalStreamId -> ReaderT SessionData IO () -closePostDataSource stream_id = do - stream2postinputmechanism <- view stream2PostInputMechanism - - pim_maybe <- liftIO $ H.lookup stream2postinputmechanism stream_id - - case pim_maybe of - - Just (PostInputMechanism (chan, _)) -> - liftIO $ do - putMVar chan Nothing - -- Not sure if this will work - H.delete stream2postinputmechanism stream_id - - Nothing -> - -- TODO: This is a protocol error, handle it properly - error "Internal error/closePostDataSource" - - -streamWorkerSendData :: Int -> B.ByteString -> ReaderT SessionData IO () -streamWorkerSendData stream_id bytes = do - s2pim <- view stream2PostInputMechanism - pim_maybe <- liftIO $ H.lookup s2pim stream_id - - case pim_maybe of - - Just pim -> - sendBytesToPim pim bytes - - Nothing -> - -- This is an internal error, the mechanism should be - -- created when the headers end (and if the headers - -- do not finish the stream) - error "Internal error" - - -sendBytesToPim :: PostInputMechanism -> B.ByteString -> ReaderT SessionData IO () -sendBytesToPim (PostInputMechanism (chan, _)) bytes = - liftIO $ putMVar chan (Just bytes) - - -postDataSourceFromMechanism :: PostInputMechanism -> InputDataStream -postDataSourceFromMechanism (PostInputMechanism (_, source)) = source - - -isSettingsAck :: NH2.FrameHeader -> Bool -isSettingsAck (NH2.FrameHeader _ flags _) = - NH2.testAck flags - - -isStreamCancelled :: GlobalStreamId -> WorkerMonad Bool -isStreamCancelled stream_id = do - cancelled_streams_mvar <- view streamsCancelled_WTE - cancelled_streams <- liftIO $ readMVar cancelled_streams_mvar - return $ NS.member stream_id cancelled_streams - - -sendPrimitive500Error :: IO TupledPrincipalStream -sendPrimitive500Error = - return ( - [ - (":status", "500") - ], - [], - do - yield "Internal server error\n" - -- No footers - return [] - ) - - --- Invokes the Coherent worker. Data is sent through pipes to --- the output thread here in this session. -workerThread :: Request -> AwareWorker -> WorkerMonad () -workerThread req aware_worker = - do - headers_output <- view headersOutput - stream_id <- view streamId - session_settings_mvar <- view sessionSettings_WTE - session_settings <- liftIO $ readMVar session_settings_mvar - next_push_stream_mvar <- view nextPushStream_WTE - - -- TODO: Handle exceptions here: what happens if the coherent worker - -- throws an exception signaling that the request is ill-formed - -- and should be dropped? That could happen in a couple of occassions, - -- but really most cases should be handled here in this file... -#if LOGIT_SWITCH_TIMINGS - liftIO . logit $ "worker-thread " `mappend` (pack . show $ stream_id) -#endif - -- (headers, _, data_and_conclussion) - principal_stream <- - liftIO $ E.catch - ( - aware_worker req - ) - ( - const $ tupledPrincipalStreamToPrincipalStream <$> sendPrimitive500Error - :: HTTP500PrecursorException -> IO PrincipalStream - ) - - -- Pieces of the header - let - effects = principal_stream ^. effect_PS - interrupt_maybe = effects ^. interrupt_Ef - - - - case interrupt_maybe of - - Nothing -> do - normallyHandleStream principal_stream - - Just (InterruptConnectionAfter_IEf) -> do - normallyHandleStream principal_stream - liftIO . writeChan headers_output $ GoAway_HM (stream_id, effects) - - Just (InterruptConnectionNow_IEf) -> do - -- Not one hundred-percent sure of this being correct, but we don't want - -- to acknowledge reception of this stream then - let use_stream_id = stream_id - 1 - liftIO . writeChan headers_output $ GoAway_HM (use_stream_id, effects) - - -normallyHandleStream :: PrincipalStream -> WorkerMonad () -normallyHandleStream principal_stream = do - headers_output <- view headersOutput - stream_id <- view streamId - session_settings_mvar <- view sessionSettings_WTE - session_settings <- liftIO $ readMVar session_settings_mvar - next_push_stream_mvar <- view nextPushStream_WTE - - -- Pieces of the header - let - headers = principal_stream ^. headers_PS - data_and_conclusion = principal_stream ^. dataAndConclusion_PS - effects = principal_stream ^. effect_PS - pushed_streams = principal_stream ^. pushedStreams_PS - - can_push = session_settings ^. pushEnabled - - -- This gets executed in normal conditions, when no interruption is required. - - -- There are several possible moments where the PUSH_PROMISEs can be sent, - -- but a default safe one is before sending the response HEADERS, so that - -- LINK headers in the response come after any potential promises. - data_promises <- if can_push then do - forM pushed_streams $ \ pushed_stream_comp -> do - -- Initialize pushed stream - pushed_stream <- liftIO pushed_stream_comp - -- Send the request headers properly wrapped in a "Push Promise", do - -- it before sending the actual response headers of this stream - let - request_headers = pushed_stream ^. requestHeaders_Psh - response_headers = pushed_stream ^. responseHeaders_Psh - pushed_data_and_conclusion = pushed_stream ^. dataAndConclusion_Psh - - child_stream_id <- liftIO $ modifyMVar next_push_stream_mvar - $ (\ x -> return (x+2,x) ) - - liftIO . writeChan headers_output . PushPromise_HM $ - (stream_id, child_stream_id, request_headers, effects) - return (child_stream_id, response_headers, pushed_data_and_conclusion, effects) - else - return [] - - - - -- Now I send the headers, if that's possible at all - headers_sent <- liftIO newEmptyMVar - liftIO $ writeChan headers_output $ NormalResponse_HM (stream_id, headers_sent, headers, effects) - - -- At this moment I should ask if the stream hasn't been cancelled by the browser before - -- commiting to the work of sending addtitional data... this is important for pushed - -- streams - is_stream_cancelled <- isStreamCancelled stream_id - unless is_stream_cancelled $ do - -- I have a beautiful source that I can de-construct... - -- TODO: Optionally pulling data out from a Conduit .... - -- liftIO ( data_and_conclussion $$ (_sendDataOfStream stream_id) ) - -- - -- This threadlet should block here waiting for the headers to finish going - -- NOTE: Exceptions generated here inheriting from HTTP500PrecursorException - -- are let to bubble and managed in this thread fork point... - (_maybe_footers, _) <- runConduit $ - transPipe liftIO data_and_conclusion - `fuseBothMaybe` - sendDataOfStream stream_id headers_sent effects - -- BIG TODO: Send the footers ... likely stream conclusion semantics - -- will need to be changed. - - -- Now, time to fork threads for the pusher streams .... - forM_ data_promises - $ \ (child_stream_id, response_headers, pushed_data_and_conclusion, effects) -> do - environment <- ask - let - action = pusherThread - child_stream_id - response_headers - pushed_data_and_conclusion - effects - -- And let the action run in its own thread - liftIO . forkIO $ runReaderT action environment - - return () - - - --- Invokes the Coherent worker. Data is sent through pipes to --- the output thread here in this session. -pusherThread :: GlobalStreamId -> Headers -> DataAndConclusion -> Effect -> WorkerMonad () -pusherThread child_stream_id response_headers pushed_data_and_conclusion effects = - do - headers_output <- view headersOutput - session_settings_mvar <- view sessionSettings_WTE - session_settings <- liftIO $ readMVar session_settings_mvar - - -- TODO: Handle exceptions here: what happens if the coherent worker - -- throws an exception signaling that the request is ill-formed - -- and should be dropped? That could happen in a couple of occassions, - -- but really most cases should be handled here in this file... - -- (headers, _, data_and_conclussion) - - - -- Now I send the headers, if that's possible at all - headers_sent <- liftIO newEmptyMVar - liftIO . writeChan headers_output - $ NormalResponse_HM (child_stream_id, headers_sent, response_headers, effects) - - -- At this moment I should ask if the stream hasn't been cancelled by the browser before - -- commiting to the work of sending addtitional data... this is important for pushed - -- streams - is_stream_cancelled <- isStreamCancelled child_stream_id - unless is_stream_cancelled $ do - -- I have a beautiful source that I can de-construct... - -- TODO: Optionally pulling data out from a Conduit .... - -- liftIO ( data_and_conclussion $$ (_sendDataOfStream stream_id) ) - -- - -- This threadlet should block here waiting for the headers to finish going - -- NOTE: Exceptions generated here inheriting from HTTP500PrecursorException - -- are let to bubble and managed in this thread fork point... - (_maybe_footers, _) <- runConduit $ - transPipe liftIO pushed_data_and_conclusion - `fuseBothMaybe` - sendDataOfStream child_stream_id headers_sent effects - -- BIG TODO: Send the footers ... likely stream conclusion semantics - -- will need to be changed. - - return () - - - --- v-- comp. monad. -sendDataOfStream :: GlobalStreamId -> MVar HeadersSent -> Effect -> Sink B.ByteString (ReaderT WorkerThreadEnvironment IO) () -sendDataOfStream stream_id headers_sent effect = do - data_output <- view dataOutput - -- Wait for all headers sent - liftIO $ takeMVar headers_sent - consumer data_output - where - --delay = effect ^. middlePauseForDelivery_Ef - consumer data_output = do - maybe_bytes <- await - case maybe_bytes of - Nothing -> - -- This is how we finish sending data - liftIO $ putMVar data_output (stream_id, Nothing, effect) - Just bytes - | B.length bytes > 0 -> do - liftIO $ do - putMVar data_output (stream_id, Just bytes, effect) - consumer data_output - | otherwise -> - liftIO $ putMVar data_output (stream_id, Nothing, effect) - - --- Returns if the frame is the first in the stream -appendHeaderFragmentBlock :: GlobalStreamId -> B.ByteString -> ReaderT SessionData IO Bool -appendHeaderFragmentBlock global_stream_id bytes = do - ht <- view stream2HeaderBlockFragment - maybe_old_block <- liftIO $ H.lookup ht global_stream_id - (new_block, new_stream) <- case maybe_old_block of - - Nothing -> do - -- TODO: Make the commented message below more informative - return $ (Bu.byteString bytes, True) - - Just something -> - return $ (something `mappend` (Bu.byteString bytes), False) - - liftIO $ H.insert ht global_stream_id new_block - return new_stream - -getHeaderBytes :: GlobalStreamId -> ReaderT SessionData IO B.ByteString -getHeaderBytes global_stream_id = do - ht <- view stream2HeaderBlockFragment - Just bytes <- liftIO $ H.lookup ht global_stream_id - return $ Bl.toStrict $ Bu.toLazyByteString bytes - - -isAboutHeaders :: InputFrame -> Maybe (GlobalStreamId, B.ByteString) -isAboutHeaders (NH2.Frame (NH2.FrameHeader _ _ stream_id) ( NH2.HeadersFrame _ block_fragment ) ) - = Just (stream_id, block_fragment) -isAboutHeaders (NH2.Frame (NH2.FrameHeader _ _ stream_id) ( NH2.ContinuationFrame block_fragment) ) - = Just (stream_id, block_fragment) -isAboutHeaders _ - = Nothing - - -getHeadersPriority :: InputFrame -> Maybe NH2.Priority -getHeadersPriority (NH2.Frame _ ( NH2.HeadersFrame prio _ ) ) = prio -getHeadersPriority _ = Nothing - - -frameEndsHeaders :: InputFrame -> Bool -frameEndsHeaders (NH2.Frame (NH2.FrameHeader _ flags _) _) = NH2.testEndHeader flags - - -streamIdFromFrame :: InputFrame -> GlobalStreamId -streamIdFromFrame (NH2.Frame (NH2.FrameHeader _ _ stream_id) _) = stream_id - - --- TODO: Have different size for the headers..... just now going with a default size of 16 k... --- TODO: Find a way to kill this thread.... -headersOutputThread :: Chan HeaderOutputMessage -- (GlobalStreamId, MVar HeadersSent, Headers, Effect) - -> MVar SessionOutputChannelAbstraction - -> ReaderT SessionData IO () -headersOutputThread input_chan session_output_mvar = forever $ do - - use_chunk_length <- view $ sessionsContext . sessionsConfig . dataFrameSize - - header_output_request <- {-# SCC input_chan #-} liftIO $ readChan input_chan - {-# SCC case_ #-} case header_output_request of - NormalResponse_HM (stream_id, headers_ready_mvar, headers, effect) -> do - - -- First encode the headers using the table - encode_dyn_table_mvar <- view toEncodeHeaders - - encode_dyn_table <- liftIO $ takeMVar encode_dyn_table_mvar - (new_dyn_table, data_to_send ) <- liftIO $ HP.encodeHeader HP.defaultEncodeStrategy encode_dyn_table headers - liftIO $ putMVar encode_dyn_table_mvar new_dyn_table - - -- Now split the bytestring in chunks of the needed size.... - -- Note that the only way we can - let - bs_chunks = bytestringChunk use_chunk_length data_to_send - - -- And send the chunks through while locking the output place.... - liftIO $ bs_chunks `deepseq` E.bracket - (takeMVar session_output_mvar) - (putMVar session_output_mvar ) - (\ session_output -> do - writeIndividualHeaderFrames session_output stream_id bs_chunks True effect - -- And say that the headers for this thread are out - -- INSTRUMENTATION( debugM "HTTP2.Session" $ "Headers were output for stream " ++ (show stream_id) ) - putMVar headers_ready_mvar HeadersSent - ) - - GoAway_HM (stream_id, _effect) -> do - -- This is in charge of sending an interrupt message to the framer - let - message = Left (SpecificTerminate_SOC stream_id) - liftIO . withMVar session_output_mvar $ - (\session_output -> do - writeChan session_output message - ) - - PushPromise_HM (parent_stream_id, child_stream_id, promise_headers, effect) -> do - - encode_dyn_table_mvar <- view toEncodeHeaders - encode_dyn_table <- liftIO $ takeMVar encode_dyn_table_mvar - - (new_dyn_table, data_to_send ) <- liftIO $ HP.encodeHeader HP.defaultEncodeStrategy encode_dyn_table promise_headers - liftIO $ putMVar encode_dyn_table_mvar new_dyn_table - - -- Now split the bytestring in chunks of the needed size.... - bs_chunks <- return $! bytestringChunk use_chunk_length data_to_send - - -- And send the chunks through while locking the output place.... - liftIO $ E.bracket - (takeMVar session_output_mvar) - (putMVar session_output_mvar ) - (\ session_output -> do - writePushPromiseFrames session_output parent_stream_id child_stream_id bs_chunks True effect - -- No notification here... but since everyhing headers is serialized here and the next - -- piece of information corresponding to the child stream is a headers sequence, we shouldn't - -- need any other tricks here - ) - - - where - writeIndividualHeaderFrames :: - SessionOutputChannelAbstraction - -> GlobalStreamId - -> [B.ByteString] - -> Bool - -> Effect - -> IO () - writeIndividualHeaderFrames session_output stream_id (last_fragment:[]) is_first effect = - writeChan session_output $ Right ( NH2.EncodeInfo { - NH2.encodeFlags = NH2.setEndHeader NH2.defaultFlags - ,NH2.encodeStreamId = stream_id - ,NH2.encodePadding = Nothing }, - (if is_first then NH2.HeadersFrame Nothing last_fragment else NH2.ContinuationFrame last_fragment), - effect - ) - writeIndividualHeaderFrames session_output stream_id (fragment:xs) is_first effect = do - writeChan session_output $ Right ( NH2.EncodeInfo { - NH2.encodeFlags = NH2.defaultFlags - ,NH2.encodeStreamId = stream_id - ,NH2.encodePadding = Nothing }, - (if is_first then NH2.HeadersFrame Nothing fragment else NH2.ContinuationFrame fragment), - effect - ) - writeIndividualHeaderFrames session_output stream_id xs False effect - - writePushPromiseFrames :: - SessionOutputChannelAbstraction - -> GlobalStreamId - -> GlobalStreamId - -> [B.ByteString] - -> Bool - -> Effect - -> IO () - writePushPromiseFrames session_output parent_stream_id child_stream_id (last_fragment:[]) is_first effect = - writeChan session_output $ Right ( NH2.EncodeInfo { - NH2.encodeFlags = NH2.setEndHeader NH2.defaultFlags - ,NH2.encodeStreamId = parent_stream_id - ,NH2.encodePadding = Nothing }, - (if is_first - then NH2.PushPromiseFrame child_stream_id last_fragment - else NH2.ContinuationFrame last_fragment - ), - effect - ) - writePushPromiseFrames session_output parent_stream_id child_stream_id (fragment:xs) is_first effect = do - writeChan session_output $ Right ( NH2.EncodeInfo { - NH2.encodeFlags = NH2.defaultFlags - ,NH2.encodeStreamId = parent_stream_id - ,NH2.encodePadding = Nothing }, - (if is_first - then NH2.PushPromiseFrame child_stream_id fragment - else NH2.ContinuationFrame fragment - ), - effect - ) - writePushPromiseFrames session_output parent_stream_id child_stream_id xs False effect - - -bytestringChunk :: Int -> B.ByteString -> [B.ByteString] -bytestringChunk len s | (B.length s) < len = [ s ] -bytestringChunk len s = h:(bytestringChunk len xs) - where - (h, xs) = B.splitAt len s - - --- This thread is for the entire session, not for each stream. The thread should --- die while waiting for input in a garbage-collected mvar. --- TODO: This function does non-optimal chunking for the case where responses are --- actually streamed.... in those cases we need to keep state for frames in --- some other format.... --- TODO: Right now, we are transmitting an empty last frame with the end-of-stream --- flag set. I'm afraid that the only --- way to avoid that is by holding a frame or by augmenting the end-user interface --- so that the user can signal which one is the last frame. The first approach --- restricts responsiviness, the second one clutters things. -dataOutputThread :: Int - -> MVar DataOutputToConveyor - -> MVar SessionOutputChannelAbstraction - -> IO () -dataOutputThread use_chunk_length input_chan session_output_mvar = forever $ do - (stream_id, maybe_contents, effect) <- takeMVar input_chan - case maybe_contents of - Nothing -> do - liftIO $ do - withLockedSessionOutput - (\ session_output -> do - -- Write an empty data-frame with the right flags - writeChan session_output $ Right ( NH2.EncodeInfo { - NH2.encodeFlags = NH2.setEndStream NH2.defaultFlags - ,NH2.encodeStreamId = stream_id - ,NH2.encodePadding = Nothing }, - NH2.DataFrame "", - effect - ) - -- And then write an-end-of-stream command - writeChan session_output $ Left . FinishStream_SOC $ stream_id - ) - - Just contents -> do - -- And now just simply output it... - let bs_chunks = bytestringChunk use_chunk_length contents - -- And send the chunks through while locking the output place.... - bs_chunks `deepseq` writeContinuations bs_chunks stream_id effect - return () - - where - - withLockedSessionOutput = E.bracket - (takeMVar session_output_mvar) - (putMVar session_output_mvar) -- <-- There is an implicit argument there!! - - writeContinuations :: [B.ByteString] -> GlobalStreamId -> Effect -> IO () - writeContinuations fragments stream_id effect = - mapM_ (\ fragment -> - withLockedSessionOutput - (\ session_output -> do - -- TODO: - when (B.length fragment == use_chunk_length) $ do - -- Force tons and tons of ping frames to see if we get less delays due to - -- congestion... - writeChan session_output $ Right ( - NH2.EncodeInfo { - NH2.encodeFlags = NH2.defaultFlags - ,NH2.encodeStreamId = 0 - ,NH2.encodePadding = Nothing - }, - NH2.PingFrame "talk on", - effect ) - - writeChan session_output $ Right ( - NH2.EncodeInfo { - NH2.encodeFlags = NH2.defaultFlags - ,NH2.encodeStreamId = stream_id - ,NH2.encodePadding = Nothing - }, - NH2.DataFrame fragment, - effect ) - ) - ) - fragments - - -sessionPollThread :: SessionData -> Chan HeaderOutputMessage -> IO () -sessionPollThread session_data headers_output = do - let - pending_requests_mvar = session_data ^. (simpleClient . pendingRequests_ClS) - client_next_stream_mvar = session_data ^. (simpleClient . nextStream_ClS) - response2waiter = session_data ^. (simpleClient . response2Waiter_ClS) - for_worker_thread = session_data ^. forWorkerThread - session_input = session_data ^. sessionInput - - ((headers, input_data_stream), response_mvar) <- takeMVar pending_requests_mvar - - new_stream_id <- modifyMVar client_next_stream_mvar (\ n -> return (n + 1, n) ) - let - worker_environment = set streamId new_stream_id for_worker_thread - effects = defaultEffects - - -- Store the response place - new_stream_id `seq` H.insert response2waiter new_stream_id response_mvar - - -- Start by sending the headers of the request - headers_sent <- liftIO newEmptyMVar - liftIO $ writeChan headers_output $ NormalResponse_HM (new_stream_id, headers_sent, headers, effects) - - liftIO . forkIO $ E.catch - (runReaderT - (clientWorkerThread new_stream_id effects headers_sent input_data_stream ) - worker_environment - ) - ( - ( \ _ -> do - -- Actions to take when the thread breaks.... - writeChan session_input InternalAbort_SIC - ) - :: HTTP500PrecursorException -> IO () - ) - - sessionPollThread session_data headers_output - - -clientWorkerThread :: GlobalStreamId -> Effect -> MVar HeadersSent -> InputDataStream -> WorkerMonad () -clientWorkerThread stream_id effects headers_sent input_data_stream = do - -- And now work on sending the data, if any... - runConduit $ - transPipe liftIO input_data_stream - `fuseBothMaybe` - sendDataOfStream stream_id headers_sent effects - return () - - -clientSideTerminate :: ClientState -> ConnectionCloseReason -> IO () -clientSideTerminate client_state reason = do - let - terminateOnQueue :: ConnectionCloseReason -> MVar (Message, MVar RequestResult) -> IO () - terminateOnQueue reason' q = do - w <- tryTakeMVar q - case w of - Just (_, m) -> do - tryPutMVar m (Left reason') +{-# LANGUAGE FlexibleContexts, Rank2Types, TemplateHaskell, OverloadedStrings, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +module SecondTransfer.Http2.Session( + http2ServerSession + ,http2ClientSession + ,getFrameFromSession + ,sendFirstFrameToSession + ,sendMiddleFrameToSession + ,sendCommandToSession + ,makeClientState + ,pendingRequests_ClS + + ,CoherentSession + ,SessionInput(..) + ,SessionInputCommand(..) + ,SessionOutput + ,SessionCoordinates(..) + ,SessionComponent(..) + ,SessionsCallbacks(..) + ,SessionsConfig(..) + ,ErrorCallback + ,ClientState(..) + ,SessionRole(..) + + -- Internal stuff + ,InputFrame + ,nextPushStream -- Exporting just to hide the warning + ) where + + +-- System grade utilities imports +import Control.Concurrent (ThreadId) +import Control.Concurrent.Chan +import qualified Control.Concurrent.BoundedChan as BC +import Control.Exception (throwTo) +import qualified Control.Exception as E +import Control.Monad ( + forever, + unless, + when, +-- mapM_, + forM, + forM_) +import Control.Monad.Morph (hoist, lift) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.DeepSeq ( + --($!!), + deepseq ) +import Control.Monad.Trans.Reader +--import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Catch as CMC + +import Control.Concurrent.MVar +import qualified Data.ByteString as B +--import Data.ByteString.Char8 (pack,unpack) +import qualified Data.ByteString.Builder as Bu +import qualified Data.ByteString.Lazy as Bl +import Data.Conduit +--import qualified Data.Conduit as Cnd +import qualified Data.HashTable.IO as H +import qualified Data.IntSet as NS +import Data.Maybe (isJust) +import qualified Data.IORef as DIO +import Data.Typeable + +import Control.Lens + +-- No framing layer here... let's use Kazu's Yamamoto library +import qualified Network.HPACK as HP +import qualified Network.HTTP2 as NH2 + +import qualified Control.Monad.Trans.Resource as ReT +import System.Clock ( getTime + , Clock(..) + , TimeSpec + ) + + +-- Imports from other parts of the program +import SecondTransfer.MainLoop.CoherentWorker +import SecondTransfer.MainLoop.Tokens +import SecondTransfer.MainLoop.Protocol +import SecondTransfer.MainLoop.ClientPetitioner + +import SecondTransfer.Sessions.Config +import SecondTransfer.IOCallbacks.Types (ConnectionData, addr_CnD) +import SecondTransfer.Sessions.Internal (--sessionExceptionHandler, + SessionsContext, + sessionsConfig) +import SecondTransfer.Utils (unfoldChannelAndSource) +import SecondTransfer.Exception +import qualified SecondTransfer.Utils.HTTPHeaders as He +import qualified SecondTransfer.Http2.TransferTypes as TT +#ifdef SECONDTRANSFER_MONITORING +import SecondTransfer.MainLoop.Logging (logit) + +#endif + +-- import Debug.Trace (traceStack) + + +type InputFrame = NH2.Frame + + +--useChunkLength :: Int +-- useChunkLength = 2048 + + +-- What to do regarding headers +data HeaderOutputMessage = + -- Send the headers of the principal stream + NormalResponse_HM (GlobalStreamId, Headers, Effect, MVar TT.OutputDataFeed) + -- Send a push-promise + |PushPromise_HM (GlobalStreamId, GlobalStreamId, Headers, Effect) + -- Send a reset stream notification for the stream given below + -- --|ResetStream_HM (GlobalStreamId, Effect) + -- Send a GoAway, where last-stream is the stream given below. + |GoAway_HM (GlobalStreamId, Effect) + + +-- Settings imposed by the peer +data SessionSettings = SessionSettings { + _pushEnabled_SeS :: DIO.IORef Bool + , _frameSize_SeS :: DIO.IORef Int + } + +makeLenses ''SessionSettings + + + +-- Whatever a worker thread is going to need comes here.... +-- this is to make refactoring easier, but not strictly needed. +data WorkerThreadEnvironment = WorkerThreadEnvironment { + -- What's the header stream id? + _streamId_WTE :: GlobalStreamId + + -- For high priority headers information + , _headersOutput_WTE :: Chan HeaderOutputMessage + + -- And regular contents can come this way and thus be properly mixed + -- with everything else.... for now... + ,_streamBytesSink_WTE :: MVar TT.OutputDataFeed + + ,_streamsCancelled_WTE :: MVar NS.IntSet + + ,_sessionSettings_WTE :: SessionSettings + + ,_nextPushStream_WTE :: MVar Int + + ,_resetStreamButton_WTE :: IO () + + ,_childResetStreamButton_WTE :: GlobalStreamId -> IO () + } + +makeLenses ''WorkerThreadEnvironment + + +-- An HTTP/2 session. Basically a couple of channels ... +type Session = (SessionInput, SessionOutput) + + +-- From outside, one can only write to this one ... the newtype is to enforce +-- this. +newtype SessionInput = SessionInput ( Chan SessionInputCommand ) +sendMiddleFrameToSession :: SessionInput -> InputFrame -> IO () +sendMiddleFrameToSession (SessionInput chan) frame = writeChan chan $ MiddleFrame_SIC frame + +sendFirstFrameToSession :: SessionInput -> InputFrame -> IO () +sendFirstFrameToSession (SessionInput chan) frame = writeChan chan $ FirstFrame_SIC frame + +sendCommandToSession :: SessionInput -> SessionInputCommand -> IO () +sendCommandToSession (SessionInput chan) command = writeChan chan command + +newtype SessionOutputChannelAbstraction = SOCA (BC.BoundedChan TT.SessionOutputPacket) + +sendOutputToFramer :: SessionOutputChannelAbstraction -> TT.SessionOutputPacket -> IO () +sendOutputToFramer (SOCA chan) p = {-# SCC serial #-} p `seq` BC.writeChan chan p + +newSessionOutput :: IO SessionOutputChannelAbstraction +newSessionOutput = + do + -- It could be length 1, but 8 will give it a bit more of space... + chan <- BC.newBoundedChan 8 + return . SOCA $ chan + +-- From outside, one can only read from this one +type SessionOutput = SessionOutputChannelAbstraction +getFrameFromSession :: SessionOutput -> IO TT.SessionOutputPacket +getFrameFromSession (SOCA chan) = BC.readChan chan + + +type HashTable k v = H.CuckooHashTable k v + + +type Stream2HeaderBlockFragment = HashTable GlobalStreamId Bu.Builder + + +type WorkerMonad = ReaderT WorkerThreadEnvironment IO + + +-- Have to figure out which are these...but I would expect to have things +-- like unexpected aborts here in this type. +data SessionInputCommand = + FirstFrame_SIC InputFrame -- This frame is special + |MiddleFrame_SIC InputFrame -- Ordinary frame + |InternalAbort_SIC -- Internal abort from the session itself + |InternalAbortStream_SIC GlobalStreamId -- Internal abort, but only for a frame + |CancelSession_SIC -- Cancel request from the framer + deriving Show + + + +-- The role of a session is either server or client. There are small +-- differences between both. +data SessionRole = + Client_SR + |Server_SR + deriving (Eq,Show) + +-- Here is how we make a session +type SessionMaker = SessionsContext -> IO Session + + +-- Here is how we make a session wrapping a CoherentWorker +type CoherentSession = AwareWorker -> SessionMaker + +data PostInputMechanism = PostInputMechanism (MVar (Maybe B.ByteString), InputDataStream) + +------------- Regarding client state +type Message = (Headers,InputDataStream) + +type RequestResult = Either ConnectionCloseReason Message + +data ClientState = ClientState { + -- Holds a queue. The client here puts the message (the request) and an VAR + -- where it will receive the response. + _pendingRequests_ClS :: MVar (Message, MVar RequestResult) + + -- This is the id of the next available stream + ,_nextStream_ClS :: MVar Int + + -- Says if the client has been closed + ,_clientIsClosed_ClS :: MVar Bool + + -- A dictionary from stream id to the client which is waiting for the + -- message + ,_response2Waiter_ClS ::HashTable GlobalStreamId (MVar RequestResult) + } + +makeLenses ''ClientState + + +makeClientState :: IO ClientState +makeClientState = do + request_chan <- newEmptyMVar + next_stream_mvar <- newMVar 3 + client_is_closed_mvar <- newMVar False + new_h <- H.new + + return ClientState { + _pendingRequests_ClS = request_chan + ,_nextStream_ClS = next_stream_mvar + ,_response2Waiter_ClS = new_h + ,_clientIsClosed_ClS = client_is_closed_mvar + } + + +handleRequest' :: ClientState -> Headers -> InputDataStream -> IO (Headers,InputDataStream) +handleRequest' client_state headers input_data = runReaderT (handleRequest headers input_data) client_state + +type ClientMonad = ReaderT ClientState IO + +handleRequest :: Headers -> InputDataStream -> ClientMonad Message +handleRequest headers input_data = do + pending_requests <- view pendingRequests_ClS + response_mvar <- liftIO $ newEmptyMVar + + liftIO $ E.catch + (do + {-# SCC cause1 #-} putMVar pending_requests ((headers,input_data),response_mvar) + either_reason_or_message <- {-# SCC cause2 #-} liftIO $ takeMVar response_mvar + case either_reason_or_message of + Left break_reason -> E.throw $ ClientSessionAbortedException break_reason + Right message -> return message + ) + ( ( \ _ -> E.throw $ ClientSessionAbortedException SessionAlreadyClosed_CCR ):: E.BlockedIndefinitelyOnMVar -> IO Message ) + + +instance ClientPetitioner ClientState where + + request = handleRequest' + +-------------- end of Regarding client state + +-- SessionData is the actual state of the session, including the channels to the framer +-- outside. +-- +-- NH2.Frame != Frame +data SessionData = SessionData { + -- ATTENTION: Ignore the warning coming from here for now + _sessionsContext :: SessionsContext + + ,_sessionInput :: Chan SessionInputCommand + + -- We need to lock this channel occassionally so that we can order multiple + -- header frames properly....that's the reason for the outer MVar + -- + -- TODO: This outer MVar is no longer needed, since multi-headers and + -- and such are handled specially now . REMOVE! + ,_sessionOutput :: MVar SessionOutputChannelAbstraction + + -- Use to encode + ,_toEncodeHeaders :: MVar HP.DynamicTable + + -- And used to decode + ,_toDecodeHeaders :: MVar HP.DynamicTable + + -- While I'm receiving headers, anything which + -- is not a header should end in the connection being + -- closed + ,_receivingHeaders :: MVar (Maybe Int) + + -- _lastGoodStream is used both to report the last good stream in the + -- GoAwayFrame and to keep track of streams oppened by the client. In + -- other words, it contains the stream_id of the last valid client + -- stream and is updated as soon as the first frame of that stream is + -- received. + ,_lastGoodStream :: MVar GlobalStreamId + + -- Used for decoding the headers... actually, this dictionary should + -- even contain just one entry... BIG TODO!!! + ,_stream2HeaderBlockFragment :: Stream2HeaderBlockFragment + + -- Used for worker threads... this is actually a pre-filled template + -- I make copies of it in different contexts, and as needed. + ,_forWorkerThread :: WorkerThreadEnvironment + + -- When acting as a server, this is the handler for processing requests + ,_awareWorker :: AwareWorker + + -- When acting as a client, this is where new requests are taken + -- from + ,_simpleClient :: ClientState + + -- Some streams may be cancelled + ,_streamsCancelled :: MVar NS.IntSet + + -- Data input mechanism corresponding to some threads + ,_stream2PostInputMechanism :: HashTable Int PostInputMechanism + + -- Worker thread register. This is a dictionary from stream id to + -- the ThreadId of the thread with the worker thread. I use this to + -- raise asynchronous exceptions in the worker thread if the stream + -- is cancelled by the client. This way we get early finalization. + -- Notice that ThreadIds here retain the thread's stack in place. + ,_stream2WorkerThread :: HashTable Int ThreadId + + -- Use to retrieve/set the session id + ,_sessionIdAtSession :: ! Int + + -- And used to keep peer session settings + ,_sessionSettings :: SessionSettings + + -- What is the next stream available for push? + ,_nextPushStream :: MVar Int + + -- What role does this session has? + ,_sessionRole :: SessionRole + + -- When did we start this session? + ,_startTime :: TimeSpec + + -- The address of the peer. + ,_peerAddress :: Maybe HashableSockAddr + + -- Used to decide what to do when some exceptions bubble + ,_sessionIsEnding :: DIO.IORef Bool + } + + +makeLenses ''SessionData + + +instance ActivityMeteredSession SessionData where + sessionLastActivity s = return $ s ^. startTime + +instance CleanlyPrunableSession SessionData where + cleanlyCloseSession s = runReaderT (quietlyCloseConnection NH2.NoError) s + + +http2ServerSession :: ConnectionData -> AwareWorker -> Int -> SessionsContext -> IO Session +http2ServerSession conn_data a i sctx = http2Session (Just conn_data) Server_SR a (error "NotAClient") i sctx + + +http2ClientSession :: ClientState -> Int -> SessionsContext -> IO Session +http2ClientSession client_state session_id sctx = + http2Session Nothing Client_SR (error "NotAServer") client_state session_id sctx + + +-- v- {headers table size comes here!!} +http2Session :: Maybe ConnectionData -> SessionRole -> AwareWorker -> ClientState -> Int -> SessionsContext -> IO Session +http2Session maybe_connection_data session_role aware_worker client_state session_id sessions_context = do + session_input <- newChan + session_output <- newSessionOutput + session_output_mvar <- newMVar session_output + + + -- For incremental construction of headers... + stream_request_headers <- H.new :: IO Stream2HeaderBlockFragment + + -- Warning: we should find a way of coping with different table sizes. + decode_headers_table <- HP.newDynamicTableForDecoding 4096 + decode_headers_table_mvar <- newMVar decode_headers_table + + encode_headers_table <- HP.newDynamicTableForEncoding 4096 + encode_headers_table_mvar <- newMVar encode_headers_table + + -- These ones need independent threads taking care of sending stuff + -- their way... + headers_output <- newChan :: IO (Chan HeaderOutputMessage) + + stream2postinputmechanism <- H.new + stream2workerthread <- H.new + last_good_stream_mvar <- newMVar (-1) + + receiving_headers <- newMVar Nothing + frame_size_ioref <- DIO.newIORef (sessions_context ^. sessionsConfig . dataFrameSize) + push_enabled_ioref <- DIO.newIORef (sessions_context ^. sessionsConfig . pushEnabled) + let + session_settings = SessionSettings { + _pushEnabled_SeS = push_enabled_ioref + , _frameSize_SeS = frame_size_ioref + } + next_push_stream <- newMVar (sessions_context ^. sessionsConfig . firstPushStream ) + + start_time <- getTime Monotonic + session_is_ending_ioref <- DIO.newIORef False + + -- What about stream cancellation? + cancelled_streams_mvar <- newMVar $ NS.empty :: IO (MVar NS.IntSet) + + let + for_worker_thread = WorkerThreadEnvironment { + _streamId_WTE = error "NotInitialized" + , _headersOutput_WTE = headers_output + , _streamsCancelled_WTE = cancelled_streams_mvar + , _sessionSettings_WTE = session_settings + , _nextPushStream_WTE = next_push_stream + , _resetStreamButton_WTE = error "Not initialized" + , _childResetStreamButton_WTE = error "Not initialized" + , _streamBytesSink_WTE = error "Not initialized" + } + + maybe_hashable_addr = case maybe_connection_data of + Just connection_info -> connection_info ^. addr_CnD + Nothing -> Nothing + + let session_data = SessionData { + _sessionsContext = sessions_context + ,_sessionInput = session_input + ,_sessionOutput = session_output_mvar + ,_toDecodeHeaders = decode_headers_table_mvar + ,_toEncodeHeaders = encode_headers_table_mvar + ,_stream2HeaderBlockFragment = stream_request_headers + ,_forWorkerThread = for_worker_thread + ,_awareWorker = aware_worker + ,_simpleClient = client_state + ,_streamsCancelled = cancelled_streams_mvar + ,_stream2PostInputMechanism = stream2postinputmechanism + ,_stream2WorkerThread = stream2workerthread + ,_sessionIdAtSession = session_id + ,_receivingHeaders = receiving_headers + ,_sessionSettings = session_settings + ,_lastGoodStream = last_good_stream_mvar + ,_nextPushStream = next_push_stream + ,_sessionRole = session_role + ,_startTime = start_time + ,_peerAddress = maybe_hashable_addr + ,_sessionIsEnding = session_is_ending_ioref + } + + let + + new_session :: HashableSockAddr -> SessionGenericHandle -> forall a . a -> IO () + new_session a b c = case maybe_callback of + Just (NewSessionCallback callback) -> callback a b c + Nothing -> return () + where + maybe_callback = + (sessions_context ^. (sessionsConfig . sessionsCallbacks . newSessionCallback_SC) ) + + io_exc_handler :: SessionComponent -> E.BlockedIndefinitelyOnMVar -> IO () + io_exc_handler _component _e = do + case session_role of + Server_SR -> do + -- sessionExceptionHandler component session_id sessions_context e + -- Just ignore this kind of exceptions here, very explicitly, as they should naturally + -- happen when the framer is closed + return () + + Client_SR -> do + clientSideTerminate client_state IOChannelClosed_CCR + + + exc_handler :: SessionComponent -> HTTP2SessionException -> IO () + exc_handler _component e = do + case session_role of + Server_SR -> + -- May be leaking space here, disabling for now since we are not using it. + -- sessionExceptionHandler component session_id sessions_context e + return () + + Client_SR -> do + let + maybe_client_session_aborted :: Maybe ClientSessionAbortedException + maybe_client_session_aborted | HTTP2SessionException ee <- e = cast ee + + maybe_protocol_error :: Maybe HTTP2ProtocolException + maybe_protocol_error | HTTP2SessionException ee <- e = cast ee + + case maybe_client_session_aborted of + Just (ClientSessionAbortedException reason) -> do + clientSideTerminate client_state reason + + Nothing -> + if isJust maybe_protocol_error + then + clientSideTerminate client_state ProtocolError_CCR + else do + E.throw e + + exc_guard :: SessionComponent -> IO () -> IO () + exc_guard component action = + E.catch + (E.catch + action + (\e -> do + -- INSTRUMENTATION( errorM "HTTP2.Session" "Exception processed" ) + exc_handler component e + ) + ) + (io_exc_handler component) + + -- Create an input thread that decodes frames... + _ <- forkIOExc "s2f1" $ exc_guard SessionInputThread_HTTP2SessionComponent + $ runReaderT sessionInputThread session_data + + -- Create a thread that captures headers and sends them down the tube + _ <- forkIOExc "s2f2" $ exc_guard SessionHeadersOutputThread_HTTP2SessionComponent + $ runReaderT (headersOutputThread headers_output session_output_mvar) session_data + + -- New session! TODO: Have to fix this manager code maybe? + case maybe_hashable_addr of + Just hashable_addr -> + new_session + hashable_addr + (Whole_SGH session_data) + session_data + + Nothing -> + putStrLn "Warning, created session without registering it" + + + -- If I'm a client, I also need a thread to poll for requests + when (session_role == Client_SR) $ do + _ <- forkIOExc "s2f4" $ exc_guard SessionClientPollThread_HTTP2SessionComponent + $ sessionPollThread session_data headers_output + return () + + + -- The two previous threads fill the session_output argument below (they write to it) + -- the session machinery in the other end is in charge of sending that data through the + -- socket. + + return ( (SessionInput session_input), + session_output ) + +-- | Takes frames from the Framer and starts streams mini-workers to make sense +-- of them. +-- +-- TODO: Really limit the number of streams that a single client is allowed to have active. +-- +-- TODO: Some ill clients can break this thread with exceptions. Make these paths a bit +--- more robust. +sessionInputThread :: ReaderT SessionData IO () +sessionInputThread = do + -- This is an introductory and declarative block... all of this is tail-executed + -- every time that a packet needs to be processed. It may be a good idea to abstract + -- these values in a closure... + session_input <- view sessionInput + + -- decode_headers_table_mvar <- view toDecodeHeaders + -- stream_request_headers <- view stream2HeaderBlockFragment + cancelled_streams_mvar <- view streamsCancelled + -- coherent_worker <- view awareWorker + + -- for_worker_thread_uns <- view forWorkerThread + stream2workerthread <- view stream2WorkerThread + -- receiving_headers_mvar <- view receivingHeaders + -- last_good_stream_mvar <- view lastGoodStream + -- current_session_id <- view sessionIdAtSession + + input <- {-# SCC session_input #-} liftIO $ readChan session_input + session_role <- view sessionRole + + case input of + + FirstFrame_SIC + (NH2.Frame + (NH2.FrameHeader _ 0 null_stream_id ) + (NH2.SettingsFrame settings_list) + ) | 0 == null_stream_id -> do + -- Good, handle + handleSettingsFrame settings_list + continue + + FirstFrame_SIC (NH2.Frame + (NH2.FrameHeader _ 1 null_stream_id ) (NH2.SettingsFrame _ ) ) | 0 == null_stream_id -> do + -- This is a SETTINGS ACK frame, which is okej to have, + -- do nothing here + continue + + FirstFrame_SIC _ -> do + -- Bad, incorrect id or god knows only what .... + -- liftIO $ putStrLn "cc1" + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + + CancelSession_SIC -> do + -- Good place to tear down worker threads... Let the rest of the finalization + -- to the framer. + -- + -- This message is normally got from the Framer + -- + cancellAllStreams + + -- We do not continue here, but instead let it finish + return () + + InternalAbort_SIC -> do + -- Message triggered because the worker failed to behave. + -- When this is sent, the connection is closed + closeConnectionBecauseIsInvalid NH2.InternalError + return () + + InternalAbortStream_SIC stream_id -> do + -- Message triggered because the worker failed to behave, but + -- here we believe that it is not necessary to tear down the + -- entire session and therefore it's enough with a stream + -- reset + -- liftIO $ putStrLn "cc4" + sendOutPriorityTrain + (NH2.EncodeInfo + NH2.defaultFlags + stream_id + Nothing + ) + (NH2.RSTStreamFrame NH2.InternalError + ) + continue + + -- The block below will process both HEADERS and CONTINUATION frames. + -- TODO: As it stands now, the server will happily start a new stream with + -- a CONTINUATION frame instead of a HEADERS frame. That's against the + -- protocol. + MiddleFrame_SIC frame | Just (_stream_id, _bytes) <- isAboutHeaders frame -> + case session_role of + Server_SR -> do + -- Just append the frames to streamRequestHeaders + serverProcessIncomingHeaders frame + continue + + Client_SR -> do + clientProcessIncomingHeaders frame + continue + + -- Peer can order a stream aborted, meaning that we shall not send any more data + -- on it. + MiddleFrame_SIC frame@(NH2.Frame _ (NH2.RSTStreamFrame _error_code_id)) -> do + let stream_id = streamIdFromFrame frame + is_iddle <- streamIsIdle stream_id + if ( stream_id == 0 || (is_iddle && odd stream_id ) ) + then do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + else do + liftIO $ do + -- putStrLn $ "StreamReset " ++ show (_error_code_id) + cancelled_streams <- takeMVar cancelled_streams_mvar + putMVar cancelled_streams_mvar $ NS.insert stream_id cancelled_streams + closePostDataSource stream_id + liftIO $ do + maybe_thread_id <- H.lookup stream2workerthread stream_id + case maybe_thread_id of + Nothing -> + -- This is can actually happen in some implementations: we are asked to + -- cancel an stream we know nothing about. + return () + + Just thread_id -> do + -- INSTRUMENTATION( infoM "HTTP2.Session" $ "Stream successfully interrupted" ) + throwTo thread_id StreamCancelledException + H.delete stream2workerthread stream_id + + continue + + MiddleFrame_SIC _frame@(NH2.Frame frame_header (NH2.WindowUpdateFrame _credit) ) -> do + -- The Framer is the one using this information, here I just merely inspect the length and destroy + -- the session if that length is not good + let frame_length = frameLength frame_header + if frame_length /= 4 + then do + closeConnectionBecauseIsInvalid NH2.FrameSizeError + return () + else + continue + + MiddleFrame_SIC frame@(NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.DataFrame somebytes)) -> unlessReceivingHeaders $ do + -- So I got data to process + -- TODO: Handle end of stream + let stream_id = nh2_stream_id + + -- The call below will block if there is not space in the mvar which is sending data to the + was_ok <- streamWorkerSendData stream_id somebytes + + if was_ok + then do + -- After that data has been received and forwarded downstream, we can issue a windows update + -- + -- + -- TODO: Consider that the best place to output these frames can be somewhere else... + -- + -- TODO: Use a special, with-quota queue here to do flow control. Don't send meaningless + -- WindowUpdateFrame's + sendOutPriorityTrainMany [ + ( + (NH2.EncodeInfo + NH2.defaultFlags + nh2_stream_id + Nothing + ), + (NH2.WindowUpdateFrame + (fromIntegral (B.length somebytes)) + ) + ), + + ( + (NH2.EncodeInfo + NH2.defaultFlags + 0 + Nothing + ), + (NH2.WindowUpdateFrame + (fromIntegral (B.length somebytes)) + ) + ) + ] + + if frameEndsStream frame + then do + -- Good place to close the source ... + closePostDataSource stream_id + else + return () + + continue + else do + -- For some reason there is no PostInput processing mechanism, therefore, + -- we were not expecting data at this point + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + + MiddleFrame_SIC (NH2.Frame frame_header (NH2.PingFrame _)) | not (isStreamZero frame_header) || frameLength frame_header /= 8 -> do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + + MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ flags _) (NH2.PingFrame _)) | NH2.testAck flags-> do + -- Deal with pings: this is an Ack, so do nothing + -- In the future we may have some metric information here.... + continue + + MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ _ _) (NH2.PingFrame somebytes)) -> do + -- Deal with pings: NOT an Ack, so answer + -- INSTRUMENTATION( debugM "HTTP2.Session" "Ping processed" ) + sendOutPriorityTrain + (NH2.EncodeInfo + (NH2.setAck NH2.defaultFlags) + 0 + Nothing + ) + (NH2.PingFrame somebytes) + + continue + + MiddleFrame_SIC (NH2.Frame frame_header (NH2.SettingsFrame settings_list)) + | frameLength frame_header `mod` 6 /= 0 -> do + liftIO . putStrLn $ "FrameSizeError" + closeConnectionBecauseIsInvalid NH2.FrameSizeError + return () + + | isSettingsAck frame_header && isStreamZero frame_header && isLengthZero frame_header -> do + -- Frame was received by the peer, do nothing here... + continue + + | not (isSettingsAck frame_header) && isStreamZero frame_header -> do + handleSettingsFrame settings_list + continue + + | otherwise -> do + -- Frame was received by the peer, do nothing here... + liftIO . putStrLn $ "SettingsHasWrongSize" + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + + MiddleFrame_SIC (NH2.Frame _ (NH2.GoAwayFrame _ _err _ )) + | Server_SR <- session_role -> do + -- I was sent a go away, so go-away... + --liftIO . putStrLn $ "Received GoAway frame" + quietlyCloseConnection NH2.NoError + return () + + | Client_SR <- session_role -> do + -- I was sent a go away, so go-away, but use the kind of exception + -- that will unwind the stack gracefully + _ <- closeConnectionForClient NH2.NoError + return () + + MiddleFrame_SIC (NH2.Frame (NH2.FrameHeader _ _ nh2_stream_id) (NH2.PriorityFrame NH2.Priority {NH2.exclusive=_e, NH2.streamDependency=dep_id, NH2.weight=_w} ) ) + | nh2_stream_id == dep_id -> do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return () + + | otherwise -> + continue + + MiddleFrame_SIC _somethingelse -> unlessReceivingHeaders $ do + -- An undhandled case here.... + liftIO $ putStrLn $ "Unhandled " ++ show _somethingelse + continue + + where + continue = sessionInputThread + + -- TODO: Do use the settings!!! + handleSettingsFrame :: NH2.SettingsList -> ReaderT SessionData IO () + handleSettingsFrame _settings_list = do + session_settings <- view sessionSettings + sessions_config <- view $ sessionsContext . sessionsConfig + let + enable_push = lookup NH2.SettingsEnablePush _settings_list + max_frame_size = lookup NH2.SettingsMaxFrameSize _settings_list + + -- Handled by the framer, but errors should be reported here. + max_flow_control_size = lookup NH2.SettingsInitialWindowSize _settings_list + + ok <- case enable_push of + Just 1 -> do + liftIO $ DIO.writeIORef (session_settings ^. pushEnabled_SeS) True + return True + Just 0 -> do + liftIO $ DIO.writeIORef (session_settings ^. pushEnabled_SeS) False + return True + Just _ -> do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return True + + Nothing -> do + return True + + ok2 <- if ok + then + case max_frame_size of + -- The spec says clearly what's the minimum size that can come here + Just n | n < 16384 || n > 16777215 + -> do + -- liftIO $ putStrLn "Wild max frame size" + closeConnectionBecauseIsInvalid NH2.FrameSizeError + return False + + | otherwise + -> + if n > (sessions_config ^. dataFrameSize) + -- Ignore if it is bigger than the size configured in this context + then do + return True + else do + liftIO $ DIO.writeIORef (session_settings ^. frameSize_SeS) n + return True + Nothing -> return True + else + return False + + ok3 <- if ok2 + then + case max_flow_control_size of + Just n + | n > 2147483647 || n < 0 + -> do + closeConnectionBecauseIsInvalid NH2.FlowControlError + return False + | otherwise + -> return True + Nothing -> return True + else + return False + + + if ok3 + then + sendOutPriorityTrain + (NH2.EncodeInfo + (NH2.setAck NH2.defaultFlags) + 0 + Nothing + ) + (NH2.SettingsFrame []) + else + return () + + + +streamIsIdle :: GlobalStreamId -> ReaderT SessionData IO Bool +streamIsIdle stream_id = + do + last_good_stream_mvar <- view lastGoodStream + last_good_stream <- liftIO . readMVar $ last_good_stream_mvar + return ( stream_id > last_good_stream ) + + +serverProcessIncomingHeaders :: NH2.Frame -> ReaderT SessionData IO () +serverProcessIncomingHeaders frame | Just (!stream_id, bytes) <- isAboutHeaders frame = do + + -- Just append the frames to streamRequestHeaders + opens_stream <- appendHeaderFragmentBlock stream_id bytes + receiving_headers_mvar <- view receivingHeaders + last_good_stream_mvar <- view lastGoodStream + for_worker_thread_uns <- view forWorkerThread + decode_headers_table_mvar <- view toDecodeHeaders + stream_request_headers <- view stream2HeaderBlockFragment + coherent_worker <- view awareWorker + current_session_id <- view sessionIdAtSession + session_input <- view sessionInput + stream2workerthread <- view stream2WorkerThread + maybe_hashable_addr <- view peerAddress + + if opens_stream + then {-# SCC gpAb #-} do + --maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar + all_ok <- liftIO . modifyMVar receiving_headers_mvar $ \ maybe_rcv_headers_of -> + case maybe_rcv_headers_of of + Just _ -> + -- Bad peer, it is already sending headers + -- and trying to open another one + return (maybe_rcv_headers_of, False) + Nothing -> do + return (Just stream_id, True) + if all_ok + then do + -- And go to check if the stream id is valid + ok2 <- liftIO . modifyMVar last_good_stream_mvar $ \ last_good_stream -> + if (odd stream_id ) && (stream_id > last_good_stream) + then + -- We are golden, set the new good stream + return (stream_id, True) + else + -- The new oppened stream has a new id + return (stream_id, False) + unless ok2 $ + closeConnectionBecauseIsInvalid NH2.ProtocolError + else do + closeConnectionBecauseIsInvalid NH2.ProtocolError + else {-# SCC gpcb #-} do + maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar + case maybe_rcv_headers_of of + Just a_stream_id + | a_stream_id == stream_id -> do + -- Nothing to complain about + liftIO $ putMVar receiving_headers_mvar maybe_rcv_headers_of + | otherwise -> + error "IncorrectStreamId1" + + Nothing -> error "InternalError, this should be set" + + if frameEndsHeaders frame then + do + -- Ok, let it be known that we are not receiving more headers + liftIO $ modifyMVar_ + receiving_headers_mvar + (\ _ -> return Nothing ) + -- Lets get a time + headers_arrived_time <- liftIO $ getTime Monotonic + + -- This is where the bytes of the stream will end up . + stream_bytes <- liftIO newEmptyMVar + + let + reset_button = writeChan session_input (InternalAbortStream_SIC stream_id) + child_reset_button = \stream_id' -> writeChan session_input (InternalAbortStream_SIC stream_id') + -- Prepare the environment for the new working thread + for_worker_thread = + (set streamId_WTE stream_id) + . + (set streamBytesSink_WTE stream_bytes) + . + (set resetStreamButton_WTE reset_button) + . + (set childResetStreamButton_WTE child_reset_button) + $ + for_worker_thread_uns + + -- Let's decode the headers + headers_bytes <- getHeaderBytes stream_id + dyn_table <- liftIO $ takeMVar decode_headers_table_mvar + maybe_table <- liftIO $ + E.catch + (do + r <- HP.decodeHeader dyn_table headers_bytes + return . Right $ r ) + ((const $ return $ Left () ):: HP.DecodeError -> IO (Either () (HP.DynamicTable, HP.HeaderList))) + + case maybe_table of + Left _ -> do + liftIO $ putStrLn "InvalidHeadersReceived" + closeConnectionBecauseIsInvalid NH2.ProtocolError + + Right (new_table, header_list ) -> do + + -- /DEBUG + -- Good moment to remove the headers from the table.... we don't want a space + -- leak here + liftIO $ do + H.delete stream_request_headers stream_id + putMVar decode_headers_table_mvar new_table + + -- TODO: Validate headers, abort session if the headers are invalid. + -- Otherwise other invariants will break!! + -- THIS IS PROBABLY THE BEST PLACE FOR DOING IT. + let + headers_editor = He.fromList header_list + + maybe_good_headers_editor <- validateIncomingHeadersServer headers_editor + + good_headers <- case maybe_good_headers_editor of + Just yes_they_are_good -> return yes_they_are_good + Nothing -> {-# SCC ccB3 #-} do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return . error $ "NotUsedHeaderRepr" + + -- Add any extra headers, on demand + --headers_extra_good <- addExtraHeaders good_headers + let + headers_extra_good = good_headers + header_list_after = He.toList headers_extra_good + -- liftIO $ putStrLn $ "header list after " ++ (show header_list_after) + + -- If the headers end the request.... + post_data_source <- if not (frameEndsStream frame) + then do + mechanism <- createMechanismForStream stream_id + let source = postDataSourceFromMechanism mechanism + return $ Just source + else do + return Nothing + + let + perception = Perception { + _startedTime_Pr = headers_arrived_time, + _streamId_Pr = stream_id, + _sessionId_Pr = current_session_id, + _protocol_Pr = Http2_HPV, + _anouncedProtocols_Pr = Nothing, + _peerAddress_Pr = maybe_hashable_addr + } + request' = Request { + _headers_RQ = header_list_after, + _inputData_RQ = post_data_source, + _perception_RQ = perception + } + + -- TODO: Handle the cases where a request tries to send data + -- even if the method doesn't allow for data. + + -- I'm clear to start the worker, in its own thread + -- + -- NOTE: Some late internal errors from the worker thread are + -- handled here by closing the session. + -- + -- TODO: Log exceptions handled here. + + session_is_ending_ioref <- view sessionIsEnding + liftIO $ do + -- The mvar below: avoid starting until the entry has + -- been properly inserted in the table... + ready <- newMVar () + let + general_exc_handler :: E.SomeException -> IO () + general_exc_handler e = do + -- Actions to take when the thread breaks.... + -- We cancel the entire session because there is a more specific + -- handler that doesn't somewhere below. If the exception bubles here, + -- it is because the situation is out of control. We may as well + -- exit the server, but I'm not being so extreme now. + H.delete stream2workerthread stream_id + session_is_ending <- DIO.readIORef session_is_ending_ioref + unless session_is_ending $ do + putStrLn $ "ERROR: Aborting session after non-handled exception bubbled up " ++ E.displayException e + writeChan session_input InternalAbort_SIC + io_closed_handle :: E.BlockedIndefinitelyOnMVar -> IO () + io_closed_handle _e = return () + thread_id <- forkIOExc "s2f7" . E.handle general_exc_handler . E.handle io_closed_handle $ + ({-# SCC growP1 #-} do + putMVar ready () + runReaderT + (workerThread + request' + coherent_worker) + for_worker_thread + H.delete stream2workerthread stream_id + ) + H.insert stream2workerthread stream_id thread_id + takeMVar ready + + + + return () + else + -- Frame doesn't end the headers... it was added before... so + -- probably do nothing + return () + +serverProcessIncomingHeaders _ = error "serverProcessIncomingHeadersNotDefined" + +clientProcessIncomingHeaders :: NH2.Frame -> ReaderT SessionData IO () +clientProcessIncomingHeaders frame | Just (stream_id, bytes) <- isAboutHeaders frame = do + + opens_stream <- appendHeaderFragmentBlock stream_id bytes + receiving_headers_mvar <- view receivingHeaders + last_good_stream_mvar <- view lastGoodStream + decode_headers_table_mvar <- view toDecodeHeaders + stream_request_headers <- view stream2HeaderBlockFragment + response2waiter <- view (simpleClient . response2Waiter_ClS) + + if opens_stream + then do + maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar + case maybe_rcv_headers_of of + Just _ -> do + -- Bad peer, it is already sending headers + -- and trying to open another one + closeConnectionBecauseIsInvalid NH2.ProtocolError + -- An exception will be thrown above, so to not complicate + -- control flow here too much. + Nothing -> do + -- Signal that we are receiving headers now, for this stream + liftIO $ putMVar receiving_headers_mvar (Just stream_id) + -- And go to check if the stream id is valid + --last_good_stream <- liftIO $ takeMVar last_good_stream_mvar + stream_initiated_by_client <- streamInitiatedByClient stream_id + if (odd stream_id ) && stream_initiated_by_client + then do + -- We are golden, set the new good stream + liftIO $ putMVar last_good_stream_mvar (stream_id) + else do + -- We are not golden + -- TODO: Control for pushed streams here. + closeConnectionBecauseIsInvalid NH2.ProtocolError + else do + maybe_rcv_headers_of <- liftIO $ takeMVar receiving_headers_mvar + case maybe_rcv_headers_of of + Just a_stream_id + | a_stream_id == stream_id -> do + -- Nothing to complain about + liftIO $ putMVar receiving_headers_mvar maybe_rcv_headers_of + | otherwise -> error "StreamIdMismatch3" + + Nothing -> error "InternalError, this should be set" + + if frameEndsHeaders frame then + do + -- Ok, let it be known that we are not receiving more headers + liftIO $ modifyMVar_ + receiving_headers_mvar + (\ _ -> return Nothing ) + -- Lets get a time + -- headers_arrived_time <- liftIO $ getTime Monotonic + -- Let's decode the headers + headers_bytes <- getHeaderBytes stream_id + dyn_table <- liftIO $ takeMVar decode_headers_table_mvar + (new_table, header_list ) <- liftIO $ HP.decodeHeader dyn_table headers_bytes + + -- Good moment to remove the headers from the table.... we don't want a space + -- leak here + liftIO $ do + H.delete stream_request_headers stream_id + putMVar decode_headers_table_mvar new_table + + -- TODO: Validate headers, abort session if the headers are invalid. + -- Otherwise other invariants will break!! + -- THIS IS PROBABLY THE BEST PLACE FOR DOING IT. + let + headers_editor = He.fromList header_list + + maybe_good_headers_editor <- validateIncomingHeadersClient headers_editor + + good_headers <- case maybe_good_headers_editor of + Just yes_they_are_good -> return yes_they_are_good + -- Function below throws an exception and therefore closes everything + -- TODO: Can we device smoother ways of terminating the session? + Nothing -> do + closeConnectionBecauseIsInvalid NH2.ProtocolError + return . error $ "NotUsedHeaderRepr2" + + -- If the headers end the request.... + post_data_source <- if not (frameEndsStream frame) + then do + mechanism <- createMechanismForStream stream_id + return $ postDataSourceFromMechanism mechanism + else + return $ return () + + (Just response_mvar) <- liftIO $ H.lookup response2waiter stream_id + liftIO $ putMVar response_mvar $ Right (He.toList good_headers, post_data_source) + + return () + else + -- Frame doesn't end the headers... it was added before... so + -- probably do nothing + return () + +clientProcessIncomingHeaders _ = error "Not defined" + +streamInitiatedByClient :: GlobalStreamId -> ReaderT SessionData IO Bool +streamInitiatedByClient stream_id = do + response2waiter <- view (simpleClient . response2Waiter_ClS) + response_handle_maybe <- liftIO $ H.lookup response2waiter stream_id + return $ isJust response_handle_maybe + + +sendOutPriorityTrain :: NH2.EncodeInfo -> NH2.FramePayload -> ReaderT SessionData IO () +sendOutPriorityTrain encode_info payload = do + session_output_mvar <- view sessionOutput + + liftIO $ withMVar session_output_mvar $ \ session_output -> + sendOutputToFramer session_output $ TT.PriorityTrain_StFB [( + encode_info, + payload, + -- Not sending effects in this frame, since it is not related... + error "sendOutFrameNotFor")] + + +sendOutPriorityTrainMany :: [(NH2.EncodeInfo , NH2.FramePayload)] -> ReaderT SessionData IO () +sendOutPriorityTrainMany many = do + session_output_mvar <- view sessionOutput + + liftIO $ withMVar session_output_mvar $ \ session_output -> + sendOutputToFramer session_output $ + TT.PriorityTrain_StFB $ + map + (\(encode_info, payload) -> (encode_info, payload, error "no-effect")) + many + + +-- TODO: Close connection on unexepcted pseudo-headers +validateIncomingHeadersServer :: He.HeaderEditor -> ReaderT SessionData IO (Maybe He.HeaderEditor) +validateIncomingHeadersServer headers_editor = do + -- Check that the headers block comes with all mandatory headers. + -- Right now I'm not checking that they come in the mandatory order though... + -- + -- Notice that this function will transform a "host" header to an ":authority" + -- one. + let + h1 = He.replaceHostByAuthority headers_editor + -- Check that headers are lowercase + headers_are_lowercase = He.headersAreLowercaseAtHeaderEditor headers_editor + -- Check that we have mandatory headers + maybe_authority = h1 ^. (He.headerLens ":authority") + maybe_method = h1 ^. (He.headerLens ":method") + maybe_scheme = h1 ^. (He.headerLens ":scheme") + maybe_path = h1 ^. (He.headerLens ":path") + + if + (isJust maybe_authority) && + (isJust maybe_method) && + (isJust maybe_scheme) && + (isJust maybe_path ) && + headers_are_lowercase + then + return (Just h1) + else + return Nothing + +validateIncomingHeadersClient :: He.HeaderEditor -> ReaderT SessionData IO (Maybe He.HeaderEditor) +validateIncomingHeadersClient headers_editor = do + -- Check that the headers block comes with all mandatory headers. + -- Right now I'm not checking that they come in the mandatory order though... + -- + -- Notice that this function will transform a "host" header to an ":authority" + -- one. + let + h1 = He.replaceHostByAuthority headers_editor + -- Check that headers are lowercase + headers_are_lowercase = He.headersAreLowercaseAtHeaderEditor headers_editor + -- Check that we have mandatory headers + maybe_status = h1 ^. (He.headerLens ":status") + + if (isJust maybe_status) && headers_are_lowercase + then + return (Just h1) + else + return Nothing + + +-- Sends a GO_AWAY frame and raises an exception, effectively terminating the input +-- thread of the session. +closeConnectionBecauseIsInvalid :: NH2.ErrorCodeId -> ReaderT SessionData IO () +closeConnectionBecauseIsInvalid error_code = do + last_good_stream_mvar <- view lastGoodStream + last_good_stream <- liftIO $ takeMVar last_good_stream_mvar + + requestTermination last_good_stream error_code + cancellAllStreams + + +-- Sends a GO_AWAY frame and closes everything, without being too drastic +quietlyCloseConnection :: NH2.ErrorCodeId -> ReaderT SessionData IO () +quietlyCloseConnection error_code = do + -- liftIO $ putStrLn "quietlyCloseConnection" + last_good_stream_mvar <- view lastGoodStream + last_good_stream <- liftIO $ takeMVar last_good_stream_mvar + + cancellAllStreams + requestTermination last_good_stream error_code + + +-- Sends a GO_AWAY frame and raises an exception, effectively terminating the input +-- thread of the session. This one for the client is different because it throws +-- an exception of type ClientSessionAbortedException +closeConnectionForClient :: NH2.ErrorCodeId -> ReaderT SessionData IO a +closeConnectionForClient error_code = do + let + use_reason = case error_code of + NH2.NoError -> NormalTermination_CCR + _ -> ProtocolError_CCR + + last_good_stream_mvar <- view lastGoodStream + last_good_stream <- liftIO $ takeMVar last_good_stream_mvar + + client_is_closed_mvar <- view (simpleClient . clientIsClosed_ClS ) + requestTermination last_good_stream error_code + cancellAllStreams + liftIO $ do + + -- Let's also mark the session as closed from the client side, so that + -- any further requests end with the correct exception + modifyMVar_ client_is_closed_mvar (\ _ -> return True) + + -- And unwind the input thread in the session, so that the + -- exception handler runs.... + E.throw $ ClientSessionAbortedException use_reason + + +cancellAllStreams :: ReaderT SessionData IO () +cancellAllStreams = + do + session_is_ending_ioref <- view sessionIsEnding + stream2workerthread <- view stream2WorkerThread + + liftIO $ do + DIO.writeIORef session_is_ending_ioref True + -- Close all active threads for this session + H.mapM_ + ( \(_stream_id, thread_id) -> + throwTo thread_id StreamCancelledException + ) + stream2workerthread + + +requestTermination :: GlobalStreamId -> NH2.ErrorCodeId -> ReaderT SessionData IO () +requestTermination stream_id error_code = + do + session_is_ending_ioref <- view sessionIsEnding + liftIO $ DIO.writeIORef session_is_ending_ioref True + session_output_mvar <- view sessionOutput + let + message = TT.Command_StFB (TT.SpecificTerminate_SOC stream_id error_code) + liftIO . withMVar session_output_mvar $ \ session_output -> do + sendOutputToFramer session_output message + + +frameEndsStream :: InputFrame -> Bool +frameEndsStream (NH2.Frame (NH2.FrameHeader _ flags _) _) = NH2.testEndStream flags + + +-- Executes its argument, unless receiving +-- headers, in which case the connection is closed. +unlessReceivingHeaders :: ReaderT SessionData IO a -> ReaderT SessionData IO a +unlessReceivingHeaders comp = do + receiving_headers_mvar <- view receivingHeaders + -- First check if we are receiving headers + maybe_recv_headers <- liftIO $ readMVar receiving_headers_mvar + if isJust maybe_recv_headers + then do + -- So, this frame is highly illegal + closeConnectionBecauseIsInvalid NH2.ProtocolError + return . error $ "NotUsedRepr3" + else + comp + + +createMechanismForStream :: GlobalStreamId -> ReaderT SessionData IO PostInputMechanism +createMechanismForStream stream_id = do + (chan, source) <- liftIO $ unfoldChannelAndSource + stream2postinputmechanism <- view stream2PostInputMechanism + let pim = PostInputMechanism (chan, hoist lift source) + liftIO $ H.insert stream2postinputmechanism stream_id pim + return pim + + +-- TODO: Can be optimized by factoring out the mechanism lookup +-- TODO IMPORTANT: This is a good place to drop the postinputmechanism +-- for a stream, so that unprocessed data can be garbage-collected. +closePostDataSource :: GlobalStreamId -> ReaderT SessionData IO () +closePostDataSource stream_id = do + stream2postinputmechanism <- view stream2PostInputMechanism + + pim_maybe <- liftIO $ H.lookup stream2postinputmechanism stream_id + + case pim_maybe of + + Just (PostInputMechanism (chan, _)) -> + liftIO $ do + putMVar chan Nothing + -- Not sure if this will work + H.delete stream2postinputmechanism stream_id + + Nothing -> + -- Assume this is ok + return () + + +streamWorkerSendData :: Int -> B.ByteString -> ReaderT SessionData IO Bool +streamWorkerSendData stream_id bytes = do + s2pim <- view stream2PostInputMechanism + pim_maybe <- liftIO $ H.lookup s2pim stream_id + + case pim_maybe of + + Just pim -> do + sendBytesToPim pim bytes + return True + + Nothing -> + -- There is no input mechanism + return False + + +sendBytesToPim :: PostInputMechanism -> B.ByteString -> ReaderT SessionData IO () +sendBytesToPim (PostInputMechanism (chan, _)) bytes = + liftIO $ putMVar chan (Just bytes) + + +postDataSourceFromMechanism :: PostInputMechanism -> InputDataStream +postDataSourceFromMechanism (PostInputMechanism (_, source)) = source + + +isSettingsAck :: NH2.FrameHeader -> Bool +isSettingsAck (NH2.FrameHeader _ flags _) = + NH2.testAck flags + + +isLengthZero :: NH2.FrameHeader -> Bool +isLengthZero (NH2.FrameHeader l _ _ ) = l == 0 + +frameLength :: NH2.FrameHeader -> Int +frameLength (NH2.FrameHeader l _ _ ) = l + +isStreamZero :: NH2.FrameHeader -> Bool +isStreamZero (NH2.FrameHeader _ _ s) = s == 0 + + +isStreamCancelled :: GlobalStreamId -> WorkerMonad Bool +isStreamCancelled stream_id = do + cancelled_streams_mvar <- view streamsCancelled_WTE + cancelled_streams <- liftIO $ readMVar cancelled_streams_mvar + return $ NS.member stream_id cancelled_streams + + +sendPrimitive500Error :: IO TupledPrincipalStream +sendPrimitive500Error = + return ( + [ + (":status", "500") + ], + [], + do + yield "Internal server error\n" + -- No footers + return [] + ) + + +-- | Invokes the Coherent worker, and interacts with the rest of +-- the session and the Framer so that data is sent and received by +-- the peer following the protocol. +workerThread :: Request -> AwareWorker -> WorkerMonad () +workerThread req aware_worker = + ignoreCancels $ do + headers_output <- view headersOutput_WTE + stream_id <- view streamId_WTE + --session_settings <- view sessionSettings_WTE + --next_push_stream_mvar <- view nextPushStream_WTE + + -- If the request get rejected right away, we can just send + -- a 500 error in this very stream, without making any fuss. + -- (headers, _, data_and_conclussion) + -- + -- TODO: Can we add debug information in a header here? + principal_stream <- + liftIO $ {-# SCC wTer1 #-} E.catch + ( + aware_worker req + ) + ( + const $ tupledPrincipalStreamToPrincipalStream <$> sendPrimitive500Error + :: HTTP500PrecursorException -> IO PrincipalStream + ) + + -- Pieces of the header + let + effects = principal_stream ^. effect_PS + interrupt_maybe = effects ^. interrupt_Ef + + + -- Exceptions can bubble in the points below. If so, send proper resets... + case interrupt_maybe of + + Nothing -> do + {-# SCC nHS #-} normallyHandleStream principal_stream + + Just (InterruptConnectionAfter_IEf) -> do + normallyHandleStream principal_stream + liftIO . writeChan headers_output $ GoAway_HM (stream_id, effects) + + Just (InterruptConnectionNow_IEf) -> do + -- Not one hundred-percent sure of this being correct, but we don't want + -- to acknowledge reception of this stream then + let use_stream_id = stream_id - 1 + liftIO . writeChan headers_output $ GoAway_HM (use_stream_id, effects) + where + ignoreCancels = CMC.handle ((\_ -> return () ):: StreamCancelledException -> WorkerMonad ()) + + +normallyHandleStream :: PrincipalStream -> WorkerMonad () +normallyHandleStream principal_stream = do + headers_output <- view headersOutput_WTE + stream_id <- view streamId_WTE + session_settings <- view sessionSettings_WTE + next_push_stream_mvar <- view nextPushStream_WTE + reset_button <- view resetStreamButton_WTE + + -- Pieces of the header + let + headers = He.removeConnectionHeaders $ principal_stream ^. headers_PS + data_and_conclusion = principal_stream ^. dataAndConclusion_PS + effects = principal_stream ^. effect_PS + pushed_streams = principal_stream ^. pushedStreams_PS + + can_push_ioref = session_settings ^. pushEnabled_SeS + + can_push <- liftIO . DIO.readIORef $ can_push_ioref + -- This gets executed in normal conditions, when no interruption is required. + + -- There are several possible moments where the PUSH_PROMISEs can be sent, + -- but a default safe one is before sending the response HEADERS, so that + -- LINK headers in the response come after any potential promises. + data_promises <- if can_push then do + forM pushed_streams $ \ pushed_stream_comp -> do + -- Initialize pushed stream + pushed_stream <- liftIO pushed_stream_comp + -- Send the request headers properly wrapped in a "Push Promise", do + -- it before sending the actual response headers of this stream + let + request_headers = pushed_stream ^. requestHeaders_Psh + -- We do not expect connection headers in pushed streams, since they + -- are HTTP/2-specific. + response_headers = pushed_stream ^. responseHeaders_Psh + pushed_data_and_conclusion = pushed_stream ^. dataAndConclusion_Psh + + child_stream_id <- liftIO $ modifyMVar next_push_stream_mvar + $ (\ x -> return (x+2,x) ) + + liftIO . writeChan headers_output . PushPromise_HM $ + (stream_id, child_stream_id, request_headers, effects) + return (child_stream_id, response_headers, pushed_data_and_conclusion, effects) + else + return [] + + -- Now I send the headers, if that's possible at all + data_output <- view streamBytesSink_WTE + headers `seq` ( liftIO $ writeChan headers_output $ NormalResponse_HM (stream_id, headers, effects, data_output) ) + + -- At this moment I should ask if the stream hasn't been cancelled by the browser before + -- commiting to the work of sending addtitional data... this is important for pushed + -- streams + is_stream_cancelled <- isStreamCancelled stream_id + unless is_stream_cancelled $ do + -- I have a beautiful source that I can de-construct... + -- TODO: Optionally pulling data out from a Conduit .... + -- liftIO ( data_and_conclussion $$ (_sendDataOfStream stream_id) ) + -- + -- This threadlet should block here waiting for the headers to finish going + -- NOTE: Exceptions generated here inheriting from HTTP500PrecursorException + -- are let to bubble and managed in this thread fork point... + _ <- liftIO . ReT.runResourceT $ do + resource_key <- ReT.register reset_button + _ <- runConduit $ + (data_and_conclusion) + `fuseBothMaybe` + (sendDataOfStream stream_id data_output) + ReT.unprotect resource_key + + -- BIG TODO: Send the footers ... likely stream conclusion semantics + -- will need to be changed. + + -- AFTER sending the data of the main stream, start sending the data of the + -- pushed streams... + + -- Now, time to fork threads for the pusher streams + -- we send those pushers even if the main stream is cancelled... + forM_ data_promises + $ \ (child_stream_id, response_headers, pushed_data_and_conclusion, _effects) -> do + environment <- ask + let + action = pusherThread + child_stream_id + response_headers + pushed_data_and_conclusion + effects + -- And let the action run in its own thread + liftIO . forkIOExc "s2f8" $ runReaderT action environment + + return () + + + +-- Takes care of pushed data, which is sent through pipes to +-- the output thread here in this session. +pusherThread :: GlobalStreamId -> Headers -> DataAndConclusion -> Effect -> WorkerMonad () +pusherThread child_stream_id response_headers pushed_data_and_conclusion effects = + do + headers_output <- view headersOutput_WTE + -- session_settings <- view sessionSettings_WTE + pushed_reset_button <- view childResetStreamButton_WTE + + -- TODO: Handle exceptions here: what happens if the coherent worker + -- throws an exception signaling that the request is ill-formed + -- and should be dropped? That could happen in a couple of occassions, + -- but really most cases should be handled here in this file... + -- (headers, _, data_and_conclussion) + pusher_data_output <- liftIO $ newEmptyMVar + + -- Now I send the headers, if that's possible at all. These are classes as "Normal response" + liftIO . writeChan headers_output + $ NormalResponse_HM (child_stream_id, response_headers, effects, pusher_data_output) + + -- At this moment I should ask if the stream hasn't been cancelled by the browser before + -- commiting to the work of sending addtitional data... this is important for pushed + -- streams + is_stream_cancelled <- isStreamCancelled child_stream_id + unless is_stream_cancelled $ do + _ <- liftIO . ReT.runResourceT $ do + k <- ReT.register (pushed_reset_button child_stream_id) + _ <- runConduit $ + pushed_data_and_conclusion + `fuseBothMaybe` + sendDataOfStream child_stream_id pusher_data_output + ReT.unprotect k + + return () + + +-- v-- comp. monad. +sendDataOfStream :: MonadIO m => GlobalStreamId -> MVar TT.OutputDataFeed -> Sink B.ByteString m () +sendDataOfStream _stream_id data_output = + do + consumer + where + consumer = do + maybe_bytes <- await + -- use_size_ioref <- view (sessionSettings_WTE . frameSize_SeS) + -- use_size <- liftIO $ DIO.readIORef use_size_ioref + case maybe_bytes of + + Nothing -> do + -- This is how we finish sending data + liftIO $ putMVar data_output "" + + Just bytes + | lng <- B.length bytes, lng > 0 -> do + + liftIO $ do + putMVar data_output bytes + consumer + + | otherwise -> do + -- Finish sending data, finish in general + liftIO $ putMVar data_output "" + + +-- Returns if the frame is the first in the stream +appendHeaderFragmentBlock :: GlobalStreamId -> B.ByteString -> ReaderT SessionData IO Bool +appendHeaderFragmentBlock global_stream_id bytes = do + ht <- view stream2HeaderBlockFragment + maybe_old_block <- liftIO $ H.lookup ht global_stream_id + (new_block, new_stream) <- case maybe_old_block of + + Nothing -> do + -- TODO: Make the commented message below more informative + return $ (Bu.byteString bytes, True) + + Just something -> + return $ (something `mappend` (Bu.byteString bytes), False) + + liftIO $ H.insert ht global_stream_id new_block + return new_stream + + +getHeaderBytes :: GlobalStreamId -> ReaderT SessionData IO B.ByteString +getHeaderBytes global_stream_id = do + ht <- view stream2HeaderBlockFragment + Just bytes <- liftIO $ H.lookup ht global_stream_id + return $ Bl.toStrict $ Bu.toLazyByteString bytes + + +isAboutHeaders :: InputFrame -> Maybe (GlobalStreamId, B.ByteString) +isAboutHeaders (NH2.Frame (NH2.FrameHeader _ _ stream_id) ( NH2.HeadersFrame _ block_fragment ) ) + = Just (stream_id, block_fragment) +isAboutHeaders (NH2.Frame (NH2.FrameHeader _ _ stream_id) ( NH2.ContinuationFrame block_fragment) ) + = Just (stream_id, block_fragment) +isAboutHeaders _ + = Nothing + + +frameEndsHeaders :: InputFrame -> Bool +frameEndsHeaders (NH2.Frame (NH2.FrameHeader _ flags _) _) = NH2.testEndHeader flags + + +streamIdFromFrame :: InputFrame -> GlobalStreamId +streamIdFromFrame (NH2.Frame (NH2.FrameHeader _ _ stream_id) _) = stream_id + + +-- TODO: Have different size for the headers..... just now going with a default size of 16 k... +-- TODO: Find a way to kill this thread.... +headersOutputThread :: Chan HeaderOutputMessage -- (GlobalStreamId, MVar HeadersSent, Headers, Effect) + -> MVar SessionOutputChannelAbstraction + -> ReaderT SessionData IO () +headersOutputThread input_chan session_output_mvar = forever $ do + + frame_size_ioref <- view $ sessionSettings . frameSize_SeS + use_chunk_length <- liftIO $ DIO.readIORef frame_size_ioref + + header_output_request <- {-# SCC input_chan #-} liftIO $ readChan input_chan + {-# SCC case_ #-} case header_output_request of + NormalResponse_HM (stream_id, headers, effect, data_output) -> do + + -- First encode the headers using the table + encode_dyn_table_mvar <- view toEncodeHeaders + + encode_dyn_table <- liftIO $ takeMVar encode_dyn_table_mvar + (new_dyn_table, data_to_send ) <- liftIO $ HP.encodeHeader HP.defaultEncodeStrategy encode_dyn_table headers + liftIO $ putMVar encode_dyn_table_mvar new_dyn_table + + -- Now split the bytestring in chunks of the needed size.... + -- Note that the only way we can + let + bs_chunks = bytestringChunk use_chunk_length data_to_send + + -- And send the chunks through while locking the output place.... + liftIO $ bs_chunks `deepseq` withMVar session_output_mvar $ \ session_output -> do + let + header_frames = headerFrames stream_id bs_chunks effect + sendOutputToFramer session_output + $ TT.HeadersTrain_StFB (stream_id, header_frames, effect, data_output) + + GoAway_HM (stream_id, _effect) -> do + -- This is in charge of sending an interrupt message to the framer + requestTermination stream_id NH2.NoError + + PushPromise_HM (parent_stream_id, child_stream_id, promise_headers, effect) -> do + + encode_dyn_table_mvar <- view toEncodeHeaders + encode_dyn_table <- liftIO $ takeMVar encode_dyn_table_mvar + + (new_dyn_table, data_to_send ) <- liftIO $ HP.encodeHeader HP.defaultEncodeStrategy encode_dyn_table promise_headers + liftIO $ putMVar encode_dyn_table_mvar new_dyn_table + + -- Now split the bytestring in chunks of the needed size.... + bs_chunks <- return $! bytestringChunk use_chunk_length data_to_send + + -- And send the chunks through while locking the output place.... + liftIO $ withMVar session_output_mvar $ \ session_output -> do + let + pp_frames = pushPromiseFrames parent_stream_id child_stream_id bs_chunks effect + sendOutputToFramer session_output $ TT.PriorityTrain_StFB pp_frames + + where + + chunksToSequence :: + ( NH2.FrameFlags -> B.ByteString -> TT.OutputFrame) + -> ( NH2.FrameFlags -> B.ByteString -> TT.OutputFrame) + -> [B.ByteString] + -> Bool + -> [TT.OutputFrame] + chunksToSequence + transform_first + _transform_middle + (last_chunk:[]) + True -- If it is first, and last + = + [transform_first (NH2.setEndHeader NH2.defaultFlags) last_chunk] + chunksToSequence + _transform_first + transform_middle + (last_chunk:[]) + False -- It is not first, but last + = + [transform_middle (NH2.setEndHeader NH2.defaultFlags) last_chunk] + chunksToSequence + transform_first + transform_middle + (chunk:rest) + True -- If it is first, but not last + = + (transform_first NH2.defaultFlags chunk):(chunksToSequence transform_first transform_middle rest False) + chunksToSequence + transform_first + transform_middle + (chunk:rest) + False -- It is not first, and not last + = + (transform_middle NH2.defaultFlags chunk):(chunksToSequence transform_first transform_middle rest False) + chunksToSequence _ _ [] _ = error "ChunkingEmptySetOfHeaders!!" + + headerFrames :: GlobalStreamId -> [B.ByteString] -> Effect -> [TT.OutputFrame] + headerFrames stream_id chunks effect = + chunksToSequence + ( \ flags chunk -> ( + NH2.EncodeInfo { + NH2.encodeFlags = flags + ,NH2.encodeStreamId = stream_id + ,NH2.encodePadding = Nothing }, + NH2.HeadersFrame Nothing chunk, + effect + ) + ) + ( \ flags chunk -> ( + NH2.EncodeInfo { + NH2.encodeFlags = flags + ,NH2.encodeStreamId = stream_id + ,NH2.encodePadding = Nothing }, + NH2.ContinuationFrame chunk, + effect + ) + ) + chunks + True + + pushPromiseFrames :: GlobalStreamId -> GlobalStreamId -> [B.ByteString] -> Effect -> [TT.OutputFrame] + pushPromiseFrames parent_stream_id child_stream_id chunks effect = + chunksToSequence + ( \ flags chunk -> ( + NH2.EncodeInfo { + NH2.encodeFlags = flags + ,NH2.encodeStreamId = parent_stream_id + ,NH2.encodePadding = Nothing }, + NH2.PushPromiseFrame child_stream_id chunk, + effect + ) + ) + ( \ flags chunk -> ( + NH2.EncodeInfo { + NH2.encodeFlags = flags + ,NH2.encodeStreamId = parent_stream_id + ,NH2.encodePadding = Nothing }, + NH2.ContinuationFrame chunk, + effect + ) + ) + chunks + True + + +bytestringChunk :: Int -> B.ByteString -> [B.ByteString] +bytestringChunk len s | (B.length s) < len = [ s ] +bytestringChunk len s = h:(bytestringChunk len xs) + where + (h, xs) = B.splitAt len s + + +-- This function works for HTTP/2 client sessions only... +sessionPollThread :: SessionData -> Chan HeaderOutputMessage -> IO () +sessionPollThread session_data headers_output = do + let + pending_requests_mvar = session_data ^. (simpleClient . pendingRequests_ClS) + client_next_stream_mvar = session_data ^. (simpleClient . nextStream_ClS) + response2waiter = session_data ^. (simpleClient . response2Waiter_ClS) + for_worker_thread = session_data ^. forWorkerThread + session_input = session_data ^. sessionInput + + ((headers, input_data_stream), response_mvar) <- takeMVar pending_requests_mvar + + new_stream_id <- modifyMVar client_next_stream_mvar (\ n -> return (n + 1, n) ) + let + worker_environment = + set + streamId_WTE + new_stream_id + for_worker_thread + effects = defaultEffects + + -- Store the response place + new_stream_id `seq` H.insert response2waiter new_stream_id response_mvar + + + -- NON-tested code + output_mvar <- newEmptyMVar + + -- Start by sending the headers of the request + liftIO $ writeChan headers_output $ NormalResponse_HM (new_stream_id, headers, effects, output_mvar) + + _ <- liftIO . forkIOExc "s2f6" $ do + either_e0 <- E.try $ runReaderT + (clientWorkerThread new_stream_id output_mvar input_data_stream ) + worker_environment + case either_e0 :: Either HTTP500PrecursorException () of + Left _ -> writeChan session_input $ InternalAbortStream_SIC new_stream_id + Right _ -> return () + + -- E.catch + -- (runReaderT + -- (clientWorkerThread new_stream_id effects headers_sent input_data_stream ) + -- worker_environment + -- ) + -- ( + -- ( \ _ -> do + -- -- Actions to take when the thread breaks.... + -- writeChan session_input InternalAbort_SIC + -- ) + -- :: HTTP500PrecursorException -> IO () + -- ) + + sessionPollThread session_data headers_output + + +clientWorkerThread :: GlobalStreamId -> MVar TT.OutputDataFeed -> InputDataStream -> WorkerMonad () +clientWorkerThread stream_id output_mvar input_data_stream = do + -- And now work on sending the data, if any... + _ <- liftIO . ReT.runResourceT . runConduit $ + input_data_stream + `fuseBothMaybe` + sendDataOfStream stream_id output_mvar + return () + + +clientSideTerminate :: ClientState -> ConnectionCloseReason -> IO () +clientSideTerminate client_state reason = do + let + terminateOnQueue :: ConnectionCloseReason -> MVar (Message, MVar RequestResult) -> IO () + terminateOnQueue reason' q = do + w <- tryTakeMVar q + case w of + Just (_, m) -> do + _ <- tryPutMVar m (Left reason') return () Nothing -> diff --git a/hs-src/SecondTransfer/Http2/TransferTypes.hs b/hs-src/SecondTransfer/Http2/TransferTypes.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Http2/TransferTypes.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ExistentialQuantification, TemplateHaskell, DeriveDataTypeable, Rank2Types, OverloadedStrings #-} +module SecondTransfer.Http2.TransferTypes ( + SessionOutputPacket + , SessionOutputCommand (..) + , GlobalStreamId + , SessionToFramerBlock (..) + , OutputFrame + , OutputDataFeed + ) where + +--import Control.Lens + +--import qualified Network.HPACK as HP +import qualified Data.ByteString as B +import qualified Network.HTTP2 as NH2 +import Control.Concurrent (MVar) + +import SecondTransfer.MainLoop.CoherentWorker ( + Effect(..) + ) + + + +type OutputFrame = (NH2.EncodeInfo, NH2.FramePayload, Effect) + +type GlobalStreamId = Int + +-- | Commands that the sessions sends to the framer which concern the whole +-- session +data SessionOutputCommand = + -- Command sent to the framer to close the session as harshly as possible. The framer + -- will pick its own last valid stream. + CancelSession_SOC !NH2.ErrorCodeId + -- Command sent to the framer to close the session specifying a specific last-stream. + | SpecificTerminate_SOC !GlobalStreamId !NH2.ErrorCodeId + deriving Show + + +type OutputDataFeed = B.ByteString + + +-- | Signals that the Session sends to the Framer concerning normal operation, including +-- high-priority data to send (in priority trains, already formatted), and a command to +-- start the output machinery for a new stream +data SessionToFramerBlock = + Command_StFB !SessionOutputCommand + | PriorityTrain_StFB [OutputFrame] + | HeadersTrain_StFB (GlobalStreamId, [OutputFrame], Effect, MVar OutputDataFeed) + -- stream id, the headers of the response, + -- the effect provided by the worker, the mvar where data is put. +-- | StartDataOutput_StFB (GlobalStreamId, MVar DataAndEffect ) -- ^ An empty string shall signal end of data + + +type SessionOutputPacket = SessionToFramerBlock diff --git a/hs-src/SecondTransfer/IOCallbacks/Botcher.hs b/hs-src/SecondTransfer/IOCallbacks/Botcher.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/Botcher.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ForeignFunctionInterface, TemplateHaskell, Rank2Types, FunctionalDependencies, OverloadedStrings #-} + +-- Module in charge of inserting noise in the middle of some communications, to see how advanced are +-- our error-handling capabilities.... +-- + +module SecondTransfer.IOCallbacks.Botcher ( + insertNoise + ) where + +import Control.Concurrent +import qualified Control.Exception as E + +import Data.Tuple (swap) +import Data.Typeable (Proxy(..)) +import Data.Maybe (fromMaybe) +import Data.IORef +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as Bu +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Unsafe as Un + +import Control.Lens ( (^.), makeLenses, + --set, Lens' + ) +import Data.IORef + +-- Import all of it! +import SecondTransfer.IOCallbacks.Types + + +insertNoise :: Int -> B.ByteString -> IOCallbacks -> IO IOCallbacks +insertNoise offset noise (IOCallbacks push pull bpa ca) = + do + written_data <- newIORef 0 + recv_data <- newIORef 0 + let + npush bs = do + n <- readIORef written_data + if n > offset + then + push . LB.fromStrict $ noise + else do + atomicModifyIORef' written_data $ \ nn -> (nn + (fromIntegral $ LB.length bs), ()) + push bs + npull n = do + rc <- readIORef recv_data + if rc > offset + then + return noise + else do + g <- pull n + putStrLn . show $ ( B.length g /= n) + atomicModifyIORef' recv_data $ \ nn -> (nn + (fromIntegral $ B.length g), ()) + return g + + nbpa cb = do + rc <- readIORef recv_data + if rc > offset + then + return noise + else do + g <- bpa cb + atomicModifyIORef' recv_data $ \ nn -> (nn + (fromIntegral $ B.length g), ()) + return g + + + return $ IOCallbacks npush npull nbpa ca diff --git a/hs-src/SecondTransfer/IOCallbacks/Coupling.hs b/hs-src/SecondTransfer/IOCallbacks/Coupling.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/Coupling.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE ExistentialQuantification, TemplateHaskell, DeriveDataTypeable, Rank2Types, OverloadedStrings #-} +module SecondTransfer.IOCallbacks.Coupling ( + Coupling + , couple + , breakCoupling + , sendSourceToIO + , iocallbacksToSink + , popIOCallbacksIntoExistance + , IOCSideA + , IOCSideB + )where + +import Control.Lens +import Control.Concurrent +import Control.Monad.IO.Class (liftIO, MonadIO) +import qualified Control.Exception as E + +import Data.IORef +--import Data.Typeable +import Data.Conduit +import qualified Data.Conduit.List as DCL + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Bu + + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.Exception (IOProblem, NoMoreDataException(..), forkIOExc) + + +-- | A coupling between two IOCallbacks. It is breakable... +data Coupling = Coupling { + _breakNow_Cou :: MVar () + } + +makeLenses ''Coupling + +-- TODO: Consider if we must report errors! how do we do that? Right now I'll re-throw exceptions, +-- but since this runs in its own thread, nobody will notice. A better coping strategy would +-- be to perhaps store the exception somewhere. +pump :: String -> MVar () -> BestEffortPullAction -> PushAction -> IO () +pump tag break_now pull push = do + let + go = do + must_finish <- tryTakeMVar break_now + case must_finish of + Nothing -> do + either_datum <- E.try (pull True) :: IO (Either IOProblem B.ByteString) + must_finish' <- tryTakeMVar break_now + case (must_finish', either_datum) of + + (Nothing, Right datum) -> do + either_ok <- E.try (push . LB.fromStrict $ datum) :: IO (Either IOProblem () ) + case either_ok of + Right _ -> go + + Left _e -> do + _succeeded <- tryPutMVar break_now () + return () + + (Just (), _) -> + return () + + (Nothing, Left _e ) -> do + _succeeded <- tryPutMVar break_now () + return () + + Just _ -> + return () + go + + +-- | Connects two IO callbacks so that data received in one is sent to the +-- other. +couple :: IOCallbacks -> IOCallbacks -> IO Coupling +couple a b = + do + break_now_mvar <- newEmptyMVar + + _pump_thread1 <- forkIOExc "pump1" $ pump "1to2" break_now_mvar ( a ^. bestEffortPullAction_IOC ) ( b ^. pushAction_IOC) + _pump_thread2 <- forkIOExc "pump2 "$ pump "2to1" break_now_mvar ( b ^. bestEffortPullAction_IOC ) ( a ^. pushAction_IOC) + + return Coupling { + _breakNow_Cou = break_now_mvar + } + + +breakCoupling :: Coupling -> IO () +breakCoupling coupling = do + _succeeded <- tryPutMVar (coupling ^. breakNow_Cou ) () + return () + + +iocallbacksToSink :: MonadIO m => IOCallbacks -> Sink LB.ByteString m () +iocallbacksToSink ioc = DCL.mapM_ ( + \ s -> do + --putStrLn $ "send: " ++ (show s) + liftIO $ ioc ^. pushAction_IOC $ s + ) + + +-- | Sends the data coming from the source to the IOCallbacks. +-- No exceptions are handled here. This consumes the thread until +-- it finishes. The iocallbacks is not closed. +sendSourceToIO :: MonadIO m => Source m LB.ByteString -> IOCallbacks -> m () +sendSourceToIO source ioc = + source $$ iocallbacksToSink ioc + +data SideDatum = SideDatum { + _dt_SD :: IORef Bu.Builder + , _dt_M :: MVar () + } + +newSideDatum :: IO SideDatum +newSideDatum = + do + r <- newIORef mempty + m <- newEmptyMVar + return SideDatum { _dt_SD = r , _dt_M = m} + +makeLenses ''SideDatum + +data IOCTransit = IOCTransit { + _aToB_IOCT :: SideDatum + , _bToA_IOCT :: SideDatum + , _closed_IOCT :: MVar () + } + +makeLenses ''IOCTransit + +newtype IOCSideA = IOCSideA (IOCTransit, IOCallbacks) + +newtype IOCSideB = IOCSideB (IOCTransit, IOCallbacks) + + +popIOCallbacksIntoExistance :: IO (IOCSideA, IOCSideB) +popIOCallbacksIntoExistance = do + sd1 <- newSideDatum + sd2 <- newSideDatum + closed <- newEmptyMVar + let + t = IOCTransit { + _aToB_IOCT = sd1 + , _bToA_IOCT = sd2 + , _closed_IOCT = closed + } + let + action_set_a = popActions t aToB_IOCT bToA_IOCT + action_set_b = popActions t bToA_IOCT aToB_IOCT + return + ( + IOCSideA (t, action_set_a), + IOCSideB (t, action_set_b) + ) + +popActions :: IOCTransit -> Lens' IOCTransit SideDatum -> Lens' IOCTransit SideDatum -> IOCallbacks +popActions t pullside pushside = + let + + throwIfNeeded :: IO () + throwIfNeeded = do + m <- tryReadMVar (t ^. closed_IOCT) + case m of + Nothing -> return () + Just _ -> E.throwIO NoMoreDataException + + push_action :: LB.ByteString -> IO () + push_action datum = do + --putStrLn . show $ "PUSHED" `mappend` datum + throwIfNeeded + atomicModifyIORef' (t ^. pushside . dt_SD) $ \ bu -> (bu `mappend` (Bu.lazyByteString datum), () ) + -- Notify the other side that there is more data + _ <- tryPutMVar (t ^. pushside . dt_M) () + return () + + best_effort_pull_action can_block + | can_block = do + throwIfNeeded + hath_data <- atomicModifyIORef' ( t ^. pullside . dt_SD ) $ \ cnt -> (mempty, cnt) + let + hath_data_bs = Bu.toLazyByteString hath_data + if LB.length hath_data_bs > 0 + then + return $ LB.toStrict hath_data_bs + else do + _ <- takeMVar (t ^. pullside . dt_M) + best_effort_pull_action True + | otherwise = do + throwIfNeeded + hath_data <- atomicModifyIORef' ( t ^. pullside . dt_SD ) $ \ cnt -> (mempty, cnt) + let + hath_data_bs = LB.toStrict . Bu.toLazyByteString $ hath_data + return hath_data_bs + + pull_action n = (LB.toStrict . Bu.toLazyByteString ) <$> (pull_action' n mempty 0) + + pull_action' :: Int -> Bu.Builder -> Int -> IO Bu.Builder + pull_action' asked bu nhath = do + throwIfNeeded + hath_data <- atomicModifyIORef' ( t ^. pullside . dt_SD ) $ \ cnt -> (mempty, cnt) + let + hath_data_bs = Bu.toLazyByteString hath_data + case fromIntegral $ LB.length hath_data_bs of + ln | (ln + nhath) < asked -> do + let + nbu = bu `mappend` hath_data + _ <- takeMVar (t ^. pullside . dt_M) + pull_action' asked nbu (ln + nhath) + + | (ln + nhath) == asked -> + return $ bu `mappend` hath_data + + | (ln + nhath) > asked -> do + let + complete_thing = bu `mappend` hath_data + (ret, keep) = LB.splitAt (fromIntegral asked) . Bu.toLazyByteString $ complete_thing + atomicModifyIORef' ( t ^. pullside . dt_SD ) $ \ cnt -> ( Bu.lazyByteString keep `mappend` cnt, ()) + _ <- tryPutMVar ( t ^. pullside . dt_M ) () + return . Bu.lazyByteString $ ret + + | otherwise -> error "Function supposed to be total" + + close_action = do + _ <- tryPutMVar (t ^. closed_IOCT ) () + return () + + in IOCallbacks { + _pushAction_IOC = push_action + , _pullAction_IOC = pull_action + , _bestEffortPullAction_IOC = best_effort_pull_action + , _closeAction_IOC = close_action + } + + +instance IOChannels IOCSideA where + handshake (IOCSideA (_t,ioc)) = return ioc + +instance IOChannels IOCSideB where + handshake (IOCSideB (_t,ioc)) = return ioc diff --git a/hs-src/SecondTransfer/IOCallbacks/SaveFragment.hs b/hs-src/SecondTransfer/IOCallbacks/SaveFragment.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/SaveFragment.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ExistentialQuantification, TemplateHaskell, DeriveDataTypeable #-} +module SecondTransfer.IOCallbacks.SaveFragment ( + SaveReadFragment + , newSaveReadFragment + ) where + +import Control.Lens +import Control.Concurrent + +--import Data.IORef +--import Data.Typeable + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +--import qualified Data.ByteString.Builder as Bu + +import SecondTransfer.IOCallbacks.Types + + +data SaveReadFragment = SaveReadFragment { + _inner_SRF :: IOCallbacks + , _fragment_SRF :: MVar B.ByteString + } + +makeLenses ''SaveReadFragment + + +pushAction :: SaveReadFragment -> LB.ByteString -> IO () +pushAction srf what = (srf ^. inner_SRF . pushAction_IOC ) what + + +bestEffortPullAction :: SaveReadFragment -> Bool -> IO B.ByteString +bestEffortPullAction srf can_block = do + maybe_fragment <- tryTakeMVar (srf ^. fragment_SRF ) + case maybe_fragment of + Nothing -> (srf ^. inner_SRF . bestEffortPullAction_IOC ) can_block + Just fragment -> return fragment + + +closeAction :: SaveReadFragment -> IO () +closeAction srf = do + _ <- tryTakeMVar (srf ^. fragment_SRF) + srf ^. inner_SRF . closeAction_IOC + + +newSaveReadFragment :: IOCallbacks -> B.ByteString -> IO SaveReadFragment +newSaveReadFragment io_callbacks fragment = do + fragment_mvar <- newMVar fragment + return SaveReadFragment { + _inner_SRF = io_callbacks + , _fragment_SRF = fragment_mvar + } + + +instance IOChannels SaveReadFragment where + + handshake srf = do + pull_action_wrapping <- newPullActionWrapping $ bestEffortPullAction srf + + return $ IOCallbacks { + _pushAction_IOC = pushAction srf + , _pullAction_IOC = pullFromWrapping' pull_action_wrapping + , _bestEffortPullAction_IOC = bestEffortPullFromWrapping pull_action_wrapping + , _closeAction_IOC = closeAction srf + } diff --git a/hs-src/SecondTransfer/IOCallbacks/SocketServer.hs b/hs-src/SecondTransfer/IOCallbacks/SocketServer.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/SocketServer.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module SecondTransfer.IOCallbacks.SocketServer( + SocketIOCallbacks + , TLSServerSocketIOCallbacks (..) + , createAndBindListeningSocket + , createAndBindListeningSocketNSSockAddr + , socketIOCallbacks + + -- ** Socket server with callbacks + , tcpServe + , tlsServe + + -- ** Socket server with iterators + , tcpItcli + , tlsItcli + ) where + + +import Control.Concurrent (threadDelay) +import qualified Control.Exception as E +--import Control.Lens (makeLenses, (^.)) +import Control.Monad.IO.Class (liftIO) + +import Data.Conduit +import qualified Data.Conduit.List as CL + +--import qualified Data.ByteString as B +--import qualified Data.ByteString.Lazy as LB +--import Data.ByteString.Char8 (pack, unpack) +--import Data.List (find) + +-- import System.Exit +--import System.Posix.Signals +import System.IO.Error (ioeGetErrorString) + +import qualified Network.Socket as NS +--import qualified Network.Socket.ByteString as NSB + + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.IOCallbacks.WrapSocket (socketIOCallbacks, SocketIOCallbacks, HasSocketPeer(..)) +--import SecondTransfer.Exception (NoMoreDataException(..)) +#include "instruments.cpphs" + + +-- | Simple alias to SocketIOCallbacks where we expect +-- encrypted contents +newtype TLSServerSocketIOCallbacks = TLSServerSocketIOCallbacks SocketIOCallbacks + deriving IOChannels + +instance TLSEncryptedIO TLSServerSocketIOCallbacks +instance TLSServerIO TLSServerSocketIOCallbacks + +instance HasSocketPeer TLSServerSocketIOCallbacks where + getSocketPeerAddress (TLSServerSocketIOCallbacks s) = getSocketPeerAddress s + +-- | Creates a listening socket at the provided network address (potentially a local interface) +-- and the given port number. It returns the socket. This result can be used by the function +-- tcpServe below +createAndBindListeningSocket :: String -> Int -> IO NS.Socket +createAndBindListeningSocket hostname portnumber = do + the_socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol + addr_info0 : _ <- NS.getAddrInfo Nothing (Just hostname) Nothing + addr_info1 <- return $ addr_info0 { + NS.addrFamily = NS.AF_INET + , NS.addrSocketType = NS.Stream + , NS.addrAddress = + (\ (NS.SockAddrInet _ a) -> NS.SockAddrInet (fromIntegral portnumber) a) + (NS.addrAddress addr_info0) + } + host_address <- return $ NS.addrAddress addr_info1 + NS.setSocketOption the_socket NS.ReusePort 1 + NS.setSocketOption the_socket NS.RecvBuffer 32000 + NS.setSocketOption the_socket NS.SendBuffer 32000 + -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but + -- not very needed since the TLS wrapping will inflate the packet well beyond that size. + -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat + -- + -- NS.setSocketOption the_socket NS.RecvLowWater 8 + -- + NS.setSocketOption the_socket NS.NoDelay 1 + NS.bind the_socket host_address + NS.listen the_socket 20 + -- bound <- NS.isBound the_socket + return the_socket + +-- | Same as above, but it takes a pre-built address +createAndBindListeningSocketNSSockAddr :: NS.SockAddr -> IO NS.Socket +createAndBindListeningSocketNSSockAddr host_addr = do + the_socket <- case host_addr of + NS.SockAddrInet _ _ -> NS.socket NS.AF_INET NS.Stream NS.defaultProtocol + NS.SockAddrUnix _ -> NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol + _ -> error "NetworkAddressTypeNotHandled" + NS.setSocketOption the_socket NS.ReusePort 1 + NS.setSocketOption the_socket NS.RecvBuffer 32000 + NS.setSocketOption the_socket NS.SendBuffer 32000 + -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but + -- not very needed since the TLS wrapping will inflate the packet well beyond that size. + -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat + -- + -- NS.setSocketOption the_socket NS.RecvLowWater 8 + -- + NS.setSocketOption the_socket NS.NoDelay 1 + NS.bind the_socket host_addr + NS.listen the_socket 20 + -- bound <- NS.isBound the_socket + return the_socket + + +-- | Simple TCP server. You must give a very short action, as the action +-- is run straight in the calling thread. +-- For a typical server, you would be doing a forkIO in the provided action. +-- Do prefer to use tcpItcli directly. +tcpServe :: NS.Socket -> ( NS.Socket -> IO () ) -> IO () +tcpServe listen_socket action = + tcpItcli listen_socket $$ CL.mapM_ (action . fst) + + +-- | Itcli is a word made from "ITerate-on-CLIents". This function makes an iterated +-- listen... +tcpItcli :: NS.Socket -> Source IO (NS.Socket, NS.SockAddr) +tcpItcli listen_socket = + -- NOTICE: The messages below should be considered traps. Whenever one + -- of them shows up, we have hit a new abnormal condition that should + -- be learn from + do + let + report_abnormality = do + putStrLn "ERROR: TCP listen abstraction undone!!" + -- TODO: System interrupts propagates freely! + iterate' = do + either_x <- liftIO . E.try $ NS.accept listen_socket + case either_x of + Left e | ioeGetErrorString e == "resource exhausted" -> do + liftIO $ threadDelay (1000 * 1000) + iterate' + | ioeGetErrorString e == "signal" -> do + -- TODO: Some signals here should be processed differently, most likely!! + return () + | otherwise -> liftIO $ do + -- TODO: Handle other interesting types of IOErrors in the loop above... + putStrLn $ "XXERR: " ++ ioeGetErrorString e + E.throwIO $ e + Right (new_socket, sock_addr) -> do + yieldOr (new_socket, sock_addr) report_abnormality + iterate' + iterate' + + +-- | Convenience function to create a TLS server. You are in charge of actually setting +-- up the TLS session, this only receives a type tagged with the IO thing... +-- Notice that the action should be short before actually forking towards something doing +-- the rest of the conversation. If you do the TLS handshake in this thread, you will be in +-- trouble when more than one client try to handshake simultaeneusly... ibidem if one of the +-- clients blocks the handshake. +tlsServe :: NS.Socket -> ( TLSServerSocketIOCallbacks -> IO () ) -> IO () +tlsServe listen_socket tls_action = + tcpServe listen_socket tcp_action + where + tcp_action active_socket = do + socket_io_callbacks <- socketIOCallbacks active_socket + tls_action (TLSServerSocketIOCallbacks socket_io_callbacks) + + +tlsItcli :: NS.Socket -> Source IO (TLSServerSocketIOCallbacks, NS.SockAddr) +tlsItcli listen_socket = + fuse + (tcpItcli listen_socket) + ( CL.mapM + $ \ (active_socket, address) -> do + socket_io_callbacks <- socketIOCallbacks active_socket + return (TLSServerSocketIOCallbacks socket_io_callbacks ,address) + ) diff --git a/hs-src/SecondTransfer/IOCallbacks/Types.hs b/hs-src/SecondTransfer/IOCallbacks/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/Types.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE ExistentialQuantification, TemplateHaskell, DeriveDataTypeable #-} +module SecondTransfer.IOCallbacks.Types ( + -- | Functions for passing data to external parties + -- The callbacks here should have a blocking behavior and not + -- return empty results unless at end of file. + + -- * Fundamental types and accessors + PushAction + , PullAction + , BestEffortPullAction + , Attendant + , CloseAction + , IOCallbacks (..) + + , pushAction_IOC + , pullAction_IOC + , closeAction_IOC + , bestEffortPullAction_IOC + + -- * Classifying IO callbacks + -- $ classifiers + , IOChannels (..) + , PlainTextIO + , TLSEncryptedIO + , TLSServerIO + , TLSClientIO + , SOCKS5Preface + , ConnectionData (..) + , addr_CnD + + -- * Utility functions + , PullActionWrapping + , newPullActionWrapping + , pullFromWrapping' + , bestEffortPullFromWrapping + ) where + + +import Control.Lens + +import Data.IORef + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Bu + +import SecondTransfer.Sessions.HashableSockAddr (HashableSockAddr) + +-- | Callback type to push data to a channel. Part of this +-- interface is the abstract exception type IOProblem. Throw an +-- instance of it from here to notify the session that the connection has +-- been broken. There is no way to signal "normal termination", since +-- HTTP/2's normal termination can be observed at a higher level when a +-- GO_AWAY frame is seen. +type PushAction = LB.ByteString -> IO () + +-- | Callback type to pull data from a channel in a best-effort basis. +-- When the first argument is True, the data-providing backend can +-- block if the input buffers are empty and await for new data. +-- Otherwise, it will return immediately with an empty ByteString +type BestEffortPullAction = Bool -> IO B.ByteString + +-- | Callback type to pull data from a channel. The same +-- as to PushAction applies to exceptions thrown from +-- there. The first argument is the number of bytes to +-- pull from the medium. Barring exceptions, we always +-- know how many bytes we are expecting with HTTP/2. +type PullAction = Int -> IO B.ByteString + +-- | Generic implementation of PullAction from BestEffortPullAction, where we keep around +-- any leftovers data ... +newtype PullActionWrapping = PullActionWrapping (IORef (Bu.Builder,Int), BestEffortPullAction) + +-- The type above contains stuff already read, its length and the the action + +newPullActionWrapping :: BestEffortPullAction -> IO PullActionWrapping +newPullActionWrapping best_effort_pull_action = do + bu_ref <- newIORef (mempty, 0) + return $ PullActionWrapping (bu_ref, best_effort_pull_action) + + +-- | The type of this function is also PullActionWrapping -> PullAction +-- There should be only one reader concurrently. +pullFromWrapping' :: PullActionWrapping -> Int -> IO B.ByteString +pullFromWrapping' (PullActionWrapping (x, bepa)) n = do + (hathz, len) <- readIORef x + let + nn = fromIntegral n + pullData hathz' len' = + if n <= len' + then do + let + hathz_lb = Bu.toLazyByteString hathz' + to_return = LB.toStrict . LB.take nn $ hathz_lb + new_hazth = Bu.lazyByteString . LB.drop nn $ hathz_lb + return (to_return, new_hazth, len' - n) + else do + -- Need to read more + more <- bepa True + -- Append + let + new_len = fromIntegral len' + B.length more + new_hazth = hathz' `mappend` Bu.byteString more + pullData new_hazth new_len + (to_return, new_hazth, new_len) <- pullData hathz len + writeIORef x (new_hazth, new_len) + return to_return + + +bestEffortPullFromWrapping :: PullActionWrapping -> Bool -> IO B.ByteString +bestEffortPullFromWrapping (PullActionWrapping (x, bepa)) False = do + (hathz, len) <- atomicModifyIORef' x $ \ (h,l) -> ((mempty,0), (h,l)) + if len > 0 + then do + return . LB.toStrict . Bu.toLazyByteString $ hathz + else do + -- At least we ought to try + bepa False + + +bestEffortPullFromWrapping (PullActionWrapping (x, bepa)) True = do + (hathz, len) <- atomicModifyIORef' x $ \ (h,l) -> ((mempty,0), (h,l)) + if len > 0 + then do + return . LB.toStrict . Bu.toLazyByteString $ hathz + else do + bepa True + + +-- | Callback that the session calls to realease resources +-- associated with the channels. Take into account that your +-- callback should be able to deal with non-clean shutdowns +-- also, for example, if the connection to the remote peer +-- is severed suddenly. +type CloseAction = IO () + +-- | A set of functions describing how to do I/O in a session. +-- There is one rule for IOCallbacks: only one user of it. +-- That is, only one can write, only one can read concurrently. +-- We don't protect for anything else, so concurrent read and +-- writes would result in terrible things happening. +data IOCallbacks = IOCallbacks { + -- | put some data in the channel + _pushAction_IOC :: PushAction, + -- | get exactly this much data from the channel. This function can + -- be used by HTTP/2 since lengths are pretty well built inside the + -- protocoll itself. An exception of type NoMoreDataException can be + -- raised from here inside if the channel is closed. This is done to + -- notify the caller that there is no more data. The alternative + -- would be to return an empty string, but that looks more hazardous + -- for the caller. + _pullAction_IOC :: PullAction, + -- | pull data from the channel, as much as the TCP stack wants to provide. + -- we have no option but use this one when talking HTTP/1.1, where the best + -- way to know the length is to scan until a Content-Length is found. + -- This will also raise NoMoreDataException when there is no more data. + -- Notice that with argument False, this may return an empty string. + _bestEffortPullAction_IOC :: BestEffortPullAction, + -- | this is called when we wish to close the channel. + _closeAction_IOC :: CloseAction + } + +makeLenses ''IOCallbacks + + +-- $classifiers +-- Sometimes we need to classify the IO callbacks according to the operations +-- that they support, so we also create the following classes. + +-- | An object a which is IOChannels +class IOChannels a where + -- | This method should only be invoked once for the a instance. + -- It will block/wait for any handshakes to complete, and only then + -- return a usable set of callbacks. + handshake :: a -> IO IOCallbacks + +-- | Data exchanged through this channel is plain text +class IOChannels a => PlainTextIO a +-- | Data exchanged through this channel is the data of a TLS session +class IOChannels a => TLSEncryptedIO a +-- | Data exchanged through this channel begins with a SOCKS5 negotiation +class IOChannels a => SOCKS5Preface a +-- | The agent putting and retrieving data in this side of the channel should +-- behave as a TLS server +class TLSEncryptedIO a => TLSServerIO a +-- | The agent putting and retrieving data in this side of the channel should +-- behave as a TLS client +class TLSEncryptedIO a => TLSClientIO a + +-- | PlainText wrapper +newtype PlainText = PlainText IOCallbacks +instance IOChannels PlainText where + handshake (PlainText io) = return io +instance PlainTextIO PlainText + +newtype TLSServer = TLSServer IOCallbacks +instance IOChannels TLSServer where + handshake (TLSServer io) = return io +instance TLSEncryptedIO TLSServer +instance TLSServerIO TLSServer + +-- | Some context related to a connection +newtype ConnectionData = ConnectionData { _addr_CnD :: Maybe HashableSockAddr } + +makeLenses ''ConnectionData + +-- | An Attendant is an entity that can speak a protocol, given +-- the presented I/O callbacks. It's work is to spawn a set +-- of threads to handle a client's session, and then return to +-- the caller. It shouldn'r busy the calling thread. +type Attendant = ConnectionData -> IOCallbacks -> IO () diff --git a/hs-src/SecondTransfer/IOCallbacks/WrapSocket.hs b/hs-src/SecondTransfer/IOCallbacks/WrapSocket.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/IOCallbacks/WrapSocket.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving, GADTs #-} +module SecondTransfer.IOCallbacks.WrapSocket ( + socketIOCallbacks + + , SocketIOCallbacks + , socket_SS + + , HasSocketPeer (..) + , SomeHasSocketPeer (..) + ) where + + +---import Control.Concurrent +import qualified Control.Exception as E +import Control.Lens (makeLenses, (^.)) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +--import Data.ByteString.Char8 (pack, unpack) +--import Data.List (find) + +import qualified Network.Socket as NS +import qualified Network.Socket.ByteString as NSB + + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.Exception + +-- | IOCallbacks around an active socket +data SocketIOCallbacks = SocketIOCallbacks { + _socket_SS :: NS.Socket + , _callbacks_SS :: IOCallbacks + } + +makeLenses ''SocketIOCallbacks + +instance IOChannels SocketIOCallbacks where + handshake s = return ( s ^. callbacks_SS ) + + +class HasSocketPeer a where + getSocketPeerAddress :: a -> IO NS.SockAddr + +data SomeHasSocketPeer where + -- = forall a . HasSocketPeer a => SomeHasSocketPeer a + SomeHasSocketPeer :: HasSocketPeer a => a -> SomeHasSocketPeer + + +instance HasSocketPeer SocketIOCallbacks where + getSocketPeerAddress s = NS.getPeerName $ s ^. socket_SS + + +-- | This function wraps an active socket (e.g., one where it is possible to send and receive data) +-- in something with a set of active callbacks +socketIOCallbacks :: NS.Socket -> IO SocketIOCallbacks +socketIOCallbacks socket = do + let + uhandler :: E.IOException -> IO a + uhandler = ((\ _e -> do + -- Preserve sockets!! + -- putStrLn $ E.displayException _e + close_action + E.throwIO NoMoreDataException + ) :: E.IOException -> IO a ) + + -- A socket is closed inmediately upon finding an exception. + -- The close action will be called many more times, of course, + -- since the entire program is very, very overzealous of + -- open sockets. + + -- We, of course, want exceptions to bubble from here. + push_action lazy_bs = -- keyedReportExceptions "pushAtSocket" $ + E.catch + (NSB.sendMany socket . LB.toChunks $ lazy_bs) + uhandler + + best_effort_pull_action _ = do + datum <- E.catch (NSB.recv socket 4096) uhandler + if B.length datum == 0 + then do + -- Pre-emptively close the socket, don't wait for anything else + close_action + E.throwIO NoMoreDataException + else do + return datum + + -- Exceptions on close are possible + close_action = E.finally + (ignoreException ioException () $ NS.shutdown socket NS.ShutdownBoth) + (ignoreException ioException () $ NS.close socket) + + pull_action_wrapping <- newPullActionWrapping best_effort_pull_action + let + pull_action = pullFromWrapping' pull_action_wrapping + best_effort_pull_action' = bestEffortPullFromWrapping pull_action_wrapping + io_callbacks = IOCallbacks { + _pushAction_IOC = push_action + , _pullAction_IOC = pull_action + , _bestEffortPullAction_IOC = best_effort_pull_action' + , _closeAction_IOC = close_action + } + return $ SocketIOCallbacks { + _socket_SS = socket + , _callbacks_SS = io_callbacks + } diff --git a/hs-src/SecondTransfer/MainLoop.hs b/hs-src/SecondTransfer/MainLoop.hs --- a/hs-src/SecondTransfer/MainLoop.hs +++ b/hs-src/SecondTransfer/MainLoop.hs @@ -1,32 +1,19 @@ module SecondTransfer.MainLoop ( + _nonce -#ifndef DISABLE_OPENSSL_TLS - -- * High level OpenSSL functions. - -- - -- | Use these functions to create your TLS-compliant +#ifndef DISABLE_OPENSSL_TLS + -- * High level OpenSSL functions. + -- + -- | Use these functions to create your TLS-compliant -- HTTP/2 server in a snap. - tlsServeWithALPN - ,tlsServeWithALPNAndFinishOnRequest + , tlsServeWithALPN #endif -#ifndef DISABLE_OPENSSL_TLS - , -#endif - enableConsoleLogging, - logit -#ifndef DISABLE_OPENSSL_TLS - ,TLSLayerGenericProblem(..) - ,FinishRequest(..) -#endif - - ) where + ) where +import SecondTransfer.TLS.CoreServer --- We don't need this module in the test suite, and stackage doesn't have a good --- enough OpenSSL library yet -#ifndef DISABLE_OPENSSL_TLS -import SecondTransfer.MainLoop.OpenSSL_TLS -#endif -import SecondTransfer.MainLoop.Logging (enableConsoleLogging,logit) +_nonce :: () +_nonce = undefined diff --git a/hs-src/SecondTransfer/MainLoop/ClientPetitioner.hs b/hs-src/SecondTransfer/MainLoop/ClientPetitioner.hs --- a/hs-src/SecondTransfer/MainLoop/ClientPetitioner.hs +++ b/hs-src/SecondTransfer/MainLoop/ClientPetitioner.hs @@ -5,7 +5,7 @@ --import Control.Lens --import Data.Conduit -import qualified Data.ByteString as B +-- import qualified Data.ByteString as B import SecondTransfer.MainLoop.CoherentWorker (Headers,InputDataStream) diff --git a/hs-src/SecondTransfer/MainLoop/CoherentWorker.hs b/hs-src/SecondTransfer/MainLoop/CoherentWorker.hs --- a/hs-src/SecondTransfer/MainLoop/CoherentWorker.hs +++ b/hs-src/SecondTransfer/MainLoop/CoherentWorker.hs @@ -20,6 +20,7 @@ , Perception(..) , Effect(..) , AwareWorker + , AwareWorkerStack , PrincipalStream(..) , PushedStreams , PushedStream(..) @@ -30,6 +31,7 @@ , TupledRequest , FragmentDeliveryCallback , InterruptEffect(..) + , PriorityEffect(..) , headers_RQ , inputData_RQ @@ -45,6 +47,7 @@ , streamId_Pr , sessionId_Pr , anouncedProtocols_Pr + , peerAddress_Pr , protocol_Pr , fragmentDeliveryCallback_Ef , priorityEffect_Ef @@ -59,12 +62,15 @@ import Control.Lens +import Control.Monad.Trans.Resource + import qualified Data.ByteString as B import Data.Conduit import Data.Foldable (find) import System.Clock (TimeSpec) import SecondTransfer.MainLoop.Protocol (HttpProtocolVersion) +import SecondTransfer.Sessions.Config (HashableSockAddr) -- | The name part of a header @@ -84,9 +90,18 @@ -- for responses. type Headers = [Header] +-- | Has kind * -> * +-- Used to allow for registered cleanup functions to be safely +-- called, even/specially in the event of a Browser/User hanging-up the +-- connection before the worker has finished doing its work. +-- Alleviates the need for handling async. execeptions. +type AwareWorkerStack = ResourceT IO + + -- |This is a Source conduit (see Haskell Data.Conduit library from Michael Snoyman) -- that you can use to retrieve the data sent by the peer piece-wise. -type InputDataStream = Source IO B.ByteString +-- +type InputDataStream = Source AwareWorkerStack B.ByteString -- | Data related to the request @@ -102,8 +117,10 @@ _startedTime_Pr :: TimeSpec, -- | Which protocol is serving the request _protocol_Pr :: HttpProtocolVersion, - -- | For new connections, probably a list of anounced protocols - _anouncedProtocols_Pr :: Maybe [B.ByteString] + -- | For new connections, probably a list of announced protocols + _anouncedProtocols_Pr :: Maybe [B.ByteString], + -- | tuple with something like the IPv4 number for the requesting host + _peerAddress_Pr :: Maybe HashableSockAddr } makeLenses ''Perception @@ -135,10 +152,11 @@ -- streams are not going to be sent to the client. type PushedStreams = [ IO PushedStream ] + -- | A source-like conduit with the data returned in the response. The -- return value of the conduit is a list of footers. For now that list can -- be anything (even bottom), I'm not handling it just yet. -type DataAndConclusion = ConduitM () B.ByteString IO Footers +type DataAndConclusion = ConduitM () B.ByteString AwareWorkerStack Footers -- | A pushed stream, represented by a list of request headers, @@ -165,32 +183,60 @@ data InterruptEffect = InterruptConnectionAfter_IEf -- ^ Close and send GoAway /after/ this stream finishes delivery |InterruptConnectionNow_IEf -- ^ Close and send GoAway /without/ delivering this stream. This implies that -- other fields of the PrincipalStream record will be ignored. - -- |InterruptThisStream_IEf -- ^ Just reset this stream, disabled for now. +-- | Valid priority effects +-- +-- +-- In certain circunstances a stream can use an internal priority, +-- not given by the browser and the protocol. Lowest values here are +-- given more priority. Default (when Nothing) is given zero. Cases +-- with negative numbers also work. Since higher numbers mean *lower* +-- priority, we often call this number *calm*, so that higher numbers +-- mean higher calm. +-- +-- Notice that SecondTransfer still assigns "system priorities" to frames +-- which are used before the priorities computed by this mechanism. +data PriorityEffect = + NoEffect_PrEf -- ^ Leaves on default priorities + | Uniform_PrEf !Int -- ^ Assigns a uniform priority to all data in this stream + | PerYield_PrEf Int [(Word, Word)] -- ^ Starts with the given priority, and as the sender crosses + -- each byte boundary in the first part of the pair, the calm + -- is raised (e.g., the priority is lowered), by the positive + -- number given as second part of the pair + +-- TODO: another kind of priority effect would be one here the priorities are +-- known in advance. Only problem here is determining if the action would +-- need to be in the resourcet monad or not.... + + -- | Sometimes a response needs to be handled a bit specially, -- for example by reporting delivery details back to the worker data Effect = Effect { - -- | A callback to be called whenever a data-packet for this stream is called. + -- | A callback to be called whenever a data-packet for this stream is . _fragmentDeliveryCallback_Ef :: Maybe FragmentDeliveryCallback -- | In certain circunstances a stream can use an internal priority, -- not given by the browser and the protocol. Lowest values here are -- given more priority. Default (when Nothing) is given zero. Cases -- with negative numbers also work. - ,_priorityEffect_Ef :: Maybe Int + ,_priorityEffect_Ef :: PriorityEffect -- | There are situations when it is desirable to close a stream or the entire -- connection. Use this member to indicate that. ,_interrupt_Ef :: Maybe InterruptEffect } +-- Quick instance of show +instance Show Effect where + show _ = "" + makeLenses ''Effect defaultEffects :: Effect defaultEffects = Effect { _fragmentDeliveryCallback_Ef = Nothing, - _priorityEffect_Ef = Nothing, + _priorityEffect_Ef = NoEffect_PrEf, _interrupt_Ef = Nothing } @@ -207,7 +253,6 @@ makeLenses ''PrincipalStream - -- | Main type of this library. You implement one of these for your server. -- This is a callback that the library calls as soon as it has -- all the headers of a request. For GET requests that's the entire request @@ -268,7 +313,7 @@ -- | If you want to skip the footers, i.e., they are empty, use this -- function to convert an ordinary Source to a DataAndConclusion. -nullFooter :: Source IO B.ByteString -> DataAndConclusion +nullFooter :: Source AwareWorkerStack B.ByteString -> DataAndConclusion nullFooter s = s =$= go where go = do diff --git a/hs-src/SecondTransfer/MainLoop/DebugMonitor.hs b/hs-src/SecondTransfer/MainLoop/DebugMonitor.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/MainLoop/DebugMonitor.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +module SecondTransfer.MainLoop.DebugMonitor ( + -- This is a simple monitoring utility.. +#ifdef SECONDTRANSFER_MONITORING + incCounter +#endif + ) where + + +#ifdef SECONDTRANSFER_MONITORING +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Concurrent.Chan + +import Control.Monad (unless) + +import Data.IORef +import Data.String +import System.IO (stderr,openFile) +import qualified System.IO as SIO +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Bch + +import System.IO.Unsafe (unsafePerformIO) +import System.Clock as Cl +import System.Posix.Files +import qualified Database.Redis as R + + +{-# NOINLINE outputHandle #-} +outputHandle :: IORef R.Connection +outputHandle = unsafePerformIO $ do + let + conn_info = R.defaultConnectInfo { + R.connectDatabase = 3 -- Let's take this cone + } + conn <- R.connect conn_info + R.runRedis conn $ R.flushdb + newIORef conn + +incCounter :: B.ByteString -> IO () +incCounter keyname = do + conn <- readIORef outputHandle + R.runRedis conn (R.incr keyname) + return () + +#endif diff --git a/hs-src/SecondTransfer/MainLoop/Disruptible.hs b/hs-src/SecondTransfer/MainLoop/Disruptible.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/MainLoop/Disruptible.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ExistentialQuantification #-} +module SecondTransfer.MainLoop.Disruptible ( + Disruptible (..) + , MonoDisruptible (..) + ) where + + +-- | This is an entity that can be disrupted and closed. Good to +-- force shutdown in some places. +class Disruptible d where + disrupt :: d -> IO () + + +-- | Monomorphic encapsulation of a Disruptible +data MonoDisruptible = forall d . Disruptible d => MonoDisruptible d + +instance Disruptible MonoDisruptible where + disrupt (MonoDisruptible d) = disrupt d diff --git a/hs-src/SecondTransfer/MainLoop/Internal.hs b/hs-src/SecondTransfer/MainLoop/Internal.hs --- a/hs-src/SecondTransfer/MainLoop/Internal.hs +++ b/hs-src/SecondTransfer/MainLoop/Internal.hs @@ -2,11 +2,10 @@ module SecondTransfer.MainLoop.Internal( readNextChunkAndContinue ,http2FrameLength - ,OutputFrame ,InputFrame - ) where + ) where import SecondTransfer.MainLoop.Framer(readNextChunkAndContinue) import SecondTransfer.Http2.Framer(http2FrameLength) -import SecondTransfer.Http2.Session(OutputFrame, InputFrame) +import SecondTransfer.Http2.Session(InputFrame) diff --git a/hs-src/SecondTransfer/MainLoop/Logging.hs b/hs-src/SecondTransfer/MainLoop/Logging.hs --- a/hs-src/SecondTransfer/MainLoop/Logging.hs +++ b/hs-src/SecondTransfer/MainLoop/Logging.hs @@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns, OverloadedStrings #-} module SecondTransfer.MainLoop.Logging ( - -- | Simple, no fuss enable logging - enableConsoleLogging - ,logWithExclusivity + nonce +#ifdef SECONDTRANSFER_MONITORING ,logit +#endif ) where import System.IO (stderr,openFile) @@ -13,42 +13,21 @@ import qualified Data.ByteString.Char8 as Bch -- Logging utilities -import System.Log.Formatter (simpleLogFormatter) -import System.Log.Handler (setFormatter, LogHandler) -import System.Log.Handler.Simple +--import System.Log.Formatter (simpleLogFormatter) +--import System.Log.Handler (setFormatter, LogHandler) +--import System.Log.Handler.Simple -- import System.Log.Handler.Syslog (Facility (..), Option (..), openlog) -import System.Log.Logger +--import System.Log.Logger import System.IO.Unsafe (unsafePerformIO) import System.Clock as Cl -import Control.Concurrent.MVar +--import Control.Concurrent.MVar import Control.Concurrent.Chan import Control.Concurrent - --- | Activates logging to terminal -enableConsoleLogging :: IO () -enableConsoleLogging = configureLoggingToConsole - - --- | Protect logging with a mutex... that is to say, --- this is a horrible hack and you should try to log --- as little as possible or nothing at all. This just --- works for instrumentation locks... -globallyLogWell :: MVar () -{-# NOINLINE globallyLogWell #-} -globallyLogWell = unsafePerformIO (newMVar () ) - --- | Used internally to avoid garbled logs -logWithExclusivity :: IO () -> IO () -logWithExclusivity a = withMVar globallyLogWell (const a ) - - -configureLoggingToConsole :: IO () -configureLoggingToConsole = do - s <- streamHandler stderr DEBUG >>= - \lh -> return $ setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg") - setLoggerLevels s +-- Simple thing to have a more generic logging utility +nonce :: () +nonce = undefined -- configureLoggingToSyslog :: IO () @@ -58,28 +37,7 @@ -- setLoggerLevels s -setLoggerLevels :: (LogHandler s) => s -> IO () -setLoggerLevels s = do - updateGlobalLogger rootLoggerName removeHandler - updateGlobalLogger "Session" ( - setHandlers [s] . - setLevel INFO - ) - updateGlobalLogger "OpenSSL" ( - setHandlers [s] . - setLevel DEBUG - ) - updateGlobalLogger "HTTP1" ( - setHandlers [s] . - setLevel DEBUG - ) - updateGlobalLogger "HTTP2" ( - setHandlers [s] . - setLevel DEBUG - ) - - - +#ifdef SECONDTRANSFER_MONITORING data Logit = Logit Cl.TimeSpec B.ByteString @@ -114,3 +72,5 @@ let lg = Logit time msg writeChan loggerChan lg + +#endif diff --git a/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.hs b/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.hs deleted file mode 100644 --- a/hs-src/SecondTransfer/MainLoop/OpenSSL_TLS.hs +++ /dev/null @@ -1,378 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, DeriveDataTypeable #-} -{-# OPTIONS_HADDOCK hide #-} -module SecondTransfer.MainLoop.OpenSSL_TLS( - tlsServeWithALPN - ,tlsServeWithALPNAndFinishOnRequest - -- ,tlsServeWithALPNOnce - - ,TLSLayerGenericProblem(..) - ,FinishRequest(..) - ) where - -import Control.Monad -import Control.Concurrent.MVar -import Control.Exception -import qualified Control.Exception as E -#ifndef IMPLICIT_APPLICATIVE_FOLDABLE -import Data.Foldable (foldMap) -#endif -import Data.Typeable -import Data.Monoid () -import Foreign -import Foreign.C - -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB -import Data.ByteString.Char8 (pack) -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Unsafe as BU - --- import System.Log.Logger - -import SecondTransfer.MainLoop.PushPullType -import SecondTransfer.MainLoop.Logging (logit) -import SecondTransfer.Exception - -#include "Logging.cpphs" - --- | Exceptions inheriting from `IOProblem`. This is thrown by the --- OpenSSL subsystem to signal that the connection was broken or that --- otherwise there was a problem at the SSL layer. -data TLSLayerGenericProblem = TLSLayerGenericProblem String - deriving (Show, Typeable) - - -instance Exception TLSLayerGenericProblem where - toException = toException . IOProblem - fromException x = do - IOProblem a <- fromException x - cast a - - -data InterruptibleEither a b = - Left_I a - |Right_I b - |Interrupted - - --- | Singleton type. Used in conjunction with an `MVar`. If the MVar is full, --- the fuction `tlsServeWithALPNAndFinishOnRequest` knows that it should finish --- at its earliest convenience and call the `CloseAction` for any open sessions. -data FinishRequest = FinishRequest - - --- These names are absolutely improper.... --- Session creator -data Connection_t --- Session -data Wired_t - -type Connection_Ptr = Ptr Connection_t -type Wired_Ptr = Ptr Wired_t - --- Actually, this makes a listener for new connections --- connection_t* make_connection(char* certificate_filename, char* privkey_filename, char* hostname, int portno, --- char* protocol_list, int protocol_list_len) -foreign import ccall "make_connection" makeConnection :: - CString -- cert filename - -> CString -- privkey_filename - -> CString -- hostname - -> CInt -- port - -> Ptr CChar -- protocol list - -> CInt -- protocol list length - -> IO Connection_Ptr - -allOk :: CInt -allOk = 0 - -badHappened :: CInt -badHappened = 1 - -timeoutReached :: CInt -timeoutReached = 3 - --- int wait_for_connection(connection_t* conn, wired_session_t** wired_session); -foreign import ccall "wait_for_connection" waitForConnection :: Connection_Ptr -> CInt -> Ptr Wired_Ptr -> IO CInt - --- int send_data(wired_session_t* ws, char* buffer, int buffer_size); -foreign import ccall "send_data" sendData :: Wired_Ptr -> Ptr CChar -> CInt -> IO CInt - --- int recv_data(wired_session_t* ws, char* inbuffer, int buffer_size, int* data_recvd); -foreign import ccall "recv_data" recvData :: Wired_Ptr -> Ptr CChar -> CInt -> Ptr CInt -> IO CInt - --- int recv_data_best_effort(wired_session_t* ws, char* inbuffer, int buffer_size, int can_wait, int* data_recvd); -foreign import ccall "recv_data_best_effort" recvDataBestEffort :: Wired_Ptr -> Ptr CChar -> CInt -> CInt -> Ptr CInt -> IO CInt - --- int get_selected_protocol(wired_session_t* ws){ return ws->protocol_index; } -foreign import ccall "get_selected_protocol" getSelectedProtocol :: Wired_Ptr -> IO CInt - --- void dispose_wired_session(wired_session_t* ws); -foreign import ccall "dispose_wired_session" disposeWiredSession :: Wired_Ptr -> IO () - -foreign import ccall "close_connection" closeConnection :: Connection_Ptr -> IO () - - -useBufferSize :: Int -useBufferSize = 4096 - - -type Protocols = [B.ByteString] - - -protocolsToWire :: Protocols -> B.ByteString -protocolsToWire protocols = - LB.toStrict . BB.toLazyByteString $ - foldMap (\ protocol - -> (BB.lazyByteString . LB.fromChunks) - [ B.singleton $ fromIntegral $ B.length protocol, - protocol - ] - ) protocols - - --- | Simple function to open -tlsServeWithALPN :: FilePath -- ^ Path to a certificate the server is going to use to identify itself. - -- Bear in mind that multiple domains can be served from the same HTTP/2 - -- TLS socket, so please create the HTTP/2 certificate accordingly. - -- Also, currently this function only accepts paths to certificates - -- or certificate chains in .pem format. - -> FilePath -- ^ Path to the key of your certificate. - -> String -- ^ Name of the network interface where you want to start your server - -> [(String, Attendant)] -- ^ List of protocol names and the corresponding `Attendant` to use for - -- each. This way you can serve both HTTP\/1.1 over TLS and HTTP\/2 in the - -- same socket. When no ALPN negotiation is present during the negotiation, - -- the first protocol in this list is used. - -> Int -- ^ Port to open to listen for connections. - -> IO () -tlsServeWithALPN certificate_filename key_filename interface_name attendants interface_port = do - - let protocols_bs = protocolsToWire $ fmap (\ (s,_) -> pack s) attendants - withCString certificate_filename $ \ c_certfn -> withCString key_filename $ \ c_keyfn -> withCString interface_name $ \ c_iname -> do - - connection_ptr <- BU.unsafeUseAsCStringLen protocols_bs $ \ (pchar, len) -> - makeConnection - c_certfn - c_keyfn - c_iname - (fromIntegral interface_port) - pchar - (fromIntegral len) - - when (connection_ptr == nullPtr) $ - throwIO $ TLSLayerGenericProblem "Could not create listening end" - - forever $ do - either_wired_ptr <- alloca $ \ wired_ptr_ptr -> - let - tryOnce = do - result_code <- waitForConnection connection_ptr defaultWaitTime wired_ptr_ptr - let - r = case result_code of - re | re == allOk -> do - p <- peek wired_ptr_ptr - return $ Right p - | re == timeoutReached -> tryOnce - | re == badHappened -> return $ Left ("A wait for connection failed" :: String) - r - in tryOnce - - case either_wired_ptr of - --- Disable a warning - Left _msg -> - return () - - Right wired_ptr -> do - - attendant_callbacks <- provideActions wired_ptr - - use_protocol <- getSelectedProtocol wired_ptr - - let - maybe_session_attendant = case fromIntegral use_protocol of - n | use_protocol >= 0 -> Just $ snd $ attendants !! n - -- Or just select the first one - | otherwise -> Just . snd . head $ attendants - - case maybe_session_attendant of - - Just session_attendant -> - E.catch - (session_attendant attendant_callbacks) - ((\ e -> - throwIO e - )::TLSLayerGenericProblem -> IO () ) - - - Nothing -> - return () - - --- | Interruptible version of `tlsServeWithALPN`. Use the extra argument to ask --- the server to finish: you pass an empty MVar and when you want to finish you --- just populate it. -tlsServeWithALPNAndFinishOnRequest :: FilePath - -> FilePath -- ^ Same as for `tlsServeWithALPN` - -> String -- ^ Same as for `tlsServeWithALPN` - -> [(String, Attendant)] -- ^ Same as for `tlsServeWithALPN` - -> Int -- ^ Same as for `tlsServeWithALPN` - -> MVar FinishRequest -- ^ Finish request, write a value here to finish serving - -> IO () -tlsServeWithALPNAndFinishOnRequest certificate_filename key_filename interface_name attendants interface_port finish_request = do - - let protocols_bs = protocolsToWire $ fmap (\ (s,_) -> pack s) attendants - withCString certificate_filename $ \ c_certfn -> withCString key_filename $ \ c_keyfn -> withCString interface_name $ \ c_iname -> do - - -- Create an accepting endpoint - connection_ptr <- BU.unsafeUseAsCStringLen protocols_bs $ \ (pchar, len) -> - makeConnection - c_certfn - c_keyfn - c_iname - (fromIntegral interface_port) - pchar - (fromIntegral len) - - -- Create a computation that accepts a connection, runs a session on it and recurses - let - recursion = do - -- Get a SSL session - either_wired_ptr <- alloca $ \ wired_ptr_ptr -> - let - tryOnce = do - result_code <- waitForConnection connection_ptr smallWaitTime wired_ptr_ptr - let - r = case result_code of - re | re == allOk -> do - p <- peek wired_ptr_ptr - return $ Right_I p - | re == timeoutReached -> do - got_finish_request <- tryTakeMVar finish_request - case got_finish_request of - Nothing -> - tryOnce - Just _ -> - return Interrupted - - | re == badHappened -> return $ Left_I ("A wait for connection failed" :: String) - r - in tryOnce - - -- With the potentially obtained SSL session do... - case either_wired_ptr of - - Left_I _msg -> - -- // .. // - recursion - - Right_I wired_ptr -> do - attendant_callbacks <- provideActions wired_ptr - - use_protocol <- getSelectedProtocol wired_ptr - - let - maybe_session_attendant = case fromIntegral use_protocol of - n | use_protocol >= 0 -> Just $ snd $ attendants !! n - | otherwise -> Just . snd . head $ attendants - - case maybe_session_attendant of - - Just session_attendant -> - session_attendant attendant_callbacks - - Nothing -> - return () - - -- // .. // - recursion - - Interrupted -> - closeConnection connection_ptr - - -- Start the loop defined above... - recursion - --- When we are using the eternal version of this function, wake up --- each second .... -defaultWaitTime :: CInt -defaultWaitTime = 200000 --- Okej, more responsiviness needed -smallWaitTime :: CInt -smallWaitTime = 50000 - --- provideActions :: Wired_Ptr -> IO (LB.ByteString -> IO (), Int -> IO B.ByteString, IO ()) -provideActions :: Wired_Ptr -> IO IOCallbacks -provideActions wired_ptr = do - can_write_mvar <- newMVar True - can_read_mvar <- newMVar True - let - pushAction :: LB.ByteString -> IO () - pushAction datum = withMVar can_write_mvar $ \ can_write -> - if can_write - then - BU.unsafeUseAsCStringLen (LB.toStrict datum) $ \ (pchar, len) -> do - result <- sendData wired_ptr pchar (fromIntegral len) - case result of - r | r == allOk -> - return () - | r == badHappened -> - throwIO $ TLSLayerGenericProblem "Could not send data" - else - throwIO $ TLSLayerGenericProblem "CouldNotWriteData--SocketAlreadyClosed" - - pullAction :: Int -> IO B.ByteString - pullAction bytes_to_get = withMVar can_read_mvar $ \ can_read -> - if can_read - then - allocaBytes bytes_to_get $ \ pcharbuffer -> - alloca $ \ data_recvd_ptr -> do - result <- recvData wired_ptr pcharbuffer (fromIntegral bytes_to_get) data_recvd_ptr - recvd_bytes <- case result of - r | r == allOk -> peek data_recvd_ptr - | r == badHappened -> - throwIO $ TLSLayerGenericProblem "Could not receive data" - - B.packCStringLen (pcharbuffer, fromIntegral recvd_bytes) - else - throwIO $ TLSLayerGenericProblem "CouldNotReadData--SocketAlreadyClosed" - - bestEffortPullAction :: Bool -> IO B.ByteString - bestEffortPullAction can_wait = withMVar can_read_mvar $ \ can_read -> - if can_read - then - allocaBytes useBufferSize $ \ pcharbuffer -> - alloca $ \ data_recvd_ptr -> do - result <- recvDataBestEffort - wired_ptr - pcharbuffer - (fromIntegral useBufferSize) - (fromIntegral . fromEnum $ can_wait) - data_recvd_ptr - recvd_bytes <- case result of - r | r == allOk -> peek data_recvd_ptr - | r == badHappened -> - throwIO $ TLSLayerGenericProblem "Could not receive data" - - B.packCStringLen (pcharbuffer, fromIntegral recvd_bytes) - else - throwIO $ TLSLayerGenericProblem "CouldNotReadData--SocketAlreadyClosed" - - - closeAction :: IO () - -- Ensure that the socket and the struct are only closed once - closeAction = - modifyMVar_ can_write_mvar $ \ can_write -> - modifyMVar can_read_mvar $ \ can_read -> - if can_write && can_read - then do - disposeWiredSession wired_ptr - return (False,False) - else - return (False,False) - - return IOCallbacks { - _pushAction_IOC = pushAction, - _pullAction_IOC = pullAction, - _closeAction_IOC = closeAction, - _bestEffortPullAction_IOC = bestEffortPullAction - } diff --git a/hs-src/SecondTransfer/MainLoop/Protocol.hs b/hs-src/SecondTransfer/MainLoop/Protocol.hs --- a/hs-src/SecondTransfer/MainLoop/Protocol.hs +++ b/hs-src/SecondTransfer/MainLoop/Protocol.hs @@ -8,4 +8,4 @@ data HttpProtocolVersion = Http11_HPV |Http2_HPV - + deriving (Show, Eq, Enum, Ord) diff --git a/hs-src/SecondTransfer/MainLoop/PushPullType.hs b/hs-src/SecondTransfer/MainLoop/PushPullType.hs deleted file mode 100644 --- a/hs-src/SecondTransfer/MainLoop/PushPullType.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} -module SecondTransfer.MainLoop.PushPullType ( - PushAction - ,PullAction - ,BestEffortPullAction - ,Attendant - ,CloseAction - ,IOCallbacks(..) - - ,pushAction_IOC - ,pullAction_IOC - ,closeAction_IOC - ,bestEffortPullAction_IOC - ) where - - -import Control.Lens - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB - --- | Callback type to push data to a channel. Part of this --- interface is the abstract exception type IOProblem. Throw an --- instance of it from here to notify the session that the connection has --- been broken. There is no way to signal "normal termination", since --- HTTP/2's normal termination can be observed at a higher level when a --- GO_AWAY frame is seen. -type PushAction = LB.ByteString -> IO () - --- | Callback type to pull data from a channel in a best-effort basis. --- When the first argument is True, the data-providing backend can --- block if the input buffers are empty and await for new data. --- Otherwise, it will return immediately with an empty ByteString -type BestEffortPullAction = Bool -> IO B.ByteString - --- | Callback type to pull data from a channel. The same --- as to PushAction applies to exceptions thrown from --- there. The first argument is the number of bytes to --- pull from the medium. Barring exceptions, we always --- know how many bytes we are expecting with HTTP/2. -type PullAction = Int -> IO B.ByteString - --- | Callback that the session calls to realease resources --- associated with the channels. Take into account that your --- callback should be able to deal with non-clean shutdowns --- also, for example, if the connection to the remote peer --- is severed suddenly. -type CloseAction = IO () - --- | A set of functions describing how to do I/O in a session. --- As usual, we provide lenses accessors. -data IOCallbacks = IOCallbacks { - -- | put some data in the channel - _pushAction_IOC :: PushAction, - -- | get exactly this much data from the channel. This function can - -- be used by HTTP/2 since lengths are pretty well built inside the - -- protocoll itself. - _pullAction_IOC :: PullAction, - -- | pull data from the channel, as much as the TCP stack wants to provide. - -- we have no option but use this one when talking HTTP/1.1, where the best - -- way to know the length is to scan until a Content-Length is found. - _bestEffortPullAction_IOC :: BestEffortPullAction, - -- | this is called when we wish to close the channel. - _closeAction_IOC :: CloseAction - } - -makeLenses ''IOCallbacks - --- | This is an intermediate type. It represents what you obtain --- by combining something that speaks the protocol and an AwareWorker. --- In turn, you need to feed a bundle of callbacks implementing I/O --- to finally start a server. --- --- You can implement one of these to let somebody else supply the --- push, pull and close callbacks. For example, 'tlsServeWithALPN' will --- supply these arguments to an 'Attendant'. --- --- Attendants encapsulate all the session book-keeping functionality, --- which for HTTP/2 is quite complicated. You use the functions --- http**Attendant --- to create one of these from a 'SecondTransfer.Types.CoherentWorker'. --- --- This library supplies two of such Attendant factories, --- 'SecondTransfer.Http1.http11Attendant' for --- HTTP 1.1 sessions, and 'SecondTransfer.Http2.http2Attendant' for HTTP/2 sessions. -type Attendant = IOCallbacks -> IO () diff --git a/hs-src/SecondTransfer/Sessions.hs b/hs-src/SecondTransfer/Sessions.hs --- a/hs-src/SecondTransfer/Sessions.hs +++ b/hs-src/SecondTransfer/Sessions.hs @@ -1,7 +1,9 @@ module SecondTransfer.Sessions( makeSessionsContext + ,makeDefaultSessionsContext + ,SessionsContext(..) + ,module SecondTransfer.Sessions.Config - ,SessionsContext ) where import SecondTransfer.Sessions.Config diff --git a/hs-src/SecondTransfer/Sessions/Config.hs b/hs-src/SecondTransfer/Sessions/Config.hs --- a/hs-src/SecondTransfer/Sessions/Config.hs +++ b/hs-src/SecondTransfer/Sessions/Config.hs @@ -1,38 +1,58 @@ -{-# LANGUAGE FlexibleContexts, Rank2Types, TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, Rank2Types, TemplateHaskell, OverloadedStrings, GADTs, DeriveGeneric #-} {- | Configuration and settings for the server. All constructor names are exported, but notice that they start with an underscore. They also have an equivalent lens without the underscore. Please prefer to use the lens interface. -} module SecondTransfer.Sessions.Config( - sessionId - ,defaultSessionsConfig - ,defaultSessionsEnrichedHeaders - ,sessionsCallbacks - ,sessionsEnrichedHeaders - ,reportErrorCallback_SC - ,dataDeliveryCallback_SC - ,dataFrameSize - ,addUsedProtocol + sessionId + , defaultSessionsConfig + , defaultSessionsEnrichedHeaders + , sessionsCallbacks + , sessionsEnrichedHeaders + , reportErrorCallback_SC + , dataDeliveryCallback_SC + , newSessionCallback_SC - ,SessionComponent(..) - ,SessionCoordinates(..) - ,SessionsCallbacks(..) - ,SessionsEnrichedHeaders(..) - -- ,UsedProtocol(..) - ,SessionsConfig(..) - ,ErrorCallback - ,DataFrameDeliveryCallback - ) where + , dataFrameSize + , addUsedProtocol + , pushEnabled + , firstPushStream + , networkChunkSize + , trayMaxSize + , SessionComponent (..) + , SessionCoordinates (..) + , SessionsCallbacks (..) + , SessionsEnrichedHeaders (..) + , SessionsConfig (..) + , SessionGenericHandle (..) + , ErrorCallback + , DataFrameDeliveryCallback + , NewSessionCallback (..) + , HashableSockAddr + + , ActivityMeteredSession (..) + , CleanlyPrunableSession (..) + + ) where + + -- import Control.Concurrent.MVar (MVar) -import Control.Exception (SomeException) -import Control.Lens (makeLenses) -import System.Clock (TimeSpec) +import Control.Exception (SomeException) +import Control.Lens (makeLenses) +--import GHC.Generics (Generic) +--import Data.Word (Word8) +--import System.Mem.Weak (Weak) +import System.Clock (TimeSpec) + +import SecondTransfer.IOCallbacks.Types (IOCallbacks) +import SecondTransfer.Sessions.HashableSockAddr (HashableSockAddr) + -- | Information used to identify a particular session. newtype SessionCoordinates = SessionCoordinates Int deriving Show @@ -74,19 +94,52 @@ -- session. type ErrorCallback = (SessionComponent, SessionCoordinates, SomeException) -> IO () + +-- | Sessions follow this class, so that they can be rescinded on inactivity +class ActivityMeteredSession a where + sessionLastActivity :: a -> IO TimeSpec + +-- | Clean-cut of sessions +class CleanlyPrunableSession a where + cleanlyCloseSession :: a -> IO () + + -- | Used by the session engine to report delivery of each data frame. Keep this callback very -- light, it runs in the main sending thread. It is called as -- f session_id stream_id ordinal when_delivered type DataFrameDeliveryCallback = Int -> Int -> Int -> TimeSpec -> IO () + +-- | An object with information about a new session, wrapped in a weak pointer. At the time the +-- newSessionCallback_SC is invoked, the reference inside the weak pointer is guranteed to be alive. +-- It may die later though. +data SessionGenericHandle where + Whole_SGH :: (ActivityMeteredSession a, CleanlyPrunableSession a) => a -> SessionGenericHandle + Partial_SGH :: (ActivityMeteredSession a) => a -> IOCallbacks -> SessionGenericHandle + +instance ActivityMeteredSession SessionGenericHandle where + sessionLastActivity (Whole_SGH a) = sessionLastActivity a + sessionLastActivity (Partial_SGH a _) = sessionLastActivity a + + +-- | Callback to be invoked when a client establishes a new session. The first parameter +-- is the address of the client, and the second parameter is a controller that can be used to +-- reduce the number of connections from time to time, the third parameter is a key on which +-- the second paramter should be made a weak pointer +newtype NewSessionCallback = NewSessionCallback ( HashableSockAddr -> SessionGenericHandle -> forall a . a -> IO () ) + -- | Callbacks that you can provide your sessions to notify you -- of interesting things happening in the server. data SessionsCallbacks = SessionsCallbacks { - -- Callback used to report errors during this session - _reportErrorCallback_SC :: Maybe ErrorCallback, - -- Callback used to report delivery of individual data frames - _dataDeliveryCallback_SC :: Maybe DataFrameDeliveryCallback -} + -- | Used to report errors during this session + _reportErrorCallback_SC :: Maybe ErrorCallback + -- | Used to report delivery of individual data frames + , _dataDeliveryCallback_SC :: Maybe DataFrameDeliveryCallback + -- | Used to notify the session manager of new sessions, so + -- that the session manager registers them (in a weak map) + -- if need comes + , _newSessionCallback_SC :: Maybe NewSessionCallback + } makeLenses ''SessionsCallbacks @@ -115,12 +168,28 @@ -- | Configuration information you can provide to the session maker. data SessionsConfig = SessionsConfig { - -- | Session callbacks - _sessionsCallbacks :: SessionsCallbacks - ,_sessionsEnrichedHeaders :: SessionsEnrichedHeaders - -- | Size to use when splitting data in data frames - ,_dataFrameSize :: Int -} + -- | Session callbacks + _sessionsCallbacks :: SessionsCallbacks + , _sessionsEnrichedHeaders :: SessionsEnrichedHeaders + -- | Size to use when splitting data in data frames, to be sent. + -- TODO: An equivalent maxRecvSize should be defined here... + , _dataFrameSize :: Int + -- | Should we enable PUSH in sessions? Notice that the client + -- can still disable PUSH at will. Also users of the library + -- can decide not to use it. This just puts another layer ... + , _pushEnabled :: Bool + -- | The number to use for the first pushed stream. Should be even + , _firstPushStream :: Int + -- | Max amount of bytes to try to send in one go. The session will + -- send less data if less is available, otherwise it will send slightly + -- more than this amount, depending on packet boundaries. This is + -- used to avoid TCP and TLS fragmentation at the network layer + , _networkChunkSize :: Int + -- | Max number of packets to hold in the output tray. A high number means + -- that more memory is used by the packets have a higher chance of going + -- out in a favourable order. + , _trayMaxSize :: Int + } makeLenses ''SessionsConfig @@ -136,10 +205,20 @@ -- the lenses interfaces defaultSessionsConfig :: SessionsConfig defaultSessionsConfig = SessionsConfig { - _sessionsCallbacks = SessionsCallbacks { + _sessionsCallbacks = SessionsCallbacks { _reportErrorCallback_SC = Nothing, - _dataDeliveryCallback_SC = Nothing - }, - _sessionsEnrichedHeaders = defaultSessionsEnrichedHeaders, - _dataFrameSize = 2048 + _dataDeliveryCallback_SC = Nothing, + _newSessionCallback_SC = Nothing + } + , _sessionsEnrichedHeaders = defaultSessionsEnrichedHeaders + , _dataFrameSize = 16*1024 + , _pushEnabled = True + , _firstPushStream = 8 + , _networkChunkSize = 18*1024 + -- Max number of packets that can be waiting to exit. A big number here + -- is desirable, but counts towards the memory consumption when the network is slow... + -- so for now let's make it a little bit lower. In the future we may want to adjust + -- this number dynamically. + -- , _trayMaxSize = 128 + , _trayMaxSize = 16 } diff --git a/hs-src/SecondTransfer/Sessions/HashableSockAddr.hs b/hs-src/SecondTransfer/Sessions/HashableSockAddr.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Sessions/HashableSockAddr.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts, Rank2Types, TemplateHaskell, OverloadedStrings, GADTs, DeriveGeneric #-} +module SecondTransfer.Sessions.HashableSockAddr ( + HashableSockAddr + , hashableSockAddrFromNSSockAddr + ) where + + +import GHC.Generics (Generic) + +import Data.Hashable +import Data.Word + +import Network.Socket (SockAddr(..)) + +-- | Since SockAddr is not hashable, we need our own. TODO: IPv6. +newtype HashableSockAddr = HashableSockAddr (Word8, Word8, Word8, Word8) + deriving (Eq, Show, Generic) + +instance Hashable HashableSockAddr + + +hashableSockAddrFromNSSockAddr :: SockAddr -> Maybe HashableSockAddr +hashableSockAddrFromNSSockAddr (SockAddrInet _port_number haddr) = + Just . HashableSockAddr $ ( + fromIntegral $ haddr `div` 16777216, + fromIntegral $ haddr `div` 65536 `mod` 256, + fromIntegral $ haddr `div` 256 `mod` 256, + fromIntegral $ haddr `mod` 256 + ) +hashableSockAddrFromNSSockAddr _ = Nothing diff --git a/hs-src/SecondTransfer/Sessions/Internal.hs b/hs-src/SecondTransfer/Sessions/Internal.hs --- a/hs-src/SecondTransfer/Sessions/Internal.hs +++ b/hs-src/SecondTransfer/Sessions/Internal.hs @@ -7,19 +7,21 @@ import Control.Concurrent.MVar (MVar, newMVar,modifyMVar) -- import Control.Exception (SomeException) import qualified Control.Exception as E -import Control.Lens ((^.), makeLenses) +import Control.Lens ((^.), makeLenses, Lens' ) -import System.Log.Logger +--import System.Log.Logger --- | Contains information that applies to all --- sessions created in the program. Use the lenses --- interface to access members of this struct. +-- | Contains information that applies to all sessions created in the program. +-- Use the lenses interface to access members of this struct. -- +-- TODO: members of this record should be renamed to the "suffix" convention. data SessionsContext = SessionsContext { + -- | Read-only configuration information passed-in at construction time _sessionsConfig :: SessionsConfig + -- | MVar with enumerator for sessions ,_nextSessionId :: MVar Int } @@ -27,6 +29,14 @@ makeLenses ''SessionsContext +sessionsConfig_Sctx :: Lens' SessionsContext SessionsConfig +sessionsConfig_Sctx = sessionsConfig + + +nextSessionId_Sctx :: Lens' SessionsContext (MVar Int) +nextSessionId_Sctx = nextSessionId + + -- Session tags are simple session identifiers acquireNewSessionTag :: SessionsContext -> IO Int acquireNewSessionTag sessions_context = @@ -45,6 +55,9 @@ } +makeDefaultSessionsContext :: IO SessionsContext +makeDefaultSessionsContext = makeSessionsContext defaultSessionsConfig + sessionExceptionHandler :: E.Exception e => SessionComponent -> Int -> SessionsContext -> e -> IO () sessionExceptionHandler session_component session_id sessions_context e = @@ -52,7 +65,7 @@ getit = ( sessionsConfig . sessionsCallbacks . reportErrorCallback_SC ) maybe_error_callback = sessions_context ^. getit - component_tag = "Session." ++ show session_component + --component_tag = "Session." ++ show session_component error_tuple = ( session_component, SessionCoordinates session_id, diff --git a/hs-src/SecondTransfer/Sessions/Tidal.hs b/hs-src/SecondTransfer/Sessions/Tidal.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Sessions/Tidal.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE GADTs, TemplateHaskell, OverloadedStrings #-} +{- | A simple session manager that prunes the number of connections from time to time.... +-} +module SecondTransfer.Sessions.Tidal ( + TidalContext (..) + , maxConnectionPerPeer_TiC + , highWaterMark_TiC + , newTidalSession + , defaultTidalContext + , tidalConnectionManager + ) where + + +import Control.Lens +import Control.Monad.IO.Class (liftIO) +--import Control.DeepSeq ( + --($!!), +-- deepseq ) +import Control.Monad.Trans.Reader +import Control.Concurrent +import Control.Monad.ST +import Control.Monad ( + foldM + --, mapM_ + , forM_ + -- , mapM + , filterM + , when + ) + +--import qualified Data.ByteString as B +--import qualified Data.ByteString.Builder as Bu +--import qualified Data.ByteString.Lazy as Bl +--import qualified Data.HashTable.IO as H +import qualified Data.Vector as DVec +--import qualified Data.Sequence as Sq +--import Data.IORef +import qualified Data.HashTable.ST.Cuckoo as Ht +import Data.Maybe (catMaybes) +import Data.Vector.Algorithms.Merge (sortBy) + +import System.Mem.Weak +--import System.Clock (TimeSpec) + +import SecondTransfer.Sessions.Config +import SecondTransfer.IOCallbacks.Types + + +-- | Configuration structure +data TidalContext = TidalContext { + -- | Number of admissible connections per peer + _maxConnectionPerPeer_TiC :: Int + -- | Callback to be used when a connection to a peer is lost. + -- | High water mark. When the number of connections go higher than this number, + -- some of them are pruned. + , _highWaterMark_TiC :: Int + } + +makeLenses ''TidalContext + + +defaultTidalContext :: TidalContext +defaultTidalContext = TidalContext { + _maxConnectionPerPeer_TiC = 8 + , _highWaterMark_TiC = 780 + } + +type ConnectionEntry = (HashableSockAddr ,Weak SessionGenericHandle) + +type ConnectionList = [ConnectionEntry] + +-- | State structure. Will live for the entire server lifetime +data TidalS = TidalS { + _context_TdS :: TidalContext + , _connections_TdS :: MVar ConnectionList + } + +makeLenses ''TidalS + + +type TidalM = ReaderT TidalS IO + + +justRegisterNewConnection :: HashableSockAddr -> a -> SessionGenericHandle -> TidalM () +justRegisterNewConnection sock_addr weakkey sgh = + do + connection_vector_mvar <- view connections_TdS + liftIO $ do + weakling <- mkWeak weakkey sgh Nothing + modifyMVar_ connection_vector_mvar + $ \ sq -> return $ (sock_addr, weakling) : sq + +type MemoTable s = Ht.HashTable s HashableSockAddr Int + + +-- | Prunes any connections over the limit of connections allowed per host. +pruneSameHost :: TidalM () +pruneSameHost = + do + -- number below, it is per peer. + max_connections <- view (context_TdS . maxConnectionPerPeer_TiC) + current_connections_mvar <- view connections_TdS + to_drop <- liftIO . modifyMVar current_connections_mvar $ \ current_connections -> do + let + countAndAdvance :: MemoTable s -> HashableSockAddr -> ST s Bool + countAndAdvance h addr = do + e <- Ht.lookup h addr + case e of + Just n -> + if n >= max_connections + then + return False + else do + Ht.insert h addr (n + 1) + return True + Nothing -> + do + Ht.insert h addr 1 + return True + + foldOperator :: MemoTable s -> ConnectionList -> ConnectionEntry -> ST s ConnectionList + foldOperator h drop_connections (addr, weakling) = + do + keep <- countAndAdvance h addr + if keep + then return drop_connections + else return ( (addr,weakling):drop_connections ) + + to_drop :: ConnectionList + to_drop = runST $ do + e <- Ht.new + foldM (foldOperator e) [] current_connections + + remaining <- dropDeathConnections current_connections + return (remaining, to_drop) + + -- We can invoke this function outside the lock, since it is not going to change the list . + liftIO $ dropConnections to_drop + + return () + + +--pruneNOldest + + +-- | Expects the connection list to be locked. Drops the death connections +-- and returns a list with the entries for the ones which are still alive. +dropDeathConnections :: ConnectionList -> IO ConnectionList +dropDeathConnections conns = filterM (\ (_addr, weakling) -> do + maybesomething <- deRefWeak weakling + case maybesomething of + Nothing -> return False + _ -> return True + ) conns + + +dropConnections :: ConnectionList -> IO () +dropConnections conns = forM_ conns $ \ (_addr, weakling) -> do + maybesomething <- deRefWeak weakling + case maybesomething of + Nothing -> return () + (Just generic_handle ) -> do + case generic_handle of + Whole_SGH a -> + cleanlyCloseSession a + + Partial_SGH _ iocallbacks -> + (iocallbacks ^. closeAction_IOC) + + +-- | Drops the oldest connections without activity .... +pruneOldestConnections :: Int -> TidalM () +pruneOldestConnections how_many_to_drop = + do + -- First, create a vector with the information we are interested in .... + current_connections_mvar <- view connections_TdS + to_drop <- liftIO . withMVar current_connections_mvar $ \ current_connections -> do + sortable_conns_list <- catMaybes <$> mapM (\ (addr, weakling) -> do + w <- deRefWeak weakling + case w of + Just g -> return . Just $ (addr, g, weakling) + Nothing -> return Nothing + ) current_connections + let + sortable_vector = DVec.fromList $ sortable_conns_list + with_time_spec <- DVec.mapM (\ (addr, generic_handle, weakling) -> do + last_act_time <- sessionLastActivity generic_handle + return ( (addr, weakling), last_act_time) + ) sortable_vector + + let + -- Now the oldest ones in the activity vector are first. + compare_with_spec ( _, t1) ( _, t2) = compare t1 t2 + sorted_time_spec = DVec.modify (\ mv -> sortBy compare_with_spec mv) with_time_spec + + -- This contains everybody that we can drop ... + to_drop = DVec.take how_many_to_drop sorted_time_spec + return . DVec.toList . DVec.map fst $ to_drop + liftIO $ dropConnections to_drop + + +whenAddingConnection :: HashableSockAddr -> SessionGenericHandle -> a -> TidalM () +whenAddingConnection sock_addr handle key = + do + highwater_mark <- view (context_TdS . highWaterMark_TiC) + connections_mvar <- view connections_TdS + connection_count <- liftIO . withMVar connections_mvar $ \ current_connections -> do + let + connection_count = length current_connections + return connection_count + + when (connection_count >= highwater_mark) $ do + -- Take measures! + pruneSameHost + pruneOldestConnections (highwater_mark `div` 3) + + justRegisterNewConnection sock_addr key handle + + +newTidalSession :: TidalContext -> IO TidalS +newTidalSession tidal_context = do + connections <- newMVar [] + return TidalS { _context_TdS = tidal_context, _connections_TdS = connections } + + +tidalConnectionManager :: TidalS -> NewSessionCallback +tidalConnectionManager tidals = + NewSessionCallback $ \ a b c -> runReaderT (whenAddingConnection a b c) tidals diff --git a/hs-src/SecondTransfer/Socks5/Parsers.hs b/hs-src/SecondTransfer/Socks5/Parsers.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Socks5/Parsers.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module SecondTransfer.Socks5.Parsers ( + parseProtocolVersion + , parseAddressType + , parseProtocolCommand + , parseReplyField + , parseClientAuthMethods_Packet + , parseServerSelectsMethod_Packet + , parseIndicatedAddress + , parseClientRequest_Packet + ) where + +import Control.Applicative ( (<|>) ) + +import Data.Word +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.Attoparsec.ByteString as P + +import SecondTransfer.Socks5.Types + + +parseProtocolVersion :: P.Parser ProtocolVersion +parseProtocolVersion = P.word8 5 >> pure ProtocolVersion + + +parseAddressType :: P.Parser AddressType +parseAddressType = + ( P.word8 1 >> pure IPv4_S5AT) + <|> ( P.word8 3 >> pure DomainName_S5AT) + <|> ( P.word8 4 >> pure IPv6_S5AT) + + +parseProtocolCommand :: P.Parser ProtocolCommand +parseProtocolCommand = + ( P.word8 1 >> pure Connect_S5PC ) + <|> ( P.word8 2 >> pure Bind_S5PC ) + <|> ( P.word8 3 >> pure UdpAssociate_S5PC ) + + +parseReplyField :: P.Parser ReplyField +parseReplyField = + ( P.word8 0 >> pure Succeeded_S5RF ) + <|> ( P.word8 1 >> pure GeneralFailure_S5RF ) + + +parseClientAuthMethods_Packet :: P.Parser ClientAuthMethods_Packet +parseClientAuthMethods_Packet = ClientAuthMethods_Packet <$> + parseProtocolVersion + <*> ( P.anyWord8 >>= \ len -> P.take . fromIntegral $ len) + + +parseServerSelectsMethod_Packet :: P.Parser ServerSelectsMethod_Packet +parseServerSelectsMethod_Packet = error "YetTooImplement(ButItsSuperEasy)" + + +parseIndicatedAddress :: AddressType -> P.Parser IndicatedAddress +parseIndicatedAddress IPv4_S5AT = + IPv4_IA + <$> anyWord32be +parseIndicatedAddress IPv6_S5AT = + IPv6_IA + <$> P.take 16 +parseIndicatedAddress DomainName_S5AT = + DomainName_IA + <$> (P.anyWord8 >>= \ len -> P.take . fromIntegral $ len) + + +parseClientRequest_Packet :: P.Parser ClientRequest_Packet +parseClientRequest_Packet = + ClientRequest_Packet + <$> parseProtocolVersion + <*> parseProtocolCommand + <*> (P.word8 0) -- Reserved part + <*> (parseAddressType >>= parseIndicatedAddress ) + <*> anyWord16be + +-- Some definitions copy-pasted from Data.Attoparsec.Binary ... Original code by Andrew Drake, +-- all rights reserved by him, used under BSD3 license. + +byteSize :: (FiniteBits a) => a -> Int +byteSize = (`div` 8) . finiteBitSize + +pack :: (FiniteBits a, Num a) => B.ByteString -> a +pack = B.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 + +anyWordN :: (FiniteBits a) => (B.ByteString -> a) -> P.Parser a +anyWordN = anyWordN' undefined + where anyWordN' :: (FiniteBits a) => a -> (B.ByteString -> a) -> P.Parser a + anyWordN' d = flip fmap $ P.take $ byteSize d + +-- | Match any 16 bit big endian word. +anyWord16be :: P.Parser Word16 +anyWord16be = anyWordN pack + + +-- | Match any 32 bit big endian word. +anyWord32be :: P.Parser Word32 +anyWord32be = anyWordN pack + + +unpack :: (FiniteBits a, Integral a) => a -> B.ByteString +unpack x = B.pack $ map f $ reverse [0..byteSize x - 1] + where f s = fromIntegral $ shiftR x (8 * s) + +wordN :: (FiniteBits a) => (a -> B.ByteString) -> a -> P.Parser a +wordN u w = P.string (u w) >> return w + +-- | Match a specific 16-bit big-endian word. +word16be :: Word16 -> P.Parser Word16 +word16be = wordN unpack diff --git a/hs-src/SecondTransfer/Socks5/Serializers.hs b/hs-src/SecondTransfer/Socks5/Serializers.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Socks5/Serializers.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module SecondTransfer.Socks5.Serializers ( + putProtocolVersion + , putReplyField + , putServerSelectsMethod_Packet + , putServerReply_Packet + ) where + +--import Control.Applicative ( (<|>) ) + +--import qualified Data.Binary.Builder as U +import qualified Data.Binary as U +import qualified Data.Binary.Put as U + +--import Data.Word +--import Data.Bits +import qualified Data.ByteString as B +--import qualified Data.Attoparsec.ByteString as P + +import SecondTransfer.Socks5.Types + + +putProtocolVersion :: ProtocolVersion -> U.Put +putProtocolVersion _ = U.putWord8 5 + + +putReplyField :: ReplyField -> U.Put +putReplyField Succeeded_S5RF = U.putWord8 0 +putReplyField GeneralFailure_S5RF = U.putWord8 1 + + +putServerSelectsMethod_Packet :: ServerSelectsMethod_Packet -> U.Put +putServerSelectsMethod_Packet (ServerSelectsMethod_Packet _v m) = + putProtocolVersion _v >> (U.putWord8 . fromIntegral $ m) + + +putAddressType :: AddressType -> U.Put +putAddressType IPv4_S5AT = U.putWord8 1 +putAddressType DomainName_S5AT = U.putWord8 3 +putAddressType IPv6_S5AT = U.putWord8 4 + + +putIndicatedAddress :: IndicatedAddress -> U.Put +putIndicatedAddress (IPv4_IA w) = U.putWord32be w +putIndicatedAddress (DomainName_IA dn) = + (U.putWord8 . fromIntegral $ B.length dn) + >> U.putByteString dn +putIndicatedAddress (IPv6_IA s) = U.putByteString s + + +putServerReply_Packet :: ServerReply_Packet -> U.Put +putServerReply_Packet (ServerReply_Packet _version reply_field _reserved address port) = + do + putProtocolVersion _version + putReplyField reply_field + U.putWord8 0 -- reserved + putAddressType $ iaToAddressType address + putIndicatedAddress address + U.putWord16be port diff --git a/hs-src/SecondTransfer/Socks5/Session.hs b/hs-src/SecondTransfer/Socks5/Session.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Socks5/Session.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module SecondTransfer.Socks5.Session ( + tlsSOCKS5Serve + , ConnectOrForward (..) + , Socks5ServerState + , initSocks5ServerState + ) where + +import Control.Concurrent +import qualified Control.Exception as E +import Control.Lens ( makeLenses, (^.), set) + +import qualified Data.ByteString as B +import Data.ByteString.Char8 ( unpack, pack) +import qualified Data.Attoparsec.ByteString as P +import qualified Data.Binary as U +import qualified Data.Binary.Put as U +import Data.Word (Word16) +import Data.Int (Int64) + +import qualified Network.Socket as NS + +import SecondTransfer.Exception (SOCKS5ProtocolException (..), forkIOExc ) + +import SecondTransfer.Socks5.Types +import SecondTransfer.Socks5.Parsers +import SecondTransfer.Socks5.Serializers + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.IOCallbacks.SocketServer +import SecondTransfer.IOCallbacks.Coupling (couple) +import SecondTransfer.IOCallbacks.WrapSocket (HasSocketPeer(..)) + +-- For debugging purposes +--import SecondTransfer.IOCallbacks.Botcher + + +data Socks5ServerState = Socks5ServerState { + _nextConnection_S5S :: !Int64 + } +makeLenses ''Socks5ServerState + +initSocks5ServerState :: Socks5ServerState +initSocks5ServerState = Socks5ServerState 0 + +data ConnectOrForward = + Connect_COF B.ByteString IOCallbacks + | Forward_COF B.ByteString Word16 + | Drop_COF B.ByteString + + +tryRead :: IOCallbacks -> B.ByteString -> P.Parser a -> IO (a,B.ByteString) +tryRead iocallbacks leftovers p = do + let + onResult result = + case result of + P.Done i r -> Right . Just $ (r,i) + P.Fail _ _ _ -> Right $ Nothing + P.Partial f -> Left $ f + + go f = do + fragment <- (iocallbacks ^. bestEffortPullAction_IOC) True + case onResult $ f fragment of + Right (Just x) -> return x + Right Nothing -> E.throwIO SOCKS5ProtocolException + Left ff -> go ff + + case onResult $ P.parse p leftovers of + Right (Just x) -> return x + Right Nothing -> E.throwIO SOCKS5ProtocolException + Left f0 -> go f0 + + +pushDatum :: IOCallbacks -> (a -> U.Put) -> a -> IO () +pushDatum iocallbacks putthing x = do + let + datum = U.runPut (putthing x) + (iocallbacks ^. pushAction_IOC) datum + + +-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the +-- SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved +-- by the first parameter. Quite simple. +negotiateSocksAndForward :: (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward +negotiateSocksAndForward approver socks_here = + do + let + tr = tryRead socks_here + ps = pushDatum socks_here + -- Start by reading the standard socks5 header + ei <- E.try $ do + (_auth, next1) <- tr "" parseClientAuthMethods_Packet + -- I will ignore the auth methods for now + let + server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth + ps putServerSelectsMethod_Packet server_selects + (req_packet, _next2) <- tr next1 parseClientRequest_Packet + case req_packet ^. cmd_SP3 of + + Connect_S5PC -> do + -- Can accept a connect, to what? + let + address = req_packet ^. address_SP3 + named_host = case address of + DomainName_IA name -> name + _ -> "" + if approver named_host then + do + -- First I need to answer to the client that we are happy and ready + let + server_reply = ServerReply_Packet { + _version_SP4 = ProtocolVersion + , _replyField_SP4 = Succeeded_S5RF + , _reservedField_SP4 = 0 + , _address_SP4 = IPv4_IA 0x7f000001 + , _port_SP4 = 10001 + } + ps putServerReply_Packet server_reply + -- Now that I have the attendant, let's just activate it ... + + -- CORRECT WAY: + return $ Connect_COF named_host socks_here + + else do + -- Logging? We need to get that real right. + return $ Drop_COF named_host + + + -- Other commands not handled for now + _ -> do + return $ Drop_COF "" + + case ei of + Left SOCKS5ProtocolException -> return $ Drop_COF "" + Right result -> return result + + +-- | Forwards a set of IOCallbacks (actually, it is exactly the same passed in) after the +-- SOCKS5 negotiation, if the negotiation succeeds and the indicated "host" is approved +-- by the first parameter. If the approver returns false, this function will try to +-- actually connect to the host and let the software act as a true proxy. +negotiateSocksForwardOrConnect :: (B.ByteString -> Bool) -> IOCallbacks -> IO ConnectOrForward +negotiateSocksForwardOrConnect approver socks_here = + do + let + tr = tryRead socks_here + ps = pushDatum socks_here + -- Start by reading the standard socks5 header + ei <- E.try $ do + (_auth, next1) <- tr "" parseClientAuthMethods_Packet + -- I will ignore the auth methods for now + let + server_selects = ServerSelectsMethod_Packet ProtocolVersion 0 -- No auth + ps putServerSelectsMethod_Packet server_selects + (req_packet, _next2) <- tr next1 parseClientRequest_Packet + case req_packet ^. cmd_SP3 of + + Connect_S5PC -> do + -- Can accept a connect, to what? + let + address = req_packet ^. address_SP3 + port_number = req_packet ^. port_SP3 + externalConnectProcessing = + do + maybe_forwarding_callbacks <- connectOnBehalfOfClient address port_number + case maybe_forwarding_callbacks of + Just (_indicated_address, io_callbacks) -> do + let + server_reply = ServerReply_Packet { + _version_SP4 = ProtocolVersion + , _replyField_SP4 = Succeeded_S5RF + , _reservedField_SP4 = 0 + , _address_SP4 = IPv4_IA 0x7f000001 + -- Wrong port, but... + , _port_SP4 = 10001 + } + ps putServerReply_Packet server_reply + -- Now couple the two streams ... + _ <- couple socks_here io_callbacks + return $ Forward_COF (pack . show $ address) (fromIntegral port_number) + _ -> + return $ Drop_COF (pack . show $ address) + + + -- /let + case address of + DomainName_IA named_host -> + if approver named_host + then do + -- First I need to answer to the client that we are happy and ready + let + server_reply = ServerReply_Packet { + _version_SP4 = ProtocolVersion + , _replyField_SP4 = Succeeded_S5RF + , _reservedField_SP4 = 0 + , _address_SP4 = IPv4_IA 0x7f000001 + , _port_SP4 = 10001 + } + ps putServerReply_Packet server_reply + -- Now that I have the attendant, let's just activate it ... + return $ Connect_COF named_host socks_here + else do + -- Forward to an external host + externalConnectProcessing + IPv4_IA _ -> do + -- TODO: Some address sanitization + externalConnectProcessing + + + -- Other commands not handled for now + _ -> do + --putStrLn "SOCKS5 HAS NEGLECTED TO REJECT A CONNECTION" + return $ Drop_COF "" + + case ei of + Left SOCKS5ProtocolException -> return $ Drop_COF "" + Right result -> return result + + +connectOnBehalfOfClient :: IndicatedAddress -> Word16 -> IO (Maybe (IndicatedAddress , IOCallbacks)) +connectOnBehalfOfClient address port_number = + do + maybe_sock_addr <- case address of + IPv4_IA addr -> + return . Just $ NS.SockAddrInet (fromIntegral port_number) addr + + DomainName_IA dn -> do + -- Let's try to connect on behalf of the client... + let + hints = NS.defaultHints { + NS.addrFlags = [NS.AI_ADDRCONFIG] + } + addrs <- E.catch + ( NS.getAddrInfo (Just hints) (Just . unpack $ dn) Nothing ) + ((\_ -> return [])::E.IOException -> IO [NS.AddrInfo]) + case addrs of + ( first : _) -> do + return . Just $ NS.addrAddress first + _ -> + return Nothing + + case maybe_sock_addr of + Just sock_addr@(NS.SockAddrInet _ ha) -> do + E.catch + (do + client_socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol + let + translated_address = (NS.SockAddrInet (fromIntegral port_number) ha) + NS.connect client_socket translated_address + is_connected <- NS.isConnected client_socket + peer_name <- NS.getPeerName client_socket + socket_io_callbacks <- socketIOCallbacks client_socket + io_callbacks <- handshake socket_io_callbacks + return . Just $ (toSocks5Addr translated_address , io_callbacks) + ) + ((\_ -> do + return Nothing)::E.IOException -> IO (Maybe (IndicatedAddress , IOCallbacks) ) ) + + _ -> do + -- Temporary message + putStrLn "SOCKS5 could not be forwarded/address not resolved, or resolved to strange format" + return Nothing + + +toSocks5Addr:: NS.SockAddr -> IndicatedAddress +toSocks5Addr (NS.SockAddrInet _ ha) = IPv4_IA ha +toSocks5Addr _ = error "toSocks5Addr not fully implemented" + + +-- | Simple alias to SocketIOCallbacks where we expect +-- encrypted contents over a SOCKS5 Socket +newtype TLSServerSOCKS5Callbacks = TLSServerSOCKS5Callbacks SocketIOCallbacks + +instance IOChannels TLSServerSOCKS5Callbacks where + handshake (TLSServerSOCKS5Callbacks cb) = handshake cb + +instance TLSEncryptedIO TLSServerSOCKS5Callbacks +instance TLSServerIO TLSServerSOCKS5Callbacks +instance HasSocketPeer TLSServerSOCKS5Callbacks where + getSocketPeerAddress (TLSServerSOCKS5Callbacks s) = getSocketPeerAddress s + + +-- | tlsSOCKS5Serve approver listening_socket onsocks5_action +-- The approver should return True for host names that are served by this software (otherwise the connection will be closed, just for now, +-- in the close future we will implement a way to forward requests to external Internet hosts.) +-- Pass a bound and listening TCP socket where you expect a SOCKS5 exchange to have to tke place. +-- And pass an action that can do something with the callbacks. The passed-in action is expected to fork a thread and return +-- inmediately. +tlsSOCKS5Serve :: + MVar Socks5ServerState + -> Socks5ConnectionCallbacks + -> (B.ByteString -> Bool) + -> Bool + -> NS.Socket + -> ( TLSServerSOCKS5Callbacks -> IO () ) + -> IO () +tlsSOCKS5Serve s5s_mvar socks5_callbacks approver forward_connections listen_socket onsocks5_action = + tcpServe listen_socket socks_action + where + socks_action active_socket = do + forkIOExc "tlsSOCKS5Serve/negotiation" $ do + conn_id <- modifyMVar s5s_mvar $ \ s5s -> do + let + conn_id = s5s ^. nextConnection_S5S + new_s5s = set nextConnection_S5S (conn_id + 1) s5s + return $ new_s5s `seq` (new_s5s, conn_id) + let + log_events_maybe = socks5_callbacks ^. logEvents_S5CC + log_event :: Socks5ConnectEvent -> IO () + log_event ev = case log_events_maybe of + Nothing -> return () + Just c -> c ev + wconn_id = S5ConnectionId conn_id + peer_address <- NS.getPeerName active_socket + log_event $ Established_S5Ev peer_address wconn_id + + socket_io_callbacks <- socketIOCallbacks active_socket + io_callbacks <- handshake socket_io_callbacks + maybe_negotiated_io <- + if forward_connections + then negotiateSocksForwardOrConnect approver io_callbacks + else negotiateSocksAndForward approver io_callbacks + case maybe_negotiated_io of + Connect_COF fate negotiated_io -> do + let + tls_server_socks5_callbacks = TLSServerSOCKS5Callbacks socket_io_callbacks + log_event $ HandlingHere_S5Ev fate wconn_id + onsocks5_action tls_server_socks5_callbacks + Drop_COF fate -> do + log_event $ Dropped_S5Ev fate wconn_id + (io_callbacks ^. closeAction_IOC) + return () + Forward_COF fate port -> do + -- TODO: More data needs to come here + -- Do not close + log_event $ ToExternal_S5Ev fate port wconn_id + return () + return () diff --git a/hs-src/SecondTransfer/Socks5/Types.hs b/hs-src/SecondTransfer/Socks5/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/Socks5/Types.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving #-} +module SecondTransfer.Socks5.Types ( + -- ** Types to be serialized and de-serialized + ClientAuthMethods_Packet (..) + , ServerSelectsMethod_Packet (..) + , ClientRequest_Packet (..) + , cmd_SP3 + , address_SP3 + , port_SP3 + , ServerReply_Packet (..) + , replyField_SP4 + , address_SP4 + , port_SP4 + , AddressType (..) + , ProtocolCommand (..) + , ProtocolVersion (..) + , IndicatedAddress (..) + , ReplyField (..) + -- *** Helpers for serialization, de-serialization + , iaToAddressType + + -- *** Logging types + , S5ConnectionId (..) + , Socks5ConnectEvent (..) + , Socks5LogCallback + , Socks5ConnectionCallbacks (..) + , logEvents_S5CC + ) where + +---import Control.Concurrent +-- import qualified Control.Exception as E +import Control.Lens (makeLenses) + +import qualified Data.ByteString as B +-- import qualified Data.ByteString.Lazy as LB +--import Data.ByteString.Char8 (pack, unpack) +--import Data.List (find) + +import Data.Word +import Data.Int (Int64) + +import qualified Network.Socket as NS(SockAddr) + +------------------------------------------------------------------------------------------------------- +-- +-- Connection callbacks, used to report Connect behavior +-- +------------------------------------------------------------------------------------------------------ + +-- | Connection ID for SOCKS5 Connections +newtype S5ConnectionId = S5ConnectionId Int64 + deriving (Eq, Ord, Show, Enum) + +-- | SOCKS5 Connections, and where are they handled +data Socks5ConnectEvent = + Established_S5Ev NS.SockAddr S5ConnectionId + | HandlingHere_S5Ev B.ByteString S5ConnectionId + | ToExternal_S5Ev B.ByteString Word16 S5ConnectionId + | Dropped_S5Ev B.ByteString S5ConnectionId + +type Socks5LogCallback = Socks5ConnectEvent -> IO () + +-- | Callbacks used by client applications to get notified about interesting +-- events happening at a connection level, or to get asked about things +-- (e.g, about if it is proper to accept a connection). These are used from CoreServer +data Socks5ConnectionCallbacks = Socks5ConnectionCallbacks { + -- | Invoked after the connection is accepted, and after it is finished. + _logEvents_S5CC :: Maybe Socks5LogCallback + } + +makeLenses ''Socks5ConnectionCallbacks +------------------------------------------------------------------------------------------------------- +-- +-- Serialization types +-- +------------------------------------------------------------------------------------------------------- + +-- | A nonce which is always equal to five... or we are in troubles +data ProtocolVersion = ProtocolVersion + deriving Show + +data AddressType = + IPv4_S5AT + | DomainName_S5AT + | IPv6_S5AT + deriving (Show, Eq, Enum) + + +-- | The command sent by the client +data ProtocolCommand = + Connect_S5PC + | Bind_S5PC + | UdpAssociate_S5PC + deriving (Show, Eq, Enum) + +-- TODO: We need to implement the other types of responses +data ReplyField = + Succeeded_S5RF + | GeneralFailure_S5RF + deriving (Show, Eq, Enum) + +-- Datatypes present at different negotiation stages +data ClientAuthMethods_Packet = ClientAuthMethods_Packet { + _version_SP1 :: ProtocolVersion + , _methods_SP1 :: B.ByteString + } + deriving Show + + +data ServerSelectsMethod_Packet = ServerSelectsMethod_Packet { + _version_SP2 :: ProtocolVersion + , _method_SP2 :: Word8 + } + deriving Show + +data IndicatedAddress = + IPv4_IA Word32 + | DomainName_IA B.ByteString + | IPv6_IA B.ByteString + deriving Show + +iaToAddressType :: IndicatedAddress -> AddressType +iaToAddressType (IPv4_IA _) = IPv4_S5AT +iaToAddressType (IPv6_IA _) = IPv6_S5AT +iaToAddressType (DomainName_IA _) = DomainName_S5AT + + +data ClientRequest_Packet = ClientRequest_Packet { + _version_SP3 :: ProtocolVersion + , _cmd_SP3 :: ProtocolCommand + , _reserved_SP3 :: Word8 -- Should be zero + , _address_SP3 :: IndicatedAddress + , _port_SP3 :: Word16 + } + deriving Show + +makeLenses ''ClientRequest_Packet + + +data ServerReply_Packet = ServerReply_Packet { + _version_SP4 :: ProtocolVersion + , _replyField_SP4 :: ReplyField + , _reservedField_SP4 :: Word8 -- Should be zero + , _address_SP4 :: IndicatedAddress + , _port_SP4 :: Word16 + } + deriving Show + +makeLenses ''ServerReply_Packet diff --git a/hs-src/SecondTransfer/TLS/Botan.hs b/hs-src/SecondTransfer/TLS/Botan.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/TLS/Botan.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE ForeignFunctionInterface, TemplateHaskell, Rank2Types, FunctionalDependencies, OverloadedStrings #-} +module SecondTransfer.TLS.Botan ( + BotanTLSContext + , BotanSession + , unencryptChannelData + , newBotanTLSContext + , newBotanTLSContextFromMemory + , botanTLS + ) where + +import Control.Concurrent +import qualified Control.Exception as E + +import Foreign +import Foreign.C.Types (CChar, CInt(..), CUInt(..)) +import Foreign.C.String (CString) + +--import Data.List (elemIndex) +import Data.Tuple (swap) +import Data.Typeable (Proxy(..)) +import Data.Maybe (fromMaybe) +import Data.IORef +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as Bu +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Unsafe as Un + +import Control.Lens ( (^.), makeLenses, + --set, Lens' + ) + +import System.IO.Unsafe (unsafePerformIO) + +-- Import all of it! +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.Exception ( + IOProblem + , NoMoreDataException(..) + , keyedReportExceptions + ) +import SecondTransfer.TLS.Types ( ProtocolSelector + , TLSContext (..) ) + +#include "instruments.cpphs" + +data BotanTLSChannel + +type RawFilePath = B.ByteString + +type BotanTLSChannelPtr = Ptr BotanTLSChannel + +type BotanTLSChannelFPtr = ForeignPtr BotanTLSChannel + +data BotanPad = BotanPad { + _encryptedSide_BP :: IOCallbacks + , _availableData_BP :: IORef Bu.Builder + , _tlsChannel_BP :: IORef BotanTLSChannelFPtr + , _dataCame_BP :: MVar () + , _handshakeCompleted_BP :: MVar () + , _writeLock_BP :: MVar () + , _active_BP :: MVar () + , _protocolSelector_BP :: B.ByteString -> IO (Int, B.ByteString) + , _selectedProtocol_BP :: MVar (Maybe (B.ByteString, Int)) + , _problem_BP :: MVar () + } + +type BotanPadRef = StablePtr BotanPad + +makeLenses ''BotanPad + +newtype BotanSession = BotanSession (IORef BotanPad) + +data BotanTLSContextAbstract + +type BotanTLSContextCSidePtr = Ptr BotanTLSContextAbstract + +type BotanTLSContextCSideFPtr = ForeignPtr BotanTLSContextAbstract + +data BotanTLSContext = BotanTLSContext { + _cppSide_BTC :: BotanTLSContextCSideFPtr + , _protocolSelector_BTC :: ProtocolSelector + } + +makeLenses ''BotanTLSContext + + +-- withBotanPadLock :: Lens' BotanPad (MVar ()) -> BotanPadRef -> (BotanPad -> IO a) -> IO a +-- withBotanPadLock lock_getter siocb cb = do +-- botan_pad <- deRefStablePtr siocb +-- let +-- lock_mvar = botan_pad ^. lock_getter +-- withMVar lock_mvar $ \ _ -> cb botan_pad + +withBotanPad :: BotanPadRef -> (BotanPad -> IO a) -> IO a +withBotanPad siocb cb = do + botan_pad <- deRefStablePtr siocb + cb botan_pad + +dontMultiThreadBotan :: MVar () +{-# NOINLINE dontMultiThreadBotan #-} +dontMultiThreadBotan = unsafePerformIO (newMVar ()) + +-- withBotanPadReadLock :: BotanPadRef -> (BotanPad -> IO () ) -> IO () +-- withBotanPadReadLock = withBotanPadLock readLock_BP + +-- withBotanPadWriteLock :: BotanPadRef -> (BotanPad -> IO () ) -> IO () +-- withBotanPadWriteLock = withBotanPadLock writeLock_BP + + +-- Botan calls this function whenever it wishes to send any data +-- to the remote peer. In some cases we can not honor Botan's wishes +foreign export ccall iocba_push :: BotanPadRef -> Ptr CChar -> CInt -> IO () +iocba_push :: BotanPadRef -> Ptr CChar -> CInt -> IO () +iocba_push siocb p len = + withBotanPad siocb $ \ botan_pad -> do + let + push_action = botan_pad ^. (encryptedSide_BP . pushAction_IOC ) + cstr = (p, fromIntegral len) + problem_mvar = botan_pad ^. problem_BP + handler :: IOProblem -> IO () + handler _ = do + _ <- tryPutMVar problem_mvar () + _ <- tryPutMVar (botan_pad ^. dataCame_BP) () + return () + b <- B.packCStringLen cstr + problem <- tryReadMVar problem_mvar + case problem of + Nothing -> + keyedReportExceptions "iocba_push" $ E.catch + (push_action (LB.fromStrict b)) + handler + + Just _ -> do + -- Ignore, but don't send any data + --putStrLn "IGNORED DATA SEND ON ENCR SOCKET" + return () + + +-- | Callback invoked by Botan with clear text data just decoded from the stream +foreign export ccall iocba_data_cb :: BotanPadRef -> Ptr CChar -> CInt -> IO () +iocba_data_cb :: BotanPadRef -> Ptr CChar -> CInt -> IO () +iocba_data_cb siocb p len = withBotanPad siocb $ \ botan_pad -> do + let + cstr = (p, fromIntegral len) + avail_data = botan_pad ^. availableData_BP + b <- B.packCStringLen cstr + if B.length b > 0 + then do + atomicModifyIORef' avail_data $ \ previous -> ( previous `mappend` (Bu.byteString b), ()) + --putStrLn "Got data" + _ <- tryPutMVar (botan_pad ^. dataCame_BP) () + return () + else do + -- Shouldn't ever happen + putStrLn "EmptyStringGot" + return () + + +-- TODO: Should we raise some sort of exception here? Maybe call the "closeAction" +-- in the other sides? +foreign export ccall iocba_alert_cb :: BotanPadRef -> CInt -> IO () +iocba_alert_cb :: BotanPadRef -> CInt -> IO () +iocba_alert_cb siocb alert_code = withBotanPad siocb $ \botan_pad -> do + let + problem_mvar = botan_pad ^. problem_BP + putStrLn $ "tls alert " ++ (show alert_code) + if (alert_code < 0) + then do + _ <- tryPutMVar problem_mvar () + _ <- tryPutMVar (botan_pad ^. dataCame_BP) () + return () + else + return () + + +-- Botan relies a wealth of information here, not using at the moment :-( +foreign export ccall iocba_handshake_cb :: BotanPadRef -> IO () +iocba_handshake_cb :: BotanPadRef -> IO () +iocba_handshake_cb siocb = do + withBotanPad siocb $ \botan_pad -> do + let + hcmvar = botan_pad ^. handshakeCompleted_BP + _ <-tryPutMVar hcmvar () + maybe_protocol <- tryReadMVar (botan_pad ^. selectedProtocol_BP) + + -- If by this time no ALPN has completed, signal that + case maybe_protocol of + Nothing -> do + putMVar (botan_pad ^. selectedProtocol_BP ) Nothing + Just _something -> do + -- It's already in the var + return () + return () + + +foreign export ccall iocba_select_protocol_cb :: BotanPadRef -> Ptr CChar -> Int -> IO Int +iocba_select_protocol_cb :: BotanPadRef -> Ptr CChar -> Int -> IO Int +iocba_select_protocol_cb siocb p len = + withBotanPad siocb $ \ botan_pad -> do + let + cstr = (p, fromIntegral len) + selector = botan_pad ^. protocolSelector_BP + b <- B.packCStringLen cstr + (chosen_protocol_int, ss) <- selector b + let + selected_protocol_mvar = botan_pad ^. selectedProtocol_BP + putMVar selected_protocol_mvar (Just (ss, chosen_protocol_int )) + return chosen_protocol_int + + +foreign import ccall iocba_cleartext_push :: BotanTLSChannelPtr -> Ptr CChar -> Int -> IO () + +foreign import ccall iocba_close :: BotanTLSChannelPtr -> IO () + +foreign import ccall "&iocba_delete_tls_context" iocba_delete_tls_context :: FunPtr( BotanTLSContextCSidePtr -> IO () ) + +foreign import ccall iocba_make_tls_context :: CString -> CString -> IO BotanTLSContextCSidePtr + +foreign import ccall iocba_make_tls_context_from_memory :: CString -> CUInt -> CString -> CUInt -> IO BotanTLSContextCSidePtr + +foreign import ccall "&iocba_delete_tls_server_channel" iocba_delete_tls_server_channel :: FunPtr( BotanTLSChannelPtr -> IO () ) + +--foreign import ccall "wrapper" mkTlsServerDeleter :: (BotanTLSChannelPtr -> IO ()) -> IO (FunPtr ( BotanTLSChannelPtr -> IO () ) ) + +foreign import ccall iocba_receive_data :: BotanTLSChannelPtr -> Ptr CChar -> CInt -> IO CInt + + +botanPushData :: BotanPad -> LB.ByteString -> IO () +botanPushData botan_pad datum = do + let + strict_datum = LB.toStrict datum + write_lock = botan_pad ^. writeLock_BP + channel_ioref = botan_pad ^. tlsChannel_BP + problem_mvar = botan_pad ^. problem_BP + handshake_completed_mvar = botan_pad ^. handshakeCompleted_BP + readMVar handshake_completed_mvar + channel <- readIORef channel_ioref + withMVar write_lock $ \ _ -> do + mp <- tryReadMVar problem_mvar + case mp of + Nothing -> + Un.unsafeUseAsCStringLen strict_datum $ \ (pch, len) -> do + withForeignPtr channel $ \ c -> withMVar dontMultiThreadBotan . const $ do + iocba_cleartext_push c pch len + + Just _ -> do + --(botan_pad ^. encryptedSide_BP . closeAction_IOC ) + --putStrLn "bpRaise" + E.throwIO $ NoMoreDataException + + +-- Bad things will happen if serveral threads are calling this concurrently!! +pullAvailableData :: BotanPad -> Bool -> IO B.ByteString +pullAvailableData botan_pad can_wait = do + let + data_came_mvar = botan_pad ^. dataCame_BP + avail_data_iorref = botan_pad ^. availableData_BP + io_problem_mvar = botan_pad ^. problem_BP + -- And here inside cleanup. The block below doesn't compose with other instances of + -- reads happening simultaneously + avail_data <- atomicModifyIORef' avail_data_iorref $ \ bu -> (mempty, bu) + let + avail_data_lb = Bu.toLazyByteString avail_data + case ( LB.length avail_data_lb == 0 , can_wait ) of + (True, True) -> do + -- Just wait for more data coming here + takeMVar data_came_mvar + maybe_problem <- tryReadMVar io_problem_mvar + case maybe_problem of + Nothing -> + pullAvailableData botan_pad True + + Just () -> do + -- avail_data' <- atomicModifyIORef' avail_data_iorref $ \ bu -> (mempty, bu) + -- putStrLn "ProblemTranslated -- Botan" + -- putStrLn $ "(stuck: " ++ (show . LB.length . Bu.toLazyByteString $ avail_data' ) ++ ")" + E.throwIO NoMoreDataException + + (_, _) -> do + let + result = LB.toStrict avail_data_lb + -- putStrLn $ "BotanPassingUp #bytes = " ++ (show $ B.length result ) + return result + + +foreign import ccall iocba_new_tls_server_channel :: + BotanPadRef + -> BotanTLSContextCSidePtr + -> IO BotanTLSChannelPtr + +-- TODO: Move this to "SecondTransfer.TLS.Utils" module +protocolSelectorToC :: ProtocolSelector -> B.ByteString -> IO (Int, B.ByteString) +protocolSelectorToC prot_sel flat_protocols = do + let + protocol_list = B.split 0 flat_protocols + maybe_idx <- prot_sel protocol_list + let + report_idx = fromMaybe (-1) maybe_idx + report_bs = if report_idx >= 0 then protocol_list !! report_idx else "" + return (report_idx, report_bs) + + +newBotanTLSContext :: RawFilePath -> RawFilePath -> ProtocolSelector -> IO BotanTLSContext +newBotanTLSContext cert_filename privkey_filename prot_sel = + do + B.useAsCString cert_filename $ \ s1 -> + B.useAsCString privkey_filename $ \ s2 -> do + ctx_ptr <- iocba_make_tls_context s1 s2 + x <- newForeignPtr iocba_delete_tls_context ctx_ptr + return $ BotanTLSContext x prot_sel + + +newBotanTLSContextFromMemory :: B.ByteString -> B.ByteString -> ProtocolSelector -> IO BotanTLSContext +newBotanTLSContextFromMemory cert_data key_data prot_sel = + do + B.useAsCString cert_data $ \ s1 -> + B.useAsCString key_data $ \s2 -> do + ctx_ptr <- iocba_make_tls_context_from_memory + s1 + (fromIntegral . B.length $ cert_data) + s2 + (fromIntegral . B.length $ key_data) + x <- newForeignPtr iocba_delete_tls_context ctx_ptr + return $ BotanTLSContext x prot_sel + + +unencryptChannelData :: TLSServerIO a => BotanTLSContext -> a -> IO BotanSession +unencryptChannelData botan_ctx tls_data = do + let + fctx = botan_ctx ^. cppSide_BTC + protocol_selector = botan_ctx ^. protocolSelector_BTC + + tls_io_callbacks <- handshake tls_data + data_came_mvar <- newEmptyMVar + handshake_completed_mvar <- newEmptyMVar + problem_mvar <- newEmptyMVar + selected_protocol_mvar <- newEmptyMVar + active_mvar <- newMVar () + tls_channel_ioref <- newIORef (error "") + avail_data_ioref <- newIORef mempty + + write_lock_mvar <- newMVar () + + let + new_botan_pad = BotanPad { + _encryptedSide_BP = tls_io_callbacks + , _availableData_BP = avail_data_ioref + , _tlsChannel_BP = tls_channel_ioref + , _dataCame_BP = data_came_mvar + , _handshakeCompleted_BP = handshake_completed_mvar + , _writeLock_BP = write_lock_mvar + , _protocolSelector_BP = protocolSelectorToC protocol_selector + , _selectedProtocol_BP = selected_protocol_mvar + , _problem_BP = problem_mvar + , _active_BP = active_mvar + } + + tls_pull_data_action = tls_io_callbacks ^. bestEffortPullAction_IOC + + destructor = + -- withMVar dontMultiThreadBotan . const $ + iocba_delete_tls_server_channel + + botan_pad_stable_ref <- newStablePtr new_botan_pad + + tls_channel_ptr <- withForeignPtr fctx $ \ x -> iocba_new_tls_server_channel botan_pad_stable_ref x + + tls_channel_fptr <- newForeignPtr destructor tls_channel_ptr + + let + + pump_exc_handler :: IOProblem -> IO (Maybe B.ByteString) + pump_exc_handler _ = do + _ <- tryPutMVar problem_mvar () + -- Wake-up any readers... + _ <- tryPutMVar data_came_mvar () + return Nothing + + -- Feeds encrypted data to Botan + pump :: IO () + pump = do + maybe_new_data <- E.catch + (Just <$> tls_pull_data_action True) + pump_exc_handler + case maybe_new_data of + Just new_data + | B.length new_data > 0 -> do + can_continue <- withMVar write_lock_mvar $ \_ -> do + maybe_problem <- tryReadMVar problem_mvar + case maybe_problem of + Nothing -> do + engine_result <- + Un.unsafeUseAsCStringLen new_data $ \ (pch, len) -> + withMVar dontMultiThreadBotan . const $ + iocba_receive_data tls_channel_ptr pch (fromIntegral len) + if engine_result < 0 + then do + _ <- tryPutMVar problem_mvar () + -- Just awake any variables + _ <- tryPutMVar data_came_mvar () + return False + else + return True + Just _ -> do + return False + if can_continue + then do + pump + else + return () + | otherwise -> do + -- This is actually an error + pump + + Nothing -> do + -- On exceptions, finish this thread + return () + + writeIORef tls_channel_ioref tls_channel_fptr + + result <- newIORef new_botan_pad + + _ <- mkWeakIORef result $ do + closeBotan new_botan_pad + freeStablePtr botan_pad_stable_ref + + -- Create the pump thread + _ <- forkIO pump + + return $ BotanSession result + + +closeBotan :: BotanPad -> IO () +closeBotan botan_pad = + do + tls_channel_fptr <- readIORef (botan_pad ^. tlsChannel_BP) + withForeignPtr tls_channel_fptr $ \ tls_channel_ptr -> do + maybe_gotit <- tryTakeMVar (botan_pad ^. active_BP) + case maybe_gotit of + Just _ -> do + -- Let's forbid libbotan for sending more output + _ <- tryPutMVar (botan_pad ^. problem_BP) () + -- Cleanly close tls, if nobody else is writing there + withMVar (botan_pad ^. writeLock_BP) $ \ _ -> do + withMVar dontMultiThreadBotan . const $ + iocba_close tls_channel_ptr + _ <- tryPutMVar (botan_pad ^. problem_BP) () + _ <- tryPutMVar (botan_pad ^. dataCame_BP) () + return () + -- Close the cypher-text transport + (botan_pad ^. encryptedSide_BP . closeAction_IOC) + -- Ensure that no calls are made to any of the IO callbacks after the + -- stable pointer is fred + + return () + + Nothing -> + -- Thing already closed, don't do it again + return () + + +instance IOChannels BotanSession where + + handshake _botan_session@(BotanSession botan_ioref) = do + + let + -- Capture the IORef to avoid early finalization + push_action :: PushAction + push_action bs = do + botan_pad <- readIORef botan_ioref + botanPushData botan_pad bs + + best_effort_pull_action :: BestEffortPullAction + best_effort_pull_action x = do + botan_pad <- readIORef botan_ioref + pullAvailableData botan_pad x + + pull_action_wrapping <- newPullActionWrapping best_effort_pull_action + + botan_pad' <- readIORef botan_ioref + let + pull_action :: PullAction + pull_action = pullFromWrapping' pull_action_wrapping + + best_effort_pull_action' = bestEffortPullFromWrapping pull_action_wrapping + + close_action :: CloseAction + close_action = closeBotan botan_pad' + + handshake_completed_mvar = botan_pad' ^. handshakeCompleted_BP + + -- We will be waiting for the handshake... + readMVar handshake_completed_mvar + + return $ IOCallbacks { + _pushAction_IOC = push_action + , _pullAction_IOC = pull_action + , _bestEffortPullAction_IOC = best_effort_pull_action' + , _closeAction_IOC = close_action + } + + +instance TLSContext BotanTLSContext BotanSession where + newTLSContextFromMemory = newBotanTLSContextFromMemory + newTLSContextFromCertFileNames = newBotanTLSContext + unencryptTLSServerIO = unencryptChannelData + getSelectedProtocol (BotanSession pad_ioref) = do + botan_pad <- readIORef pad_ioref + a <- readMVar (botan_pad ^. selectedProtocol_BP) + return ( swap <$> a) + + +botanTLS :: Proxy BotanTLSContext +botanTLS = Proxy diff --git a/hs-src/SecondTransfer/TLS/CoreServer.hs b/hs-src/SecondTransfer/TLS/CoreServer.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/TLS/CoreServer.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE RankNTypes, + FunctionalDependencies, + PartialTypeSignatures, + OverloadedStrings, + ScopedTypeVariables, + TemplateHaskell + #-} +module SecondTransfer.TLS.CoreServer ( + -- * Simpler interfaces + -- These functions are simple enough but don't work with controllable + -- processes. + tlsServeWithALPN + , tlsServeWithALPNNSSockAddr + , tlsSessionHandler + , tlsServeWithALPNUnderSOCKS5SockAddr + + -- * Interfaces for a pre-fork scenario + -- The first part of the invocation opens and + -- bind the socket, the second part does the accepting... + , NormalTCPHold + , tlsServeWithALPNNSSockAddr_Prepare + , tlsServeWithALPNNSSockAddr_Do + , Socks5Hold + + , tlsServeWithALPNUnderSOCKS5SockAddr_Prepare + , tlsServeWithALPNUnderSOCKS5SockAddr_Do + + , coreListen + + -- * Utility + , NamedAttendants + , chooseProtocol + + -- * Conduit-based session management + -- , coreItcli + + ) where + +import Control.Concurrent +--import Control.Monad.IO.Class (liftIO) +--import Control.Monad (when) +import Control.Lens ( (^.), makeLenses, over, set ) + +--import Data.Conduit +-- import qualified Data.Conduit as Con(yield) +--import qualified Data.Conduit.List as CL +import Data.Typeable (Proxy(..)) +import Data.List (elemIndex) +import Data.Maybe (-- fromMaybe, + isJust) +import qualified Data.ByteString as B +import Data.ByteString.Char8 (pack, unpack) +import Data.Int (Int64) +-- import Data.IORef + +--import qualified Data.ByteString.Lazy as LB +--import qualified Data.ByteString.Builder as Bu + +import qualified Network.Socket as NS + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.TLS.Types +import SecondTransfer.IOCallbacks.SocketServer +import SecondTransfer.IOCallbacks.WrapSocket (HasSocketPeer(..)) + +import SecondTransfer.Socks5.Session (tlsSOCKS5Serve, initSocks5ServerState) +import SecondTransfer.Socks5.Types (Socks5ConnectionCallbacks) +import SecondTransfer.Exception (forkIOExc) + +import SecondTransfer.Sessions.HashableSockAddr (hashableSockAddrFromNSSockAddr) + +--import Debug.Trace (traceStack) + + +data SessionHandlerState = SessionHandlerState { + _liveSessions_S :: !Int64 + , _nextConnId_S :: !Int64 + , _connCallbacks_S :: ConnectionCallbacks + } + +makeLenses ''SessionHandlerState + + +-- | A simple Alias +type NamedAttendants = [(String, Attendant)] + + +-- | Convenience function to open a port and listen there for connections and +-- select protocols and so on. +tlsServeWithALPN :: forall ctx session . (TLSContext ctx session) + => (Proxy ctx ) -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Control and log connections + -> B.ByteString -- ^ String with contents of certificate chain + -> B.ByteString -- ^ String with contents of PKCS #8 key + -> String -- ^ Name of the network interface + -> NamedAttendants -- ^ List of attendants and their handlers + -> Int -- ^ Port to listen for connections + -> IO () +tlsServeWithALPN proxy conn_callbacks cert_filename key_filename interface_name attendants interface_port = do + listen_socket <- createAndBindListeningSocket interface_name interface_port + coreListen proxy conn_callbacks cert_filename key_filename listen_socket tlsServe attendants + +-- | Use a previously given network address +tlsServeWithALPNNSSockAddr :: forall ctx session . (TLSContext ctx session) + => (Proxy ctx ) -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Control and regulate SOCKS5 connections + -> B.ByteString -- ^ String with contents of certificate chain + -> B.ByteString -- ^ String with contents of PKCS #8 key + -> NS.SockAddr -- ^ Address to bind to + -> NamedAttendants -- ^ List of attendants and their handlers + -> IO () +tlsServeWithALPNNSSockAddr proxy conn_callbacks cert_filename key_filename sock_addr attendants = do + listen_socket <- createAndBindListeningSocketNSSockAddr sock_addr + coreListen proxy conn_callbacks cert_filename key_filename listen_socket tlsServe attendants + +data NormalTCPHold = NormalTCPHold ( IO () ) + +-- | The prefork way requires a first step where we create the sockets and then we listen on them... +-- This function is identical otherwise to the one without _Prepare. The real thing is done by the +-- one with _Do below... +tlsServeWithALPNNSSockAddr_Prepare :: forall ctx session . (TLSContext ctx session) + => (Proxy ctx ) -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Control and regulate SOCKS5 connections + -> B.ByteString -- ^ String with contents of certificate chain + -> B.ByteString -- ^ String with contents of PKCS #8 key + -> NS.SockAddr -- ^ Address to bind to + -> IO NamedAttendants -- ^ Will-be list of attendants and their handlers + -> IO NormalTCPHold +tlsServeWithALPNNSSockAddr_Prepare proxy conn_callbacks cert_filename key_filename sock_addr make_attendants = do + listen_socket <- createAndBindListeningSocketNSSockAddr sock_addr + return . NormalTCPHold $ do + attendants <- make_attendants + coreListen proxy conn_callbacks cert_filename key_filename listen_socket tlsServe attendants + + +-- | Actually listen, possibly at the other side of the fork. +tlsServeWithALPNNSSockAddr_Do :: NormalTCPHold -> IO () +tlsServeWithALPNNSSockAddr_Do (NormalTCPHold action) = action + + +tlsServeWithALPNUnderSOCKS5SockAddr :: forall ctx session . (TLSContext ctx session) + => Proxy ctx -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Log and control of the inner TLS session + -> Socks5ConnectionCallbacks -- ^ Log and control the outer SOCKS5 session + -> B.ByteString -- ^ String with contents of certificate chain + -> B.ByteString -- ^ String with contents of PKCS #8 key + -> NS.SockAddr -- ^ Address to bind to + -> NamedAttendants -- ^ List of attendants and their handlers, + -> [B.ByteString] -- ^ Names of "internal" hosts + -> Bool -- ^ Should I forward connection requests? + -> IO () +tlsServeWithALPNUnderSOCKS5SockAddr + proxy + conn_callbacks + socks5_callbacks + cert_filename + key_filename + host_addr + attendants + internal_hosts + forward_no_internal = do + let + approver :: B.ByteString -> Bool + approver name = isJust $ elemIndex name internal_hosts + socks5_state_mvar <- newMVar initSocks5ServerState + listen_socket <- createAndBindListeningSocketNSSockAddr host_addr + coreListen + proxy + conn_callbacks + cert_filename + key_filename + listen_socket + (tlsSOCKS5Serve socks5_state_mvar socks5_callbacks approver forward_no_internal) + attendants + + +-- | Opaque hold type +data Socks5Hold = Socks5Hold (IO ()) + + +tlsServeWithALPNUnderSOCKS5SockAddr_Prepare :: forall ctx session . (TLSContext ctx session) + => Proxy ctx -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Log and control of the inner TLS session + -> Socks5ConnectionCallbacks -- ^ Log and control the outer SOCKS5 session + -> B.ByteString -- ^ String with contents of certificate chain + -> B.ByteString -- ^ String with contents of PKCS #8 key + -> NS.SockAddr -- ^ Address to bind to + -> IO NamedAttendants -- ^ List of attendants and their handlers, as it will be built + -> [B.ByteString] -- ^ Names of "internal" hosts + -> Bool -- ^ Should I forward connection requests? + -> IO Socks5Hold +tlsServeWithALPNUnderSOCKS5SockAddr_Prepare + proxy + conn_callbacks + socks5_callbacks + cert_pemfile_data + key_pemfile_data + host_addr + make_attendants + internal_hosts + forward_no_internal = do + let + approver :: B.ByteString -> Bool + approver name = isJust $ elemIndex name internal_hosts + socks5_state_mvar <- newMVar initSocks5ServerState + listen_socket <- createAndBindListeningSocketNSSockAddr host_addr + return . Socks5Hold $ do + attendants <- make_attendants + coreListen + proxy + conn_callbacks + cert_pemfile_data + key_pemfile_data + listen_socket + (tlsSOCKS5Serve socks5_state_mvar socks5_callbacks approver forward_no_internal) + attendants + + +tlsServeWithALPNUnderSOCKS5SockAddr_Do :: Socks5Hold -> IO () +tlsServeWithALPNUnderSOCKS5SockAddr_Do (Socks5Hold action) = action + + +tlsSessionHandler :: (TLSContext ctx session, TLSServerIO encrypted_io, HasSocketPeer encrypted_io) => + MVar SessionHandlerState + -> NamedAttendants + -> ctx + -> encrypted_io + -> IO () +tlsSessionHandler session_handler_state_mvar attendants ctx encrypted_io = do + -- Have the handshake happen in another thread + _ <- forkIOExc "tlsSessionHandler" $ do + + -- Get a new connection id + (new_conn_id, live_now) <- modifyMVar session_handler_state_mvar $ \ s -> do + let new_conn_id = s ^. nextConnId_S + live_now_ = (s ^. liveSessions_S) + 1 + new_s = over nextConnId_S ( + 1 ) s + new_new_s = live_now_ `seq` set liveSessions_S live_now_ new_s + return $ new_new_s `seq` (new_new_s, (new_conn_id, live_now_) ) + + connection_callbacks <- withMVar session_handler_state_mvar $ \ s -> do + return $ s ^. connCallbacks_S + let + log_events_maybe = connection_callbacks ^. logEvents_CoCa + log_event :: ConnectionEvent -> IO () + log_event ev = case log_events_maybe of + Nothing -> return () + Just c -> c ev + wconn_id = ConnectionId new_conn_id + sock_addr <- getSocketPeerAddress encrypted_io + let + hashable_addr = hashableSockAddrFromNSSockAddr sock_addr + connection_data = ConnectionData hashable_addr + log_event (Established_CoEv sock_addr wconn_id live_now) + session <- unencryptTLSServerIO ctx encrypted_io + plaintext_io_callbacks_u <- handshake session :: IO IOCallbacks + + close_reported <- newMVar False + + let + instr = do + modifyMVar_ close_reported $ \ close_reported_x -> do + if (not close_reported_x) then do + -- We can close just once + plaintext_io_callbacks_u ^. closeAction_IOC + log_event (Ended_CoEv wconn_id) + modifyMVar_ session_handler_state_mvar $ \ s -> do + let + live_now_ = (s ^. liveSessions_S) - 1 + new_new_s = set liveSessions_S live_now_ s + new_new_s `seq` return new_new_s + return True + else + return close_reported_x + + plaintext_io_callbacks = set closeAction_IOC instr plaintext_io_callbacks_u + + maybe_sel_prot <- getSelectedProtocol session + let maybe_attendant = + case maybe_sel_prot of + Just (_, prot_name) -> + lookup (unpack prot_name) attendants + Nothing -> + lookup "" attendants + case maybe_attendant of + Just use_attendant -> + use_attendant connection_data plaintext_io_callbacks + Nothing -> do + log_event (ALPNFailed_CoEv wconn_id) + plaintext_io_callbacks ^. closeAction_IOC + return () + + +-- tlsSessionHandlerControllable :: (TLSContext ctx session, TLSServerIO encrypted_io) +-- => [(String, ControllableAttendant controller)] -> ctx -> encrypted_io -> IO (Maybe controller) +-- tlsSessionHandlerControllable attendants ctx encrypted_io = do +-- session <- unencryptTLSServerIO ctx encrypted_io +-- plaintext_io_callbacks <- handshake session :: IO IOCallbacks +-- maybe_sel_prot <- getSelectedProtocol session +-- case maybe_sel_prot of +-- Just (_, prot_name) -> do +-- let +-- Just use_attendant = lookup (unpack prot_name) attendants +-- x <- use_attendant plaintext_io_callbacks +-- return . Just $ x + +-- Nothing -> do +-- let +-- maybe_attendant = lookup "" attendants +-- case maybe_attendant of +-- Just use_attendant -> do +-- x <- use_attendant plaintext_io_callbacks +-- return . Just $ x +-- Nothing -> do +-- -- Silently do nothing, and close the connection +-- plaintext_io_callbacks ^. closeAction_IOC +-- return Nothing + + + +chooseProtocol :: [(String, a)] -> [B.ByteString] -> IO (Maybe Int) +chooseProtocol attendants proposed_protocols = + let + i_want_protocols = map (pack . fst) attendants + chosen = + foldl + ( \ selected want_protocol -> + case (selected, elemIndex want_protocol proposed_protocols) of + ( Just a, _) -> Just a + (_, Just idx) -> Just idx + (_, _ ) -> Nothing + ) + Nothing + i_want_protocols + in return chosen + + +coreListen :: + forall a ctx session b . (TLSContext ctx session, TLSServerIO b, HasSocketPeer b) + => (Proxy ctx ) -- ^ This is a simple proxy type from Typeable that is used to select the type + -- of TLS backend to use during the invocation + -> ConnectionCallbacks -- ^ Functions to log and control behaviour of the server + -> B.ByteString -- ^ PEM-encoded certificate chain, in this string + -> B.ByteString -- ^ PEM-encoded, un-encrypted PKCS #8 key in this string + -> a -- ^ An entity that is used to fork new handlers + -> ( a -> (b -> IO()) -> IO () ) -- ^ The fork-handling functionality + -> [(String, Attendant)] -- ^ List of attendants and their handlers + -> IO () +coreListen _ conn_callbacks certificate_pemfile_data key_pemfile_data listen_abstraction session_forker attendants = do + let + state = SessionHandlerState { + _liveSessions_S = 0 + , _nextConnId_S = 0 + , _connCallbacks_S = conn_callbacks + } + state_mvar <- newMVar state + ctx <- newTLSContextFromMemory certificate_pemfile_data key_pemfile_data (chooseProtocol attendants) :: IO ctx + session_forker listen_abstraction (tlsSessionHandler state_mvar attendants ctx) + + +-- | A conduit that takes TLS-encrypted callbacks, creates a TLS server session on top of it, passes the resulting +-- plain-text io-callbacks to a chosen Attendant in the argument list, and passes up the controller of the attendant +-- so that it can be undone if needs come. This should be considered a toy API, as multiple handshake can not progress +-- simultaeneusly through Conduits, so a server using this would be blocked for the entire length of a TLS handshake +-- with a remote client .... :-( + + +-- coreItcli :: +-- forall ctx session b . (TLSContext ctx session, TLSServerIO b) +-- => ctx -- ^ Passing in a tls context already-built value allows for sharing a single +-- -- context across multiple listening abstractions... +-- -> [(String, Attendant)] -- ^ List of attendants and their handlers +-- -> Conduit b IO () +-- coreItcli ctx controllable_attendants = do +-- let +-- monomorphicHandler :: [(String, Attendant )] -> ctx -> b -> IO () +-- monomorphicHandler = tlsSessionHandler +-- CL.mapMaybeM $ liftIO <$> monomorphicHandler controllable_attendants ctx diff --git a/hs-src/SecondTransfer/TLS/Types.hs b/hs-src/SecondTransfer/TLS/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/SecondTransfer/TLS/Types.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Rank2Types, FunctionalDependencies, TemplateHaskell, GeneralizedNewtypeDeriving #-} +module SecondTransfer.TLS.Types ( + FinishRequest (..) + , ProtocolSelector + + + , TLSContext (..) + + , ConnectionId (..) + , ConnectionEvent (..) + , ConnectionCallbacks (..) + , logEvents_CoCa + , defaultConnectionCallbacks + ) where + + +import Control.Lens +import qualified Data.ByteString as B +import Data.Int (Int64) + +import qualified Network.Socket as NS(SockAddr) + +import SecondTransfer.IOCallbacks.Types (TLSServerIO, IOChannels) + +-- | Singleton type. Used in conjunction with an `MVar`. If the MVar is full, +-- the fuction `tlsServeWithALPNAndFinishOnRequest` knows that it should finish +-- at its earliest convenience and call the `CloseAction` for any open sessions. +data FinishRequest = FinishRequest + +-- | Given a list of ALPN identifiers, if something is suitable, return it. +type ProtocolSelector = [B.ByteString] -> IO (Maybe Int) + + +-- | Types implementing this class are able to say a little bit about their peer. +class IOChannels session => TLSContext ctx session | ctx -> session, session -> ctx where + newTLSContextFromMemory :: B.ByteString -> B.ByteString -> ProtocolSelector -> IO ctx + newTLSContextFromCertFileNames :: B.ByteString -> B.ByteString -> ProtocolSelector -> IO ctx + unencryptTLSServerIO :: forall cipherio . TLSServerIO cipherio => ctx -> cipherio -> IO session + getSelectedProtocol :: session -> IO (Maybe (Int, B.ByteString)) + + +-- | A connection number +newtype ConnectionId = ConnectionId Int64 + deriving (Eq, Ord, Show, Enum) + + +-- | Connection events +data ConnectionEvent = + Established_CoEv NS.SockAddr ConnectionId Int64 -- ^ New connection. The second member says how many live connections are now + | ALPNFailed_CoEv ConnectionId -- ^ An ALPN negotiation failed + | Ended_CoEv ConnectionId -- ^ A connection ended. + + +type LogCallback = ConnectionEvent -> IO () + +-- | Callbacks used by client applications to get notified about interesting +-- events happening at a connection level, or to get asked about things +-- (e.g, about if it is proper to accept a connection). These are used from CoreServer +data ConnectionCallbacks = ConnectionCallbacks { + -- | Invoked after the connection is accepted, and after it is finished. + _logEvents_CoCa :: Maybe LogCallback + } + +makeLenses ''ConnectionCallbacks + +-- | Default connections callback. Empty +defaultConnectionCallbacks :: ConnectionCallbacks +defaultConnectionCallbacks = ConnectionCallbacks { + _logEvents_CoCa = Nothing + } diff --git a/hs-src/SecondTransfer/Types.hs b/hs-src/SecondTransfer/Types.hs --- a/hs-src/SecondTransfer/Types.hs +++ b/hs-src/SecondTransfer/Types.hs @@ -1,9 +1,9 @@ module SecondTransfer.Types( - module SecondTransfer.MainLoop.PushPullType + module SecondTransfer.IOCallbacks.Types ,module SecondTransfer.MainLoop.CoherentWorker ,module SecondTransfer.MainLoop.Protocol ) where -import SecondTransfer.MainLoop.PushPullType +import SecondTransfer.IOCallbacks.Types import SecondTransfer.MainLoop.CoherentWorker import SecondTransfer.MainLoop.Protocol diff --git a/hs-src/SecondTransfer/Utils.hs b/hs-src/SecondTransfer/Utils.hs --- a/hs-src/SecondTransfer/Utils.hs +++ b/hs-src/SecondTransfer/Utils.hs diff --git a/hs-src/SecondTransfer/Utils/DevNull.hs b/hs-src/SecondTransfer/Utils/DevNull.hs --- a/hs-src/SecondTransfer/Utils/DevNull.hs +++ b/hs-src/SecondTransfer/Utils/DevNull.hs @@ -1,17 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} module SecondTransfer.Utils.DevNull( - dropIncomingData - ) where + dropIncomingData + , dropWouldGoData + ) where -import Control.Concurrent (forkIO) -import Control.Monad.IO.Class (liftIO) +import Data.Conduit -import Data.Conduit +import Control.Monad.IO.Class (liftIO, MonadIO) +import qualified Control.Monad.Trans.Resource as ReT import SecondTransfer.MainLoop.CoherentWorker -import SecondTransfer.MainLoop.Logging(logit) +import SecondTransfer.Exception (forkIOExc) -- TODO: Handling unnecessary data should be done in some other, less -- harmfull way... need to think about that. @@ -20,11 +21,24 @@ -- use this consumer to drop the data to oblivion. Otherwise it will -- remain in an internal queue until the client closes the -- stream, and if the client doesn't want to do so.... -dropIncomingData :: Maybe InputDataStream -> IO () +dropIncomingData :: MonadIO m => Maybe InputDataStream -> m () dropIncomingData Nothing = return () dropIncomingData (Just data_source) = do - forkIO $ - data_source $$ awaitForever (\ _ -> do - liftIO $ logit "stream discarded" + _ <- liftIO . forkIOExc "dropIncomingData" . ReT.runResourceT $ + data_source $$ awaitForever (\ _ -> do return () ) + return () + + +dropWouldGoData :: DataAndConclusion -> IO () +dropWouldGoData data_source = do + let + do_empty = do + x <- await + case x of + Nothing -> return () + Just _ -> do_empty + _ <- forkIOExc "dropWouldGoData" $ do + _ <- ReT.runResourceT . runConduit $ fuseBoth data_source do_empty + return () return () diff --git a/hs-src/SecondTransfer/Utils/HTTPHeaders.hs b/hs-src/SecondTransfer/Utils/HTTPHeaders.hs --- a/hs-src/SecondTransfer/Utils/HTTPHeaders.hs +++ b/hs-src/SecondTransfer/Utils/HTTPHeaders.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, Rank2Types #-} +{-# LANGUAGE OverloadedStrings, Rank2Types, GeneralizedNewtypeDeriving, DeriveGeneric, TemplateHaskell #-} {-| Utilities for working with headers. @@ -30,12 +30,25 @@ -- ** HTTP utilities ,replaceHostByAuthority ,introduceDateHeader + ,headerIsPseudo + ,combineAuthorityAndHost + ,removeConnectionHeaders + ,fusionHeaders + + , PrettyPrintHeadersConfig (..) + , indentSpace_PPHC + , prettyPrintHeaders + , defaultPrettyPrintHeadersConfig ) where import qualified Control.Lens as L import Control.Lens ( (^.) ) +import Control.DeepSeq (deepseq) +import GHC.Generics (Generic) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Bu import Data.ByteString.Char8 (pack) import Data.Char (isUpper) import Data.List (find) @@ -49,12 +62,8 @@ import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Time.Clock (getCurrentTime) -#ifndef IMPLICIT_MONOID -import Control.Applicative ((<$>)) -import Data.Monoid -#endif -import SecondTransfer.MainLoop.CoherentWorker (Headers) +import SecondTransfer.MainLoop.CoherentWorker (Headers, HeaderName, HeaderValue, Header) -- Why having a headers library? The one at Network.HTTP.Headers works -- with Strings and is not very friendly to custom headers. @@ -63,10 +72,10 @@ -- | HTTP headers are case-insensitive, so we can use lowercase versions -- everywhere lowercaseHeaders :: Headers -> Headers -lowercaseHeaders = map (\(h,v) -> (low h, v)) - where - low = encodeUtf8 . toLower . decodeUtf8 +lowercaseHeaders = map (\(h,v) -> (lower h, v)) +lower :: B.ByteString -> B.ByteString +lower = encodeUtf8 . toLower . decodeUtf8 -- | Checks that headers are lowercase headersAreLowercase :: Headers -> Bool @@ -88,27 +97,53 @@ -- | Looks for a given header -fetchHeader :: Headers -> B.ByteString -> Maybe B.ByteString +fetchHeader :: Headers -> HeaderName -> Maybe HeaderValue fetchHeader headers header_name = snd <$> find ( \ x -> fst x == header_name ) headers -newtype Autosorted = Autosorted { toFlatBs :: B.ByteString } - deriving Eq +data HeaderPriority = + Pseudo_Hep + | Important_Hep + | Normal_HeP + deriving (Eq, Ord, Show, Generic) -colon :: Word8 -colon = fromIntegral . fromEnum $ ':' +headerIsPseudo :: HeaderName -> Bool +headerIsPseudo h | B.length h == 0 = False --- Actually.... + | B.head h == colon = True + | otherwise = False +headerIsImportant :: HeaderName -> Bool +headerIsImportant hn | hn == "host" = True + | hn == "date" = True + | hn == "content-length" = True + | hn == "content-type" = True + | hn == "cache-control" = True + | otherwise = False -instance Ord Autosorted where - compare (Autosorted a) (Autosorted b) | (B.head a) == colon, (B.head b) /= colon = LT - compare (Autosorted a) (Autosorted b) | (B.head a) /= colon, (B.head b) == colon = GT - compare (Autosorted a) (Autosorted b) = compare a b +headerPriority :: HeaderName -> HeaderPriority +headerPriority hn | headerIsPseudo hn = Pseudo_Hep + | headerIsImportant hn = Important_Hep + | otherwise = Normal_HeP +-- This is a "flattish" representation of a header using lexical +-- ordering. HeaderName gives HeaderPriority, but we cache it here +-- nonetheless. The last number is used to hold the order. +newtype Autosorted = Autosorted (HeaderPriority, HeaderName, Int) + deriving (Eq, Ord, Show, Generic) + +toFlatBs :: Autosorted -> B.ByteString +toFlatBs (Autosorted (_priority, header_name, _same_order) ) = header_name + + +colon :: Word8 +colon = fromIntegral . fromEnum $ ':' + + -- | Abstract data-type. Use `fromList` to get one of these from `Headers`. -- The underlying representation admits better asymptotics. newtype HeaderEditor = HeaderEditor { innerMap :: Ms.Map Autosorted B.ByteString } @@ -116,13 +151,102 @@ -- This is a pretty uninteresting instance instance Monoid HeaderEditor where mempty = HeaderEditor mempty - mappend (HeaderEditor x) (HeaderEditor y) = HeaderEditor (x `mappend` y) + mappend (HeaderEditor x) (HeaderEditor y) = HeaderEditor (x `combineMaps` y) +-- | Expands a header value with zeros into something else +splitByZeros :: B.ByteString -> [B.ByteString] +splitByZeros = B.split 0 + +-- | Transforms a header value so that characters outside the valid ascii range +-- are replaced by nothings +sanitizeHeaderValue :: HeaderValue -> HeaderValue +sanitizeHeaderValue hv = B.filter (\x -> x >= 32 && x <= 126) hv + +headerToMany :: Int -> Header -> [(Autosorted, HeaderValue)] +headerToMany base (header_name, header_value) = + zip + (map + Autosorted + (zip3 + (repeat (headerPriority header_name)) + (repeat (lower header_name)) + (iterate (+ 1) base) + ) + ) + (map sanitizeHeaderValue $ splitByZeros header_value) + +-- Uses a new base to change the number components in the Autosorted tuple , +-- provided that they are already sorted. +rebase :: Int -> [(Autosorted, HeaderValue)] -> [(Autosorted, HeaderValue)] +rebase _base [] = [] +rebase base ((Autosorted (hp, hn,_),hv ): rest) = (Autosorted (hp, hn, base), hv) : ( rebase (base+1) rest ) + +headerIsSingleton :: HeaderName -> Bool +headerIsSingleton hn | hn == "date" = True + | hn == "content-length" = True + | hn == "content-type" = True + | hn == "expires" = True + | hn == "last-modified" = True + | hn == "content-encoding" = True + | hn == "server" = True + | hn == ":authority" = True + | hn == "host" = True + | hn == ":status" = True + | hn == ":path" = True + | otherwise = False + + +removeDuplicateHeaders :: [(Autosorted,HeaderValue)] -> [(Autosorted, HeaderValue)] +removeDuplicateHeaders [] = [] +removeDuplicateHeaders (a:[]) = [a] +removeDuplicateHeaders ( (Autosorted (hp1, hn1,n1),hv1):(Autosorted (hp2, hn2,n2), hv2):rest ) + | hn1 == hn2 && headerIsSingleton hn1 + = removeDuplicateHeaders ( (Autosorted (hp2, hn2,n2), hv2):rest ) + | otherwise = (Autosorted (hp1, hn1,n1), hv1) : removeDuplicateHeaders ( (Autosorted(hp2, hn2,n2), hv2):rest ) + + +combineMaps :: Ms.Map Autosorted B.ByteString -> Ms.Map Autosorted B.ByteString -> Ms.Map Autosorted B.ByteString +combineMaps mp1 mp2 = + let + at2 :: [(Autosorted, HeaderValue)] + at2 = Ms.toList mp2 + + n1 = Ms.size mp1 + at2' = rebase (n1+1) at2 + + mp3 = mp1 `mappend` (Ms.fromList at2') + at3 = Ms.toList mp3 + at4 = removeDuplicateHeaders at3 + at5 = rebase 0 at4 + in Ms.fromList at5 + + -- | /O(n*log n)/ Builds the editor from a list. fromList :: Headers -> HeaderEditor -fromList = HeaderEditor . Ms.fromList . map (\(hn, hv) -> (Autosorted hn, hv)) +fromList headers = + let + at1go :: Int -> Headers -> [[(Autosorted, HeaderValue)]] + at1go _base [] = [] + at1go base (h:rest) = let + g = headerToMany base h + in g : at1go (base + length g ) rest --- | /O(n)/ Takes the HeaderEditor back to Headers + at1 :: [[(Autosorted, HeaderValue)]] + at1 = at1go 0 headers + + mp1 :: Ms.Map Autosorted HeaderValue + mp1 = Ms.fromList . concat $ at1 + + at2 = Ms.toList mp1 + at3 = removeDuplicateHeaders at2 + at4 = rebase 0 at3 + mp2 = Ms.fromList at4 + in HeaderEditor mp2 + + +-- | /O(n)/ Takes the HeaderEditor back to Headers. Notice that these headers +-- are good for both HTTP/1.1 and HTTP/2, as combined headers won't +-- be merged. It will even work for Cookie headers. toList :: HeaderEditor -> Headers toList (HeaderEditor m) = [ (toFlatBs x, v) | (x,v) <- Ms.toList m ] @@ -135,22 +259,58 @@ -- is Nothing, it returns the original headers list. If header_name is not in headers -- and maybe_header_value is Just new_value, it returns a new list where the last element -- is (header_name, new_value) -replaceHeaderValue :: HeaderEditor -> B.ByteString -> Maybe B.ByteString -> HeaderEditor +replaceHeaderValue :: HeaderEditor -> HeaderName -> Maybe HeaderValue -> HeaderEditor replaceHeaderValue (HeaderEditor m) header_name maybe_header_value = - HeaderEditor $ Ms.alter (const maybe_header_value) (Autosorted header_name) m + let + lst = Ms.toList m + rpl :: Int -> [(Autosorted, HeaderValue)] -> [(Autosorted, HeaderValue)] + rpl rc (e1@(Autosorted (_hp, hn,_n), _hv):rest) + | rc==0, hn == header_name , Just new_value <- maybe_header_value = + (Autosorted (_hp, hn, _n), new_value): (rpl 1 rest) + | rc > 0, hn == header_name = + rpl rc rest + | hn == header_name, Nothing <- maybe_header_value = + rpl rc rest + | otherwise = + e1:(rpl rc rest) + rpl rc [] + | rc > 0 = + [] + | rc == 0, Just new_value <- maybe_header_value = + [(Autosorted (headerPriority header_name, header_name, 0), new_value)] + | otherwise = + [] + + at1 = rpl 0 lst + ms1 = Ms.fromList at1 + at2 = Ms.toList ms1 + at3 = rebase 0 at2 + in HeaderEditor . Ms.fromList $ at3 + + + -- | headerLens header_name represents a lens into the headers, --- and you can use it then to add, alter and remove headers. +-- and you can use it then to add, alter and() remove headers. -- It uses the same semantics than `replaceHeaderValue` headerLens :: B.ByteString -> L.Lens' HeaderEditor (Maybe B.ByteString) headerLens name = - L.lens - (Ms.lookup hname . innerMap ) - (\(HeaderEditor hs) mhv -> HeaderEditor $ Ms.alter (const mhv) hname hs) - where - hname = Autosorted name + let + -- + at1f he = Ms.toList . innerMap $ he + findthingy ( (Autosorted (_hp, hn, _n), hv):rest ) + | hn == name = Just hv + | otherwise = findthingy rest + findthingy [] = Nothing + -- + result = L.lens + (findthingy . at1f ) + (\he mhv -> replaceHeaderValue he name mhv) + in result + + -- | Replaces a \"host\" HTTP\/1.1 header by an ":authority" HTTP\/2 -- header. -- The list is expected to be already in lowercase, so nothing will happen if there @@ -172,7 +332,32 @@ Nothing -> headers Just host -> L.set authority_lens (Just host) no_hosts +-- | Combines ":authority" and "host", giving priority to the first. This is used when proxying +-- HTTP/2 to HTTP/1.1. It leaves whichever header of highest priority is present +combineAuthorityAndHost :: HeaderEditor -> HeaderEditor +combineAuthorityAndHost (HeaderEditor mp) = + let + ap1 = Ms.toList mp + go :: Int -> [(Autosorted, HeaderValue)] -> [(Autosorted, HeaderValue)] + go _ [] = [] + go n (a1@(Autosorted (_,hn,_) , _): rest) + | hn == ":authority" && n < 2 + = (a1: go 2 rest) + | hn == ":authority" && n >= 2 + = go n rest + | hn == "host" && n < 1 + = (a1: go 1 rest) + | hn == "host" && n >= 1 + = (go n rest) + | otherwise + = (a1 : go n rest) + + mp2 = Ms.fromList . go 0 $ ap1 + + in HeaderEditor mp2 + + -- | Given a header editor, introduces a "Date" header. This function has -- a side-effect: to get the current time introduceDateHeader :: HeaderEditor -> IO HeaderEditor @@ -184,3 +369,87 @@ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" current_time new_editor = L.set date_header_lens formatted_date header_editor return new_editor + + +-- | Remove connection-specific headers as required by HTTP/2 +removeConnectionHeaders :: Headers -> Headers +removeConnectionHeaders headers = + filter (\(h,_v) -> + (h /= "keep-alive") && + (h /= "proxy-connection") && + (h /= "transfer-encoding") && + (h /= "upgrade") + ) headers + + +-- | Fusion values for a specific header, using a provided separator. +fusionHeaders :: HeaderName -> B.ByteString -> Headers -> Headers +fusionHeaders header_name separator headers = + let + (before_first_cookie, after_first_cookie, all_cookie_values) = go False headers + new_cookie_header = + if length all_cookie_values > 0 then + LB.toStrict . Bu.toLazyByteString $ + (Bu.byteString . head $ all_cookie_values) + `mappend` (mconcat $ map (\ v -> + Bu.byteString separator `mappend` Bu.byteString v + ) + (tail all_cookie_values) + ) + else + "" + + go :: Bool -> Headers -> ( (Headers -> Headers), (Headers->Headers), [B.ByteString] ) + go _seen_first_cookie [] = + (id, id, []) + go False ((hh,hv):moreheaders) + | hh == header_name + = let + new_values = hv:morevalues + (before, after, morevalues) = go True moreheaders + in (before, after , new_values) + + | otherwise + = let + (retrans, otherheaders, morevalues) = go False moreheaders + newfun = \ x -> ( (hh, hv) : (retrans x)) + in (newfun, otherheaders, morevalues) + + go True ((hh, hv):moreheaders) + | hh == header_name + = let + new_values = hv:morevalues + (retrans, otherheaders, morevalues) = go True moreheaders + in (retrans, otherheaders , new_values) + + | otherwise + = let + (retrans, otherheaders, morevalues) = go True moreheaders + after = \ x -> ( (hh, hv) : (otherheaders x)) + in (retrans, after, morevalues) + result = before_first_cookie ( (header_name, new_cookie_header): after_first_cookie []) + in + result `deepseq` result + + + +data PrettyPrintHeadersConfig = PrettyPrintHeadersConfig { + _indentSpace_PPHC :: Int + } + +L.makeLenses ''PrettyPrintHeadersConfig + + +defaultPrettyPrintHeadersConfig :: PrettyPrintHeadersConfig +defaultPrettyPrintHeadersConfig = PrettyPrintHeadersConfig { + _indentSpace_PPHC = 8 + } + +prettyPrintHeaders :: PrettyPrintHeadersConfig -> Headers -> B.ByteString +prettyPrintHeaders config headers = + LB.toStrict . Bu.toLazyByteString . mconcat $ map (\ (h,v) -> + space `mappend` Bu.byteString h `mappend` ": " `mappend` Bu.byteString v `mappend` "\n" + ) + headers + where + space = Bu.byteString . pack . take (config ^. indentSpace_PPHC) . repeat $ ' ' diff --git a/macros/Logging.cpphs b/macros/Logging.cpphs deleted file mode 100644 --- a/macros/Logging.cpphs +++ /dev/null @@ -1,13 +0,0 @@ - - -#ifdef ENABLE_DEBUG - -#define INSTRUMENTATION(x) (liftIO $ logWithExclusivity (x)) -#define LOGIT_SWITCH_TIMINGS 1 - -#else - -#define INSTRUMENTATION(x) (return ()) -#define LOGIT_SWITCH_TIMINGS 0 - -#endif diff --git a/macros/instruments.cpphs b/macros/instruments.cpphs new file mode 100644 --- /dev/null +++ b/macros/instruments.cpphs @@ -0,0 +1,29 @@ + + +#ifdef ENABLE_DEBUG + +#define INSTRUMENTATION(x) (liftIO $ logWithExclusivity (x)) +#define LOGIT_SWITCH_TIMINGS 1 + +#else + +#define INSTRUMENTATION(x) (return ()) +#define LOGIT_SWITCH_TIMINGS 0 + +#endif + + +#ifdef SECONDTRANSFER_MONITORING + +import qualified SecondTransfer.MainLoop.DebugMonitor as DeMit + +#define REPORT_EVENT(evname) (DeMit.incCounter evname) +#define LIO_REPORT_EVENT(evname) (liftIO . DeMit.incCounter $ evname ) + +#else + +#define IMPORT_MONITORING +#define REPORT_EVENT(evname) +#define LIO_REPORT_EVENT(evname) + +#endif diff --git a/second-transfer.cabal b/second-transfer.cabal --- a/second-transfer.cabal +++ b/second-transfer.cabal @@ -1,13 +1,13 @@ name : second-transfer --- The package version. See the Haskell package versioning policy (PVP) +-- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version : 0.7.1.0 +version : 0.10.0.1 synopsis : Second Transfer HTTP/2 web server @@ -40,12 +40,24 @@ -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 -extra-source-files: macros/Logging.cpphs +extra-source-files: macros/instruments.cpphs Flag debug Description: Enable debug support Default: False +Flag fastc + Description: Enable fast use of c libraries + Default: False + +Flag misc-executables + Description: Compile helpers for development + Default: False + +Flag monitoring + Description: Enable build-time hacks used to inspect the live runtime state + Default: False + source-repository head type: git location: git@github.com:alcidesv/second-transfer.git @@ -53,7 +65,7 @@ source-repository this type: git location: git@github.com:alcidesv/second-transfer.git - tag: 0.7.1.0 + tag: 0.10.0.1 library @@ -65,48 +77,84 @@ , SecondTransfer.Types , SecondTransfer.Utils.HTTPHeaders , SecondTransfer.Utils.DevNull + + , SecondTransfer.TLS.CoreServer + , SecondTransfer.TLS.Types + + , SecondTransfer.Socks5.Types + , SecondTransfer.Socks5.Session + + , SecondTransfer.Sessions + , SecondTransfer.Sessions.Config + + , SecondTransfer.Http1.Parse + , SecondTransfer.Http1.Types + , SecondTransfer.Http1.Proxy + + -- These ones should probably go in their own package + , SecondTransfer.IOCallbacks.Types + , SecondTransfer.IOCallbacks.SocketServer + , SecondTransfer.IOCallbacks.WrapSocket + , SecondTransfer.IOCallbacks.Coupling + , SecondTransfer.IOCallbacks.SaveFragment + -- These are really internal modules, but are exposed -- here for the sake of the test suite. They are hidden -- from the documentation. , SecondTransfer.MainLoop.Internal - , SecondTransfer.Sessions - , SecondTransfer.Sessions.Config - , SecondTransfer.Http1.Parse + , SecondTransfer.MainLoop.Disruptible + , SecondTransfer.MainLoop.CoherentWorker - other-modules: SecondTransfer.MainLoop.CoherentWorker - , SecondTransfer.MainLoop.PushPullType - , SecondTransfer.MainLoop.Protocol - , SecondTransfer.MainLoop.Tokens - , SecondTransfer.MainLoop.Framer - , SecondTransfer.MainLoop.Logging - , SecondTransfer.MainLoop.ClientPetitioner + -- These are instrumentation utilities, they are mostly + -- disabled if the flag monitoring is off. + , SecondTransfer.MainLoop.Logging + , SecondTransfer.MainLoop.DebugMonitor - , SecondTransfer.Sessions.Internal - , SecondTransfer.MainLoop.OpenSSL_TLS - , SecondTransfer.Utils + -- TODO: Most of these should be moved back to "other-modules" + , SecondTransfer.TLS.Botan + , SecondTransfer.Sessions.Internal + , SecondTransfer.Sessions.Tidal + , SecondTransfer.Sessions.HashableSockAddr + , SecondTransfer.Http2.Session + , SecondTransfer.Http2.Framer + , SecondTransfer.MainLoop.ClientPetitioner - , SecondTransfer.Http2.Framer - , SecondTransfer.Http2.MakeAttendant - , SecondTransfer.Http2.Session - , SecondTransfer.Http2.SimpleClient - , SecondTransfer.Http1.Session + other-modules: SecondTransfer.MainLoop.Protocol + , SecondTransfer.MainLoop.Tokens + , SecondTransfer.MainLoop.Framer + , SecondTransfer.Utils + , SecondTransfer.ConstantsAndLimits + , SecondTransfer.Socks5.Serializers + , SecondTransfer.Socks5.Parsers + + , SecondTransfer.Http2.MakeAttendant + , SecondTransfer.Http2.SimpleClient + , SecondTransfer.Http2.TransferTypes + , SecondTransfer.Http2.OutputTray + , SecondTransfer.Http2.CalmState + + , SecondTransfer.Http1.Session + , SecondTransfer.IOCallbacks.Botcher + + + + if flag(monitoring) + CPP-Options: -DSECONDTRANSFER_MONITORING + build-tools: cpphs default-extensions: CPP - if flag(debug) - CPP-Options: -DENABLE_DEBUG - if !os(windows) - CC-Options: "-DDEBUG" - else - CC-Options: "-DNDEBUG" + if flag(fastc) + CPP-Options: -DINCLUDE_BOTAN_H + include-dirs: /usr/local/include/botan-1.11/ + else + CPP-Options: -DINCLUDE_BOTAN_ALL_H - if impl(ghc >= 7.10) - CPP-Options: -DIMPLICIT_MONOID -DIMPLICIT_APPLICATIVE_FOLDABLE -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -117,6 +165,7 @@ bytestring >= 0.10.4, base16-bytestring >= 0.1.1, network >= 2.6 && < 2.7, + network-uri >= 2.6, text >= 1.2 && < 1.3, binary >= 0.7.1.0, containers >= 0.5.5, @@ -126,16 +175,24 @@ hashtables >= 1.2 && < 1.3, lens >= 4.7 , http2 >= 1.0.2, - hslogger >= 1.2.6, hashable >= 1.2, attoparsec >= 0.12, - clock >= 0.4, - SafeSemaphore >= 0.10, + clock >= 0.6, + resourcet >= 1.1, + -- SafeSemaphore >= 0.10, + BoundedChan >= 1.0.3, pqueue >= 1.3.0, stm >= 2.3, deepseq >= 1.4.1, - time >= 1.5.0 && < 1.8 + time >= 1.5.0 && < 1.8, + vector >= 0.10, + vector-algorithms >= 0.7, + mmorph >= 1.0 + if flag(monitoring) + build-depends: hedis >= 0.6 + , unix >= 2.7 + -- Directories containing source files. hs-source-dirs: hs-src @@ -144,46 +201,58 @@ -- NOTE: Very specific directory with the version of openssl -- that I'm using. As of February 2015-- openssl 1.0.2 is not - -- commonly installed. Update this path in your build + -- commonly installed. Update this path in your build -- or otherwise your build will be broken. include-dirs: /opt/openssl-1.0.2/include + , /usr/local/include/botan-1.11 - c-sources: cbits/tlsinc.c if flag(debug) - cc-options: -O0 -g3 + cc-options: -O0 -g3 -std=c++11 ld-options: -g3 + else + -- -g3 temporarily set + cc-options: -g3 -std=c++11 -mavx2 -msse4.1 -msse2 -mpclmul -maes + if os(linux) + ghc-options: -pgmPcpphs "-pgmc g++" -optP--cpp + if os(darwin) + ghc-options: -pgmPcpphs "-pgmc g++-5" "-pgml g++-5" -optP--cpp - ghc-options: -pgmPcpphs -optP--cpp + -- v------ remove this + if os(linux) + if flag(fastc) + c-sources: cbits/enable_tls.cpp + else + c-sources: cbits/enable_tls.cpp - extra-libraries: ssl crypto - -- NOTE: Please fill-in with an-up-to date library path here. - -- It should point to openssl 1.0.2 or greater. See note for - -- include-dirs above. - extra-lib-dirs: /opt/openssl-1.0.2/lib + if os(darwin) + extra-libraries: second_transfer__enable_tls + extra-lib-dirs: /usr/local/shimmercat-build/ + ld-options: -framework Security + if os(linux) + extra-libraries: stdc++ + extra-lib-dirs: /usr/local + if flag(fastc) + if os(linux) + extra-libraries: botan-1.11 - include-dirs: macros/ -Test-Suite compiling-ok - type : exitcode-stdio-1.0 - main-is : compiling_ok.hs - hs-source-dirs : tests/tests-hs-src/ - default-language: Haskell2010 - build-depends : base >=4.7 && <= 4.9 - , second-transfer - , conduit >= 1.2.4 - ghc-options : -threaded - - + -- NOTE: Please fill-in with an-up-to date library path here. + -- It should point to openssl 1.0.2 or greater. See note for + -- include-dirs above. + include-dirs: macros/ +-- These are just some tests for the engine, there should +-- be more as an independent python test suite, checking +-- more stuff. Test-Suite hunit-tests type : exitcode-stdio-1.0 main-is : hunit_tests.hs - hs-source-dirs : tests/tests-hs-src, hs-src/ + hs-source-dirs : tests/tests-hs-src default-language : Haskell2010 build-depends : base >=4.7 && <= 4.9 ,conduit >= 1.2.4 @@ -191,56 +260,23 @@ ,HUnit >= 1.2 && < 1.5 ,bytestring >= 0.10.4.0 ,http2 - ,exceptions >= 0.8 && < 0.9 - ,base16-bytestring >= 0.1.1 ,network >= 2.6 && < 2.7 ,text >= 1.2 && < 1.3 ,binary >= 0.7.1.0 ,containers >= 0.5.5 - ,transformers >=0.3 && <= 0.5 ,network-uri >= 2.6 && < 2.7 ,hashtables >= 1.2 && < 1.3 ,unordered-containers - ,hslogger >= 1.2.6 - ,hashable >= 1.2 - ,attoparsec >= 0.12 - ,time >= 1.5.0 && < 1.8 - ,SafeSemaphore >= 0.10 - ,pqueue >= 1.3.0 - ,clock >= 0.4 - ,stm >= 2.3 - ,deepseq >= 1.4.1 + ,transformers >=0.3 && <= 0.5 + ,second-transfer + ,stm >= 2.4 + build-tools : cpphs default-extensions : CPP include-dirs : macros/ - CPP-Options : -DDISABLE_OPENSSL_TLS - ghc-options : -threaded -pgmPcpphs -optP--cpp + ghc-options : -threaded -pgmPcpphs "-pgmc gcc" -optP--cpp other-modules : SecondTransfer.Test.DecoySession - , SecondTransfer - , SecondTransfer.MainLoop - , SecondTransfer.Http2 - , SecondTransfer.Http1 - , SecondTransfer.Exception - , SecondTransfer.Types - , SecondTransfer.Utils.HTTPHeaders - , SecondTransfer.Utils.DevNull - , SecondTransfer.MainLoop.Internal - , SecondTransfer.Sessions - , SecondTransfer.Sessions.Config - , SecondTransfer.Http1.Parse - , SecondTransfer.MainLoop.CoherentWorker - , SecondTransfer.MainLoop.PushPullType - , SecondTransfer.MainLoop.Tokens - , SecondTransfer.MainLoop.Framer - , SecondTransfer.MainLoop.Logging - , SecondTransfer.MainLoop.Protocol - , SecondTransfer.Sessions.Internal - , SecondTransfer.MainLoop.ClientPetitioner - , SecondTransfer.Utils - , SecondTransfer.Http2.Framer - , SecondTransfer.Http2.MakeAttendant - , SecondTransfer.Http2.Session - , SecondTransfer.Http1.Session , Tests.HTTP1Parse , Tests.HTTP2Session + , Tests.TestIOCalbks , Tests.Utils diff --git a/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs b/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs --- a/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs +++ b/tests/tests-hs-src/SecondTransfer/Test/DecoySession.hs @@ -106,6 +106,8 @@ -- (Just $ setError mvar) defaultSessionsConfig +-- | Creates a IOCallbacks where "pullAction" reads from input_data_channel and where +-- "pushData" writes to output_data_channel. channelsToIOCallbacks :: TChan B.ByteString -> TChan B.ByteString -> TMVar DataContinuityEngine -> IOCallbacks channelsToIOCallbacks input_data_channel output_data_channel incoming_data_tmvar = let diff --git a/tests/tests-hs-src/Tests/HTTP1Parse.hs b/tests/tests-hs-src/Tests/HTTP1Parse.hs --- a/tests/tests-hs-src/Tests/HTTP1Parse.hs +++ b/tests/tests-hs-src/Tests/HTTP1Parse.hs @@ -1,27 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} module Tests.HTTP1Parse where +import Control.Lens +import Control.Concurrent hiding (yield) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Bu import Data.Maybe (isJust) +import Data.Conduit +import qualified Data.Conduit.List as DCL import Test.HUnit +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.IOCallbacks.Coupling + import SecondTransfer (Headers) import SecondTransfer.Http1.Parse +import SecondTransfer.Http1.Types +import SecondTransfer.Http1.Proxy +import qualified SecondTransfer.Utils.HTTPHeaders as He testParse :: Test testParse = TestCase $ do let - headers_text = "GET /helo.html HTTP/1.1\r\nHost: www.auther.com \r\n\r\n" - headers_text2 = "POST /helo.html HTTP/1.1\r\nHost: www.auther.com \r\nContent-Length: 1\r\n\r\np" - a0 = newIncrementalHttp1Parser - isDone (OnlyHeaders_H1PC _ _) = True - isDone _ = False - a1 = addBytes a0 headers_text - (OnlyHeaders_H1PC h0 leftovers)= a1 - (HeadersAndBody_H1PC h1 cond0 l2) = addBytes a0 headers_text2 + headers_text = "GET /helo.html HTTP/1.1\r\nHost: www.auther.com \r\n\r\n" + headers_text2 = "POST /helo.html HTTP/1.1\r\nHost: www.auther.com \r\nContent-Length: 1\r\n\r\np" + a0 = newIncrementalHttp1Parser + isDone (OnlyHeaders_H1PC _ _) = True + isDone _ = False + a1 = addBytes a0 headers_text + (OnlyHeaders_H1PC h0 leftovers) = a1 + (HeadersAndBody_H1PC h1 cond0 l2) = addBytes a0 headers_text2 waitForBodyOk (HeadersAndBody_H1PC _ _ _) = True waitForBodyOk _ = False assertBool "testParse.IsDone" (isDone a1) @@ -42,5 +54,112 @@ fragments = ["hello world"] serialized = serializeHTTPResponse headers_list fragments assertEqual "testGenerate.1" - "HTTP/1.1 200 OK\r\ncontent-length: 11\r\netag: afrh\r\nhost: www.example.com\r\n\r\nhello world" + "HTTP/1.1 200 OK\r\ncontent-length: 11\r\nhost: www.example.com\r\netag: afrh\r\n\r\nhello world" serialized + + +testCombineAuthorityAndHost :: Test +testCombineAuthorityAndHost = TestCase $ do + let + headers_list :: Headers + headers_list = [ + (":status", "200"), + ("host", "www.example.com"), + (":authority", "www.exampl.com"), + ("etag", "afrh") + ] + he1 = He.fromList headers_list + he2 = He.combineAuthorityAndHost he1 + h2 = He.toList he2 + fragments = ["hello world"] + serialized = serializeHTTPResponse h2 fragments + assertEqual "testGenerate.1" + "HTTP/1.1 200 OK\r\n:authority: www.exampl.com\r\n:status: 200\r\ncontent-length: 11\r\netag: afrh\r\n\r\nhello world" + serialized + + +testCombineAuthorityAndHost2 :: Test +testCombineAuthorityAndHost2 = TestCase $ do + let + headers_list :: Headers + headers_list = [ + (":status", "200"), + ("host", "www.example.com"), + ("etag", "afrh") + ] + he1 = He.fromList headers_list + he2 = He.combineAuthorityAndHost he1 + h2 = He.toList he2 + fragments = ["hello world"] + serialized = serializeHTTPResponse h2 fragments + assertEqual "testGenerate.1" + "HTTP/1.1 200 OK\r\ncontent-length: 11\r\nhost: www.example.com\r\netag: afrh\r\n\r\nhello world" + serialized + + +testHeadersToRequest :: Test +testHeadersToRequest = TestCase $ do + let + headers_list :: Headers + headers_list = [ + (":status", "200"), + ("host", "www.example.com"), + ("etag", "afrh") + ] + serialized = LB.toStrict . Bu.toLazyByteString $ headerListToHTTP1RequestText headers_list + assertEqual "testGenerate.1" + "GET * HTTP/1.1\r\nhost:www.example.com\r\netag:afrh\r\n" + serialized + + +testHeadersToRequest2 :: Test +testHeadersToRequest2 = TestCase $ do + let + headers_list :: Headers + headers_list = [ + (":status", "200"), + (":authority", "www.example.com"), + (":path", "/important"), + (":method", "HEAD"), + ("etag", "afrh") + ] + serialized = LB.toStrict . Bu.toLazyByteString $ headerListToHTTP1RequestText headers_list + assertEqual "testGenerate.1" + "HEAD /important HTTP/1.1\r\nhost:www.example.com\r\netag:afrh\r\n" + serialized + + +testCycle :: Test +testCycle = TestCase $ do + let + headers_list :: Headers + headers_list = [ + (":authority", "www.example.com"), + (":path", "/interesting"), + (":method", "POST"), + ("etag", "afrh") + ] + rqsource = yield "Hello world" + request = HttpRequest { + _headers_Rq = headers_list + , _body_Rq = rqsource + } + (ioap, iobp) <- popIOCallbacksIntoExistance + ioa <- handshake ioap + iob <- handshake iobp + + let + controller = IOCallbacksConn ioa + + finished <- newEmptyMVar + forkIO $ do + request_text <- (iob ^. pullAction_IOC) 74 + --putStrLn . show $ request_text + assertEqual "test.Request" "POST /interesting HTTP/1.1\r\nhost:www.example.com\r\netag:afrh\r\n\r\nHello world" request_text + (iob ^. pushAction_IOC) "HTTP/1.1 200 OK\r\ncontent-length: 11\r\nhost: www.example.com\r\netag: afrh\r\n\r\nhello world" + putMVar finished () + + (response, _) <- ioProxyToConnection controller request + assertEqual "test.Response" (response ^. headers_Rp ) [(":status","200"),("content-length","11"),("host","www.example.com"),("etag","afrh")] + contents <- (response ^. body_Rp) $$ DCL.consume + assertEqual "test.rp1Txt" "hello world" (mconcat contents) diff --git a/tests/tests-hs-src/Tests/HTTP2Session.hs b/tests/tests-hs-src/Tests/HTTP2Session.hs --- a/tests/tests-hs-src/Tests/HTTP2Session.hs +++ b/tests/tests-hs-src/Tests/HTTP2Session.hs @@ -4,27 +4,27 @@ import Data.Typeable -import Control.Concurrent (threadDelay) -import qualified Control.Concurrent as C (yield) +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent as C(yield) import Control.Concurrent.MVar import Control.Exception import Control.Lens -import qualified Control.Lens as L -import Control.Monad.IO.Class (liftIO) -import qualified Network.HTTP2 as NH2 +import qualified Control.Lens as L +import Control.Monad.IO.Class (liftIO) +import qualified Network.HTTP2 as NH2 import Test.HUnit import SecondTransfer.Exception -import SecondTransfer.Http2 (http2Attendant) +import SecondTransfer.Http2 (http2Attendant) import SecondTransfer.Sessions import SecondTransfer.Test.DecoySession import SecondTransfer.Types -import SecondTransfer.Utils.HTTPHeaders (fetchHeader) -import SecondTransfer.MainLoop.CoherentWorker (defaultEffects) +import SecondTransfer.Utils.HTTPHeaders (fetchHeader) +import SecondTransfer.MainLoop.CoherentWorker (defaultEffects) import SecondTransfer.MainLoop.ClientPetitioner -import Data.Conduit (yield) +import Data.Conduit (yield) @@ -92,7 +92,7 @@ [], -- No pushed streams do yield "Error coming down" - liftIO $ throwIO Internal500Exception + _ <- liftIO $ throwIO Internal500Exception return [] ) @@ -348,16 +348,16 @@ seen3 <- frameIsGoAwayBecauseInternalError decoy_session seen2 f2 f3 <- recvFrameFromSession decoy_session - seen4 <- frameIsGoAwayBecauseInternalError decoy_session seen3 f3 + seen4 <- frameIsResetBecauseInternalError decoy_session seen3 f3 if not seen4 then do - assertFailure "Didn't see GoAwayFrame" + assertFailure "Didn't see RSTFrame for faulty stream" else return () frameIsGoAwayBecauseInternalError :: DecoySession -> Bool -> Maybe NH2.Frame -> IO Bool -frameIsGoAwayBecauseInternalError decoy_session prev maybe_frame = do +frameIsGoAwayBecauseInternalError _decoy_session prev maybe_frame = do case prev of True -> return True False -> @@ -372,7 +372,7 @@ frameIsGoAwayBecauseProtocolError :: DecoySession -> Bool -> Maybe NH2.Frame -> IO Bool -frameIsGoAwayBecauseProtocolError decoy_session prev maybe_frame = do +frameIsGoAwayBecauseProtocolError _decoy_session prev maybe_frame = do case prev of True -> return True False -> @@ -380,6 +380,20 @@ Just (NH2.Frame _ (NH2.GoAwayFrame _ ec _) ) -> do case ec of NH2.ProtocolError -> return True + _ -> return False + + _ -> + return False + +frameIsResetBecauseInternalError :: DecoySession -> Bool -> Maybe NH2.Frame -> IO Bool +frameIsResetBecauseInternalError _decoy_session prev maybe_frame = do + case prev of + True -> return True + False -> + case maybe_frame of + Just (NH2.Frame _ (NH2.RSTStreamFrame ec) ) -> do + case ec of + NH2.InternalError -> return True _ -> return False _ -> diff --git a/tests/tests-hs-src/Tests/TestIOCalbks.hs b/tests/tests-hs-src/Tests/TestIOCalbks.hs new file mode 100644 --- /dev/null +++ b/tests/tests-hs-src/Tests/TestIOCalbks.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.TestIOCalbks where + +import Control.Lens + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Bu +import Data.Maybe (isJust) + +import Test.HUnit + +import SecondTransfer.IOCallbacks.Types +import SecondTransfer.IOCallbacks.Coupling + +import SecondTransfer (Headers) +import SecondTransfer.Http1.Parse +import qualified SecondTransfer.Utils.HTTPHeaders as He + + +testPair :: Test +testPair = TestCase $ do + (ioap, iobp) <- popIOCallbacksIntoExistance + ioa <- handshake ioap + iob <- handshake iobp + (ioa ^. pushAction_IOC) "Hello world" + n <- (iob ^. pullAction_IOC) $ B.length "Hello world" + assertEqual "testTransitsInPair" n "Hello world" + + +testPair2 :: Test +testPair2 = TestCase $ do + (ioap, iobp) <- popIOCallbacksIntoExistance + ioa <- handshake ioap + iob <- handshake iobp + (ioa ^. pushAction_IOC) "Hello world" + n <- (iob ^. pullAction_IOC) $ B.length "Hello world" - 1 + assertEqual "testTransitsInPair" n "Hello worl" + (ioa ^. pushAction_IOC) "xebo" + + nn <- (iob ^. pullAction_IOC) $ B.length "dxebo" + assertEqual "testTransitsInPair2" nn "dxebo" + + +testPair3 :: Test +testPair3 = TestCase $ do + (ioap, iobp) <- popIOCallbacksIntoExistance + ioa <- handshake ioap + iob <- handshake iobp + (ioa ^. pushAction_IOC) "Hello world" + n <- (iob ^. pullAction_IOC) $ B.length "Hello world" - 1 + assertEqual "testTransitsInPair" n "Hello worl" + nn <- (iob ^. bestEffortPullAction_IOC) False + assertBool "testTransitsInPair2" (B.length nn > 0) diff --git a/tests/tests-hs-src/compiling_ok.hs b/tests/tests-hs-src/compiling_ok.hs deleted file mode 100644 --- a/tests/tests-hs-src/compiling_ok.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import SecondTransfer( - AwareWorker - , Footers - , DataAndConclusion - , tlsServeWithALPNAndFinishOnRequest - , http2Attendant - , http11Attendant - , dropIncomingData - , coherentToAwareWorker - , FinishRequest(..) - ) -import SecondTransfer.Sessions( - makeSessionsContext - , defaultSessionsConfig - ) - -import Data.Conduit -import Control.Concurrent (threadDelay, forkIO) -import Control.Concurrent.MVar - -saysHello :: DataAndConclusion -saysHello = do - yield "Hello world!" - -- No footers - return [] - - -helloWorldWorker :: AwareWorker -helloWorldWorker = coherentToAwareWorker $ \ (_request_headers, _maybe_post_data) -> do - dropIncomingData _maybe_post_data - return ( - [ - (":status", "200") - ], - [], -- No pushed streams - saysHello - ) - - --- For this program to work, it should be run from the top of --- the developement directory. -main = do - sessions_context <- makeSessionsContext defaultSessionsConfig - finish <- newEmptyMVar - -- Make the server work only for small amount of time, so that - -- continue running other tests - forkIO $ do - threadDelay 1000000 - putMVar finish FinishRequest - let - http2_attendant = http2Attendant sessions_context helloWorldWorker - http11_attendant = http11Attendant sessions_context helloWorldWorker - tlsServeWithALPNAndFinishOnRequest - "tests/support/servercert.pem" -- Server certificate - "tests/support/privkey.pem" -- Certificate private key - "127.0.0.1" -- On which interface to bind - [ - ("h2-14", http2_attendant), -- Protocols present in the ALPN negotiation - ("h2", http2_attendant), -- they may be slightly different, but for this - -- test it doesn't matter. - ("http/1.1", http11_attendant) - ] - 8000 - finish diff --git a/tests/tests-hs-src/hunit_tests.hs b/tests/tests-hs-src/hunit_tests.hs --- a/tests/tests-hs-src/hunit_tests.hs +++ b/tests/tests-hs-src/hunit_tests.hs @@ -11,6 +11,7 @@ import Tests.HTTP2Session import Tests.Utils import Tests.HTTP1Parse +import Tests.TestIOCalbks tests = TestList [ @@ -32,6 +33,16 @@ ,TestLabel "testClosedInteraction3" testClosedInteraction3 ,TestLabel "testWorkerClosesAfter" testWorkerClosesAfter ,TestLabel "testWorkerClosesBefore" testWorkerClosesBefore + ,TestLabel "testCombineAuthorityAndHost" testCombineAuthorityAndHost + ,TestLabel "testCombineAuthorityAndHost2" testCombineAuthorityAndHost2 + ,TestLabel "testHeadersToRequest" testHeadersToRequest + ,TestLabel "testHeadersToRequest2" testHeadersToRequest2 + + ,TestLabel "testPair" testPair + ,TestLabel "testPair2" testPair2 + ,TestLabel "testPair3" testPair3 + + ,TestLabel "http1Cycle" testCycle ]