diff --git a/dist/build/blockingStub/blockingStub-tmp/blockingStub.hs b/dist/build/blockingStub/blockingStub-tmp/blockingStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/blockingStub/blockingStub-tmp/blockingStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import Blocking ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/lazynessStub/lazynessStub-tmp/lazynessStub.hs b/dist/build/lazynessStub/lazynessStub-tmp/lazynessStub.hs deleted file mode 100644 --- a/dist/build/lazynessStub/lazynessStub-tmp/lazynessStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import Lazyness ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/targetsStub/targetsStub-tmp/targetsStub.hs b/dist/build/targetsStub/targetsStub-tmp/targetsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/targetsStub/targetsStub-tmp/targetsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import Targets ( tests ) +main :: IO () +main = stubMain tests diff --git a/src/System/IO/Uniform/Targets.hs b/src/System/IO/Uniform/Targets.hs --- a/src/System/IO/Uniform/Targets.hs +++ b/src/System/IO/Uniform/Targets.hs @@ -2,8 +2,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE EmptyDataDecls #-} -module System.IO.Uniform.Targets (TlsSettings(..), UniformIO(..), SocketIO, FileIO, TlsStream, BoundedPort, SomeIO(..), connectTo, connectToHost, bindPort, accept, openFile, getPeer, closePort) where +module System.IO.Uniform.Targets (TlsSettings(..), UniformIO(..), SocketIO, FileIO, StdIO, TlsStream, BoundedPort, SomeIO(..), connectTo, connectToHost, bindPort, accept, openFile, getPeer, closePort) where import Foreign import Foreign.C.Types @@ -14,16 +15,19 @@ import qualified Data.ByteString as BS import qualified Data.List as L import Control.Exception +import Control.Applicative ((<$>)) import qualified Network.Socket as Soc import System.IO.Error import Data.Default.Class +import System.Posix.Types (Fd(..)) + -- | Settings for starttls functions. -data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String} deriving (Read, Show) +data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String, tlsDHParametersFile :: String} deriving (Read, Show) instance Default TlsSettings where - def = TlsSettings "" "" + def = TlsSettings "" "" "" -- | -- Typeclass for uniform IO targets. @@ -65,58 +69,90 @@ data Nethandler -- | A bounded IP port from where to accept SocketIO connections. newtype BoundedPort = BoundedPort {lis :: (Ptr Nethandler)} -data SockDs -newtype SocketIO = SocketIO {sock :: (Ptr SockDs)} -data FileDs -newtype FileIO = FileIO {fd :: (Ptr FileDs)} +data Ds +newtype SocketIO = SocketIO {sock :: (Ptr Ds)} +newtype FileIO = FileIO {fd :: (Ptr Ds)} data TlsDs newtype TlsStream = TlsStream {tls :: (Ptr TlsDs)} +data StdIO -- | UniformIO IP connections. instance UniformIO SocketIO where - uRead s n = allocaArray n ( - \b -> do - count <- c_recvSock (sock s) b (fromIntegral n) - if count < 0 - then throwErrno "could not read" - else BS.packCStringLen (b, fromIntegral count) - ) - uPut s t = BS.useAsCStringLen t ( - \(str, n) -> do - count <- c_sendSock (sock s) str $ fromIntegral n - if count < 0 - then throwErrno "could not write" - else return () - ) - uClose s = c_closeSock (sock s) + uRead s n = do + allocaArray n ( + \b -> do + count <- c_recv (sock s) b (fromIntegral n) + if count < 0 + then throwErrno "could not read" + else BS.packCStringLen (b, fromIntegral count) + ) + uPut s t = do + BS.useAsCStringLen t ( + \(str, n) -> do + count <- c_send (sock s) str $ fromIntegral n + if count < 0 + then throwErrno "could not write" + else return () + ) + uClose s = do + f <- Fd <$> c_prepareToClose (sock s) + closeFd f startTls st s = withCString (tlsCertificateChainFile st) ( \cert -> withCString (tlsPrivateKeyFile st) ( - \key -> do - r <- c_startSockTls (sock s) cert key - if r == nullPtr - then throwErrno "could not start TLS" - else return . TlsStream $ r + \key -> withCString (tlsDHParametersFile st) ( + \para -> do + r <- c_startSockTls (sock s) cert key para + if r == nullPtr + then throwErrno "could not start TLS" + else return . TlsStream $ r + ) ) ) isSecure _ = False +-- | UniformIO IP connections. +instance UniformIO StdIO where + uRead _ n = do + allocaArray n ( + \b -> do + count <- c_recvStd b (fromIntegral n) + if count < 0 + then throwErrno "could not read" + else BS.packCStringLen (b, fromIntegral count) + ) + uPut _ t = do + BS.useAsCStringLen t ( + \(str, n) -> do + count <- c_sendStd str $ fromIntegral n + if count < 0 + then throwErrno "could not write" + else return () + ) + uClose _ = return () + startTls _ _ = return . TlsStream $ nullPtr + isSecure _ = False + -- | UniformIO type for file IO. instance UniformIO FileIO where - uRead s n = allocaArray n ( - \b -> do - count <- c_recvFile (fd s) b $ fromIntegral n - if count < 0 - then throwErrno "could not read" - else BS.packCStringLen (b, fromIntegral count) - ) - uPut s t = BS.useAsCStringLen t ( - \(str, n) -> do - count <- c_sendFile (fd s) str $ fromIntegral n - if count < 0 - then throwErrno "could not write" - else return () - ) - uClose s = c_closeFile (fd s) + uRead s n = do + allocaArray n ( + \b -> do + count <- c_recv (fd s) b $ fromIntegral n + if count < 0 + then throwErrno "could not read" + else BS.packCStringLen (b, fromIntegral count) + ) + uPut s t = do + BS.useAsCStringLen t ( + \(str, n) -> do + count <- c_send (fd s) str $ fromIntegral n + if count < 0 + then throwErrno "could not write" + else return () + ) + uClose s = do + f <- Fd <$> c_prepareToClose (fd s) + closeFd f -- Not implemented yet. startTls _ _ = return . TlsStream $ nullPtr isSecure _ = False @@ -124,21 +160,26 @@ -- | UniformIO wrapper that applies TLS to communication on IO target. -- This type is constructed by calling startTls on other targets. instance UniformIO TlsStream where - uRead s n = allocaArray n ( - \b -> do - count <- c_recvTls (tls s) b $ fromIntegral n - if count < 0 - then throwErrno "could not read" - else BS.packCStringLen (b, fromIntegral count) - ) - uPut s t = BS.useAsCStringLen t ( - \(str, n) -> do - count <- c_sendTls (tls s) str $ fromIntegral n - if count < 0 - then throwErrno "could not write" - else return () - ) - uClose s = c_closeTls (tls s) + uRead s n = do + allocaArray n ( + \b -> do + count <- c_recvTls (tls s) b $ fromIntegral n + if count < 0 + then throwErrno "could not read" + else BS.packCStringLen (b, fromIntegral count) + ) + uPut s t = do + BS.useAsCStringLen t ( + \(str, n) -> do + count <- c_sendTls (tls s) str $ fromIntegral n + if count < 0 + then throwErrno "could not write" + else return () + ) + uClose s = do + d <- c_closeTls (tls s) + f <- Fd <$> c_prepareToClose d + closeFd f startTls _ s = return s isSecure _ = True @@ -242,28 +283,34 @@ ) ) +closeFd :: Fd -> IO () +closeFd (Fd f) = c_closeFd f + -- | Closes a BoundedPort, and releases any resource used by it. closePort :: BoundedPort -> IO () closePort p = c_closePort (lis p) -foreign import ccall safe "getPort" c_getPort :: CInt -> IO (Ptr Nethandler) -foreign import ccall safe "createFromHandler" c_accept :: Ptr Nethandler -> IO (Ptr SockDs) -foreign import ccall safe "createFromFileName" c_createFile :: CString -> IO (Ptr FileDs) -foreign import ccall safe "createToIPv4Host" c_connect4 :: CUInt -> CInt -> IO (Ptr SockDs) -foreign import ccall safe "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr SockDs) +foreign import ccall interruptible "getPort" c_getPort :: CInt -> IO (Ptr Nethandler) +foreign import ccall interruptible "createFromHandler" c_accept :: Ptr Nethandler -> IO (Ptr Ds) +foreign import ccall safe "createFromFileName" c_createFile :: CString -> IO (Ptr Ds) +foreign import ccall interruptible "createToIPv4Host" c_connect4 :: CUInt -> CInt -> IO (Ptr Ds) +foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr Ds) -foreign import ccall safe "startSockTls" c_startSockTls :: Ptr SockDs -> CString -> CString -> IO (Ptr TlsDs) -foreign import ccall safe "getPeer" c_getPeer :: Ptr SockDs -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO (CInt) +foreign import ccall interruptible "startSockTls" c_startSockTls :: Ptr Ds -> CString -> CString -> CString -> IO (Ptr TlsDs) +foreign import ccall safe "getPeer" c_getPeer :: Ptr Ds -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO (CInt) -foreign import ccall safe "closeSockDs" c_closeSock :: Ptr SockDs -> IO () -foreign import ccall safe "closeFileDs" c_closeFile :: Ptr FileDs -> IO () +--foreign import ccall safe "getFd" c_getFd :: Ptr Ds -> IO CInt +--foreign import ccall safe "getTlsFd" c_getTlsFd :: Ptr TlsDs -> IO CInt +foreign import ccall safe "closeFd" c_closeFd :: CInt -> IO () + +foreign import ccall safe "prepareToClose" c_prepareToClose :: Ptr Ds -> IO CInt foreign import ccall safe "closeHandler" c_closePort :: Ptr Nethandler -> IO () -foreign import ccall safe "closeTlsDs" c_closeTls :: Ptr TlsDs -> IO () +foreign import ccall safe "closeTls" c_closeTls :: Ptr TlsDs -> IO (Ptr Ds) -foreign import ccall interruptible "fileDsSend" c_sendFile :: Ptr FileDs -> Ptr CChar -> CInt -> IO CInt -foreign import ccall interruptible "sockDsSend" c_sendSock :: Ptr SockDs -> Ptr CChar -> CInt -> IO CInt +foreign import ccall interruptible "sendDs" c_send :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt +foreign import ccall interruptible "stdDsSend" c_sendStd :: Ptr CChar -> CInt -> IO CInt foreign import ccall interruptible "tlsDsSend" c_sendTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt -foreign import ccall interruptible "fileDsRecv" c_recvFile :: Ptr FileDs -> Ptr CChar -> CInt -> IO CInt -foreign import ccall interruptible "sockDsRecv" c_recvSock :: Ptr SockDs -> Ptr CChar -> CInt -> IO CInt +foreign import ccall interruptible "recvDs" c_recv :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt +foreign import ccall interruptible "stdDsRecv" c_recvStd :: Ptr CChar -> CInt -> IO CInt foreign import ccall interruptible "tlsDsRecv" c_recvTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt diff --git a/src/System/IO/Uniform/ds.c b/src/System/IO/Uniform/ds.c --- a/src/System/IO/Uniform/ds.c +++ b/src/System/IO/Uniform/ds.c @@ -11,10 +11,14 @@ #include #include #include +#include #include "ds.h" int openSslLoaded = 0; +char *availableCiphers = "EDH+CAMELLIA:EDH+aRSA:EECDH+aRSA+AESGCM:EECDH+aRSA+SHA256:EECDH:" + "+CAMELLIA128:+AES128:+SSLv3:!aNULL:!eNULL:!LOW:!3DES:!MD5:!EXP:!PSK:!DSS:!RC4:!SEED:" + "!IDEA:!ECDSA:kEDH:CAMELLIA128-SHA:AES128-SHA"; void *clear(void *ptr){ int e = errno; @@ -25,15 +29,21 @@ return NULL; } -void loadOpenSSL(){ +pthread_mutex_t loadLock; + +void loadOpenSSL(const char *dh){ + if(openSslLoaded) + return; + pthread_mutex_lock(&loadLock); if(!openSslLoaded){ - openSslLoaded = 1; SSL_load_error_strings(); ERR_load_BIO_strings(); ERR_load_crypto_strings(); SSL_library_init(); - OpenSSL_add_all_algorithms(); + OpenSSL_add_all_algorithms(); + openSslLoaded = 1; } + pthread_mutex_unlock(&loadLock); } void copy6addr(unsigned char d[16], const unsigned char s[16]){ @@ -52,29 +62,29 @@ nethandler h = (nethandler)malloc(sizeof(s_nethandler)); h->ipv6 = ipv6; if(ipv6){ - h->s = socket(AF_INET6, SOCK_STREAM, 0); + h->fd = socket(AF_INET6, SOCK_STREAM, 0); }else{ - h->s = socket(AF_INET, SOCK_STREAM, 0); + h->fd = socket(AF_INET, SOCK_STREAM, 0); } int optval = 1; - setsockopt(h->s, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof(optval)); + setsockopt(h->fd, SOL_SOCKET, SO_REUSEADDR, &optval, sizeof(optval)); int e, en; if(ipv6){ struct sockaddr_in6 add; add.sin6_family = AF_INET6; zero6addr(add.sin6_addr.s6_addr); add.sin6_port = htons(port); - e = bind(h->s, (struct sockaddr*) &add, sizeof(add)); + e = bind(h->fd, (struct sockaddr*) &add, sizeof(add)); }else{ struct sockaddr_in add; add.sin_family = AF_INET; add.sin_addr.s_addr = INADDR_ANY; add.sin_port = htons(port); - e = bind(h->s, (struct sockaddr*) &add, sizeof(add)); + e = bind(h->fd, (struct sockaddr*) &add, sizeof(add)); } if(e) return clear(h); - e = listen(h->s, DEFAULT_LISTENNING_QUEUE); + e = listen(h->fd, DEFAULT_LISTENNING_QUEUE); if(e) return clear(h); return h; @@ -88,39 +98,42 @@ return getNethandler(1, port); } -fileDs createFromFile(int f){ - fileDs d = (fileDs)malloc(sizeof(s_fileDs)); - d->f = f; +ds createFromFile(int f){ + ds d = (ds)malloc(sizeof(s_ds)); + d->tp = file; + d->fd = f; return d; } -fileDs createFromFileName(const char *f){ - int fd = open(f, O_CREAT | O_RDWR); +ds createFromFileName(const char *f){ + int fd = open(f, O_CREAT | O_RDWR, 0666); if(fd == -1){ return NULL; } return createFromFile(fd); } -sockDs createFromHandler(nethandler h){ - sockDs d = (sockDs)malloc(sizeof(s_sockDs)); +ds createFromHandler(nethandler h){ + ds d = (ds)malloc(sizeof(s_ds)); + d->tp = sock; unsigned int s = sizeof(d->peer); - d->s = accept(h->s, (struct sockaddr*)&(d->peer), &s); - if(d->s <= 0) + d->fd = accept(h->fd, (struct sockaddr*)&(d->peer), &s); + if(d->fd <= 0) return clear(d); d->ipv6 = d->peer.ss_family == AF_INET6; d->server = 1; return d; } -sockDs createToHost(struct sockaddr *add, const int add_size, const int ipv6){ - sockDs d = (sockDs)malloc(sizeof(s_sockDs)); +ds createToHost(struct sockaddr *add, const int add_size, const int ipv6){ + ds d = (ds)malloc(sizeof(s_ds)); + d->tp = sock; if(ipv6){ - d->s = socket(AF_INET6, SOCK_STREAM, 0); + d->fd = socket(AF_INET6, SOCK_STREAM, 0); }else{ - d->s = socket(AF_INET, SOCK_STREAM, 0); + d->fd = socket(AF_INET, SOCK_STREAM, 0); } - if(connect(d->s, add, add_size) < 0){ + if(connect(d->fd, add, add_size) < 0){ int e = errno; free(d); errno = e; @@ -130,7 +143,7 @@ return d; } -sockDs createToIPv4Host(const unsigned long host, const int port){ +ds createToIPv4Host(const unsigned long host, const int port){ struct sockaddr_in add; add.sin_family = AF_INET; add.sin_port = htons(port); @@ -138,7 +151,7 @@ return createToHost((struct sockaddr*) &add, sizeof(add), 0); } -sockDs createToIPv6Host(const unsigned char host[16], const int port){ +ds createToIPv6Host(const unsigned char host[16], const int port){ struct sockaddr_in6 add; add.sin6_family = AF_INET6; add.sin6_port = htons(port); @@ -148,11 +161,11 @@ return createToHost((struct sockaddr*) &add, sizeof(add), 1); } -int getPeer(sockDs d, unsigned long *ipv4peer, unsigned char ipv6peer[16], int *ipv6){ +int getPeer(ds d, unsigned long *ipv4peer, unsigned char ipv6peer[16], int *ipv6){ int port = 0; struct sockaddr_storage peer; int peer_size = sizeof(peer); - if(getpeername(d->s, (struct sockaddr*)&peer, &peer_size)){ + if(getpeername(d->fd, (struct sockaddr*)&peer, &peer_size)){ return 0; } if(peer.ss_family == AF_INET){ @@ -171,11 +184,8 @@ return port; } -int fileDsSend(fileDs d, const char *b, const int s){ - return write(d->f, b, s); -} -int sockDsSend(sockDs d, const char *b, const int s){ - return write(d->s, b, s); +int sendDs(ds d, const char *b, const int s){ + return write(d->fd, b, s); } int tlsDsSend(tlsDs d, const char *b, const int s){ return SSL_write(d->s, b, s); @@ -184,11 +194,8 @@ return write(1, b, s); } -int fileDsRecv(fileDs d, char *b, const int s){ - return read(d->f, b, s); -} -int sockDsRecv(sockDs d, char *b, const int s){ - return read(d->s, b, s); +int recvDs(ds d, char *b, const int s){ + return read(d->fd, b, s); } int tlsDsRecv(tlsDs d, char *b, const int s){ return SSL_read(d->s, b, s); @@ -198,88 +205,114 @@ } -void closeFileDs(fileDs d){ - close(d->f); - free(d); -} -void closeSockDs(sockDs d){ - close(d->s); +int prepareToClose(ds d){ + int fd = d->fd; free(d); + return fd; } -void closeTlsDs(tlsDs d){ - SSL_shutdown(d->s); +ds closeTls(tlsDs d){ + ds original = d->original; SSL_shutdown(d->s); + //No bidirectional shutdown supported + //SSL_shutdown(d->s); SSL_free(d->s); - switch(d->tp){ - case file: - closeFileDs(d->original); - break; - case sock: - closeSockDs(d->original); - break; - } free(d); + return original; } void closeHandler(nethandler h){ - close(h->s); + close(h->fd); free(h); } -tlsDs startSockTls(sockDs d, const char *cert, const char *key){ - loadOpenSSL(); +tlsDs startSockTls(ds d, const char *cert, const char *key, const char *dh){ + loadOpenSSL(dh); SSL_CTX * ctx = NULL; if(d->server) - ctx = SSL_CTX_new(TLSv1_server_method()); + ctx = SSL_CTX_new(TLSv1_1_server_method()); else - ctx = SSL_CTX_new(TLSv1_client_method()); + ctx = SSL_CTX_new(TLSv1_1_client_method()); if(!ctx) return NULL; + if(d->server){ + FILE *dhfile = fopen(dh, "r"); + DH *dhdt = PEM_read_DHparams(dhfile, NULL, NULL, NULL); + fclose(dhfile); + if(SSL_CTX_set_tmp_dh(ctx, dhdt) <= 0){ + int f = prepareToClose(d); + closeFd(f); + clear(dhdt); + return clear(ctx); + } + } SSL_CTX_set_options(ctx, SSL_OP_SINGLE_DH_USE); if(cert) if(SSL_CTX_use_certificate_chain_file(ctx, cert) != 1){ - closeSockDs(d); + int f = prepareToClose(d); + closeFd(f); return clear(ctx); } if(key) if(SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) != 1){ - closeSockDs(d); + int f = prepareToClose(d); + closeFd(f); return clear(ctx); } + if(SSL_CTX_set_cipher_list(ctx, availableCiphers) <= 0){ + int f = prepareToClose(d); + closeFd(f); + return clear(ctx); + } tlsDs t = (tlsDs)malloc(sizeof(s_tlsDs)); t->original = d; if(!(t->s = SSL_new(ctx))){ - closeSockDs(d); + int f = prepareToClose(d); + closeFd(f); clear(ctx); return clear(t); } - if(!SSL_set_fd(t->s, d->s)){ - closeTlsDs(t); + if(!SSL_set_fd(t->s, d->fd)){ + closeTls(t); return NULL; } - printf("Starting handshake\n"); int retry = 1; int e; while(retry){ retry = 0; - if(d->server) + if(d->server){ + SSL_set_accept_state(t->s); e = SSL_accept(t->s); - else + }else{ + SSL_set_connect_state(t->s); e = SSL_connect(t->s); + } if(e <= 0){ - retry = 1; - int erval = SSL_get_error(t->s, e); + unsigned long erval = SSL_get_error(t->s, e); + //char ertxt[300]; + //ERR_error_string(erval, ertxt); + //fprintf(stderr, "SSL Error: %s\n", ertxt); if((erval == SSL_ERROR_WANT_READ) || (erval == SSL_ERROR_WANT_WRITE)){ - + //Here goes support to non-blocking IO, once it's supported + //retry = 1; }else{ - printf("Error\n"); - ERR_print_errors(t->s->bbio); - closeTlsDs(t); + closeTls(t); return NULL; } } } - printf("Success\n"); return t; +} + +int getFd(ds d){ + return d->fd; +} + +int getTlsFd(tlsDs t){ + ds d = t->original; + return d->fd; +} + +void closeFd(int fd){ + close(fd); } diff --git a/src/System/IO/Uniform/ds.h b/src/System/IO/Uniform/ds.h --- a/src/System/IO/Uniform/ds.h +++ b/src/System/IO/Uniform/ds.h @@ -2,28 +2,25 @@ #include #include +typedef enum { + file, std, sock +} dstype; + typedef struct { - int s; + int fd; + dstype tp; int ipv6; int server; struct sockaddr_storage peer; -} *sockDs, s_sockDs; - -typedef struct { - int f; -} *fileDs, s_fileDs; +} *ds, s_ds; #define DEFAULT_LISTENNING_QUEUE 5 typedef struct{ - int s; + int fd; int ipv6; } *nethandler, s_nethandler; -typedef enum { - file, sock -} dstype; - typedef struct { dstype tp; void *original; @@ -33,26 +30,22 @@ nethandler getIPv4Port(const int port); nethandler getPort(const int port); -fileDs createFromFile(int); -fileDs createFromFileName(const char*); -sockDs createFromHandler(nethandler); -sockDs createToIPv4Host(const unsigned long, const int); -sockDs createToIPv6Host(const unsigned char[16], const int); +ds createFromFile(int); +ds createFromFileName(const char*); +ds createFromHandler(nethandler); +ds createToIPv4Host(const unsigned long, const int); +ds createToIPv6Host(const unsigned char[16], const int); -tlsDs startSockTls(sockDs, const char*, const char*); +tlsDs startSockTls(ds, const char*, const char*, const char*); -int getPeer(sockDs, unsigned long*, unsigned char[16], int*); +int getPeer(ds, unsigned long*, unsigned char[16], int*); -void closeSockDs(sockDs); -void closeFileDs(fileDs); +int closeDs(ds); void closeHandler(nethandler); -void closeTlsDs(tlsDs); - -int fileDsSend(fileDs, const char[const], const int); -int fileDsRecv(fileDs, char[], const int); +ds closeTls(tlsDs); -int sockDsSend(sockDs, const char[const], const int); -int sockDsRecv(sockDs, char[], const int); +int sendDs(ds, const char[const], const int); +int recvDs(ds, char[], const int); int tlsDsSend(tlsDs, const char[const], const int); int tlsDsRecv(tlsDs, char[], const int); @@ -60,3 +53,6 @@ int stdDsSend(const char[const], const int); int stdDsRecv(char[], const int); +int getFd(ds); +int getTlsFd(tlsDs); +void closeFd(int); diff --git a/test/Blocking.hs b/test/Blocking.hs new file mode 100644 --- /dev/null +++ b/test/Blocking.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Blocking (tests) where + +import Distribution.TestSuite +import Base (simpleTest) +import Control.Concurrent(forkIO) +import qualified System.IO.Uniform as U +import qualified System.IO.Uniform.Streamline as S +import System.Timeout (timeout) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Attoparsec.ByteString as A +--import Control.Monad.IO.Class (liftIO) + +tests :: IO [Test] +tests = return [ + simpleTest "recieveLine" + (successTimeout "A test\n" (restoreLine S.receiveLine)), + simpleTest "runAttoparsec with successful parser" + (successTimeout "abcde" (parseBS (A.string "abcde"))), + simpleTest "runAttoparsec with failed parser" + (failTimeout "abcde" (parseBS (A.string "c"))), + simpleTest "lazyRecieveLine" + (successTimeout "Another test\n" (concatLine S.lazyRecieveLine)), + simpleTest "lazyReceiveN" + (failTimeout "abcde" (concatLine (S.lazyReceiveN 5))) + ] + +parseBS :: A.Parser ByteString -> S.Streamline IO ByteString +parseBS p = do + t <- S.runAttoparsec p + case t of + Left e -> return . C8.pack $ e + Right s -> return s + +restoreLine :: S.Streamline IO ByteString -> S.Streamline IO ByteString +restoreLine f = do + l <- f + return $ BS.concat [l, "\n"] + +concatLine :: S.Streamline IO [ByteString] -> S.Streamline IO ByteString +concatLine f = do + l <- f + return . BS.concat $ l + +-- | Tests the given command, by sending a string to an echo and running the command. +-- the command must not block. +successTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress +successTimeout txt f = do + recv <- U.bindPort 8888 + forkIO $ S.withClient (\_ _ -> do + l <- f + S.send l + return () + ) recv + r' <- timeout 1000000 $ S.withServer (do + S.send txt + t <- f + if t == txt + then return . Finished $ Pass + else return . Finished . Fail . C8.unpack $ t + ) "127.0.0.1" 8888 + U.closePort recv + case r' of + Just r -> return r + Nothing -> return . Finished . Fail $ "Execution blocked" + +-- | Tests the given command, by sending text trough the network and running it. +-- Does not care about the result of the command, just wether it blocks. +failTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress +failTimeout txt f = do + recv <- U.bindPort 8888 + forkIO $ S.withClient (\_ _ -> do + f + S.send "\n" + return () + ) recv + r' <- timeout 1000000 $ S.withServer (do + S.send txt + S.receiveLine + return . Finished $ Pass + ) "127.0.0.1" 8888 + U.closePort recv + case r' of + Just r -> return r + Nothing -> return . Finished . Fail $ "Execution blocked" diff --git a/test/Lazyness.hs b/test/Lazyness.hs deleted file mode 100644 --- a/test/Lazyness.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Lazyness (tests) where - -import Distribution.TestSuite -import Control.Concurrent(forkIO) -import qualified System.IO.Uniform as U -import qualified System.IO.Uniform.Streamline as S -import System.Timeout (timeout) - -tests :: IO [Test] -tests = return [Test readLine] - where - readLine = TestInstance - {run = testReadLine, - name = "Lazyness of readLine", - tags = [], - options = [], - setOption = \_ _ -> Right readLine - } - -testReadLine :: IO Progress -testReadLine = do - recv <- U.bindPort 8888 - forkIO $ S.withClient (\_ _ -> do - l <- S.receiveLine - S.send l - S.send "\n" - return () - ) recv - r <- timeout 1000000 $ S.withServer (do - S.send "A test\n" - S.receiveLine - return () - ) "127.0.0.1" 8888 - case r of - Just _ -> return . Finished $ Pass - Nothing -> return . Finished . Fail $ "Timeout on Streamline.readLine" - - - - diff --git a/test/Targets.hs b/test/Targets.hs new file mode 100644 --- /dev/null +++ b/test/Targets.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Targets (tests) where + +import Distribution.TestSuite +import Base (simpleTest) +import Control.Concurrent(forkIO) +import qualified System.IO.Uniform as U +import System.Timeout (timeout) +import qualified Data.ByteString.Char8 as C8 + +tests :: IO [Test] +tests = return [ + simpleTest "network" testNetwork, + simpleTest "file" testFile, + simpleTest "network TLS" testTls + ] + +testNetwork :: IO Progress +testNetwork = do + recv <- U.bindPort 8888 + forkIO $ do + s <- U.accept recv + l <- U.uRead s 100 + U.uPut s l + U.uClose s + return () + r' <- timeout 1000000 $ do + s <- U.connectToHost "127.0.0.1" 8888 + let l = "abcdef\n" + U.uPut s l + l' <- U.uRead s 100 + U.uClose s + if l == l' + then return . Finished $ Pass + else return . Finished . Fail . C8.unpack $ l' + U.closePort recv + case r' of + Just r -> return r + Nothing -> return . Finished . Fail $ "Execution blocked" + +testFile :: IO Progress +testFile = do + let file = "test/testFile" + s <- U.openFile file + let l = "abcde\n" + U.uPut s l + U.uClose s + s' <- U.openFile file + l' <- U.uRead s' 100 + U.uClose s' + if l == l' + then return . Finished $ Pass + else return . Finished . Fail . C8.unpack $ l' + +testTls :: IO Progress +testTls = do + recv <- U.bindPort 8888 + let set = U.TlsSettings "test/key.pem" "test/cert.pem" "test/dh.pem" + forkIO $ do + s' <- U.accept recv + s <- U.startTls set s' + l <- U.uRead s 100 + U.uPut s l + U.uClose s + return () + r' <- timeout 1000000 $ do + s' <- U.connectToHost "127.0.0.1" 8888 + s <- U.startTls set s' + let l = "abcdef\n" + U.uPut s l + l' <- U.uRead s 100 + U.uClose s + if l == l' + then return . Finished $ Pass + else return . Finished . Fail . C8.unpack $ l' + U.closePort recv + case r' of + Just r -> return r + Nothing -> return . Finished . Fail $ "Execution blocked" diff --git a/uniform-io.cabal b/uniform-io.cabal --- a/uniform-io.cabal +++ b/uniform-io.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.1.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Uniform IO over files, network, watever. @@ -22,9 +22,9 @@ It also includes implementations for standard IO, files and network IO, and easy to use TLS wrapping of any of those. - Currently TLS only wraps sockets, std streams are not exported - and there's no support for TLS certificate verification. Those - are all planned to be added soon. + Currently TLS only wraps sockets, and there's no support + for TLS certificate verification. Those are planned + to be added soon. Requires a '-threaded' compiler switch. @@ -70,7 +70,7 @@ source-repository this type: git location: https://sealgram.com/git/haskell/uniform-io - tag: 0.1.1.0 + tag: 0.2.0.0 library -- Modules exported by the library. @@ -111,15 +111,29 @@ includes: ds.h install-includes: ds.h C-Sources: src/System/IO/Uniform/ds.c - extra-libraries: ssl + extra-libraries: ssl, pthread -Test-suite lazyness +Test-suite targets type: detailed-0.9 - test-module: Lazyness + test-module: Targets hs-source-dirs: test build-depends: base >=4.7 && <5.0, Cabal >= 1.9.2, - uniform-io == 0.1.1.0 + bytestring >=0.10 && <1.0, + uniform-io == 0.2.0.0 + ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded + +Test-suite blocking + type: detailed-0.9 + test-module: Blocking + hs-source-dirs: + test + build-depends: + base >=4.7 && <5.0, + Cabal >= 1.9.2, + bytestring >=0.10 && <1.0, + attoparsec >=0.10 && <1.0, + uniform-io == 0.2.0.0 ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded