uniform-io 1.1.1.0 → 1.2.0.0

raw patch · 17 files changed

+699/−644 lines, 17 filesdep +interruptibledep +monad-controldep +transformers-basedep ~attoparsecdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: interruptible, monad-control, transformers-base

Dependency ranges changed: attoparsec, base, bytestring, data-default-class, iproute, network, transformers, word8

API changes (from Hackage documentation)

Files

• cbits/ds.c +318/−0
• cbits/ds.h +58/−0
• src/System/IO/Uniform.hs +15/−4
• src/System/IO/Uniform/ByteString.hs +3/−7
• src/System/IO/Uniform/External.hs +5/−4
• src/System/IO/Uniform/File.hs +16/−32
• src/System/IO/Uniform/HandlePair.hs +36/−0
• src/System/IO/Uniform/Network.hs +30/−44
• src/System/IO/Uniform/Std.hs +15/−17
• src/System/IO/Uniform/Streamline.hs +134/−131
• src/System/IO/Uniform/Streamline/Scanner.hs +19/−6
• src/System/IO/Uniform/ds.c +0/−318
• src/System/IO/Uniform/ds.h +0/−58
• test/Base.hs +7/−1
• test/Blocking.hs +1/−5
• test/Targets.hs +20/−2
• uniform-io.cabal +22/−15

@@ -0,0 +1,318 @@+#include <malloc.h>+#include <unistd.h>+#include <string.h>+//#include <sys/select.h>+#include <sys/types.h>+#include <sys/socket.h>+#include <sys/stat.h>+#include <fcntl.h>+#include <netinet/in.h>+#include <errno.h>+#include <openssl/bio.h>+#include <openssl/ssl.h>+#include <openssl/err.h>+#include <pthread.h>++#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;+  if(ptr){+    free(ptr);+  }+  errno = e;+  return NULL;+}++pthread_mutex_t loadLock;++void loadOpenSSL(const char *dh){+  if(openSslLoaded)+    return;+  pthread_mutex_lock(&loadLock);+  if(!openSslLoaded){+    SSL_load_error_strings();+    ERR_load_BIO_strings();+    ERR_load_crypto_strings();+    SSL_library_init();+    OpenSSL_add_all_algorithms();    +    openSslLoaded = 1;    +  }+  pthread_mutex_unlock(&loadLock);+}++void copy6addr(unsigned char d[16], const unsigned char s[16]){+  int i;+  for(i = 0; i < 16; i++)+    d[i] = s[i];+}++void zero6addr(unsigned char d[16]){+  int i;+  for(i = 0; i < 16; i++)+    d[i] = 0;+}++nethandler getNethandler(const int ipv6, const int port){+  nethandler h = (nethandler)malloc(sizeof(s_nethandler));+  h->ipv6 = ipv6;+  if(ipv6){+    h->fd = socket(AF_INET6, SOCK_STREAM, 0);+  }else{+    h->fd = socket(AF_INET, SOCK_STREAM, 0);+  }+  int optval = 1;+  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->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->fd, (struct sockaddr*) &add, sizeof(add));+  }+  if(e)+    return clear(h);+  e = listen(h->fd, DEFAULT_LISTENNING_QUEUE);+  if(e)+    return clear(h);+  return h;+}++nethandler getIPv4Port(const int port){+  return getNethandler(0, port);+}++nethandler getPort(const int port){+  return getNethandler(1, port);+}++ds createFromFile(int f){+  ds d = (ds)malloc(sizeof(s_ds));+  d->tp = file;+  d->fd = f;+  return d;+}++ds createFromFileName(const char *f){+  int fd = open(f, O_CREAT | O_RDWR, 0666);+  if(fd == -1){+    return NULL;+  }+  return createFromFile(fd);+}++ds createFromHandler(nethandler h){+  ds d = (ds)malloc(sizeof(s_ds));+  d->tp = sock;+  unsigned int s = sizeof(d->peer);+  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;+}++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->fd = socket(AF_INET6, SOCK_STREAM, 0);+  }else{+    d->fd = socket(AF_INET, SOCK_STREAM, 0);+  }+  if(connect(d->fd, add, add_size) < 0){+    int e = errno;+    free(d);+    errno = e;+    return NULL;+  }+  d->server = 0;+  return d;+}++ds createToIPv4Host(const unsigned long host, const int port){+  struct sockaddr_in add;+  add.sin_family = AF_INET;+  add.sin_port = htons(port);+  add.sin_addr.s_addr = host;+  return createToHost((struct sockaddr*) &add, sizeof(add), 0);+}++ds createToIPv6Host(const unsigned char host[16], const int port){+  struct sockaddr_in6 add;+  add.sin6_family = AF_INET6;+  add.sin6_port = htons(port);+  add.sin6_flowinfo = 0;+  copy6addr(add.sin6_addr.s6_addr, host);+  add.sin6_scope_id = 0;+  return createToHost((struct sockaddr*) &add, sizeof(add), 1);+}++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->fd, (struct sockaddr*)&peer, &peer_size)){+    return 0;+  }+  if(peer.ss_family == AF_INET){+    struct sockaddr_in *a = (struct sockaddr_in*)&(peer);+    zero6addr(ipv6peer);+    *ipv6 = -1;+    *ipv4peer = a->sin_addr.s_addr;+    port = a->sin_port;+  }else{+    struct sockaddr_in6 *a = (struct sockaddr_in6*)&(peer);+    *ipv4peer = 0;+    *ipv6 = 1;+    copy6addr(ipv6peer, a->sin6_addr.s6_addr);+    port = a->sin6_port;+  }+  return port;+}++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);+}+int stdDsSend(const char *b, const int s){+  return write(1, 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);+}+int stdDsRecv(char *b, const int s){+  return read(0, b, s);+}+++int prepareToClose(ds d){+  int fd = d->fd;+  free(d);+  return fd;+}++ds closeTls(tlsDs d){+  ds original = d->original;+  SSL_shutdown(d->s);+  //No bidirectional shutdown supported+  //SSL_shutdown(d->s);+  SSL_free(d->s);+  free(d);+  return original;+}++void closeHandler(nethandler h){+  close(h->fd);+  free(h);+}++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_1_server_method());+  else+    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){+      int f = prepareToClose(d);+      closeFd(f);+      return clear(ctx);+    }+  if(key)+    if(SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) != 1){+      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))){+    int f = prepareToClose(d);+    closeFd(f);+    clear(ctx);+    return clear(t);+  }+  if(!SSL_set_fd(t->s, d->fd)){+    closeTls(t);+    return NULL;+  }+  int retry = 1;+  int e;+  while(retry){+    retry = 0;+    if(d->server){+      SSL_set_accept_state(t->s);+      e = SSL_accept(t->s);+    }else{+      SSL_set_connect_state(t->s);+      e = SSL_connect(t->s);+    }+    if(e <= 0){+      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{+	closeTls(t);+	return NULL;+      }+    }+  }+  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);+}

@@ -0,0 +1,58 @@+#include <sys/types.h>+#include <netinet/in.h>+#include <openssl/ssl.h>++typedef enum {+  file, std, sock+} dstype;++typedef struct {+  int fd;+  dstype tp;+  int ipv6;+  int server;+  struct sockaddr_storage peer;+} *ds, s_ds;++#define DEFAULT_LISTENNING_QUEUE 5++typedef struct{+  int fd;+  int ipv6;+} *nethandler, s_nethandler;++typedef struct {+  dstype tp;+  void *original;+  SSL *s;+} *tlsDs, s_tlsDs;++nethandler getIPv4Port(const int port);+nethandler getPort(const int port);++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(ds, const char*, const char*, const char*);++int getPeer(ds, unsigned long*, unsigned char[16], int*);++int closeDs(ds);+void closeHandler(nethandler);+ds closeTls(tlsDs);++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);++int stdDsSend(const char[const], const int);+int stdDsRecv(char[], const int);++int getFd(ds);+int getTlsFd(tlsDs);+void closeFd(int);

@@ -9,12 +9,13 @@   UniformIO(..),   TlsSettings(..),   SomeIO(..),-  mapOverInput+  mapOverInput,+  uGetContents   ) where  import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS import Control.Exception-import Control.Applicative ((<$>)) import System.IO.Error  import Data.Default.Class@@ -53,8 +54,8 @@ data SomeIO = forall a. (UniformIO a) => SomeIO a  instance UniformIO SomeIO where-  uRead (SomeIO s) n = uRead s n-  uPut (SomeIO s) t  = uPut s t+  uRead (SomeIO s) = uRead s+  uPut (SomeIO s)  = uPut s   uClose (SomeIO s) = uClose s   startTls set (SomeIO s) = SomeIO <$> startTls set s   isSecure (SomeIO s) = isSecure s@@ -81,3 +82,13 @@     Right dt -> do       i <- f initial dt       mapOverInput io block f i++{- |+Returns the entire contents recieved from this target.+-}+uGetContents :: UniformIO io => io -> Int -> IO LBS.ByteString+uGetContents io block = LBS.fromChunks <$> mapOverInput io block atEnd []+  where+    atEnd :: [ByteString] -> ByteString -> IO [ByteString]+    atEnd bb b = return $ bb ++ [b]+

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +-- | UniformIO on memory module System.IO.Uniform.ByteString (   ByteStringIO,   withByteStringIO, withByteStringIO'@@ -11,11 +12,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Builder as BSBuild---import qualified Data.List as L---import Control.Exception---import Control.Applicative ((<$>))-import Data.Monoid (mappend)---import qualified Network.Socket as Soc import System.IO.Error import Control.Concurrent.MVar @@ -34,7 +30,7 @@       ioError $ mkIOError eofErrorType "read past end of input" Nothing Nothing     else do       let (r, i') = BS.splitAt n i-      let eof' = (BS.null r && n > 0)+      let eof' = BS.null r && n > 0       putMVar (bsioinput s) (i', eof')       return r   uPut s t = do@@ -42,7 +38,7 @@     let o' = mappend o $ BSBuild.byteString t     putMVar (bsiooutput s) o'   uClose _ = return ()-  startTls _ a = return a+  startTls _ = return   isSecure _ = True  -- | withByteStringIO' input f

@@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface, InterruptibleFFI, EmptyDataDecls #-}+{-# CFILES src/System/IO/Uniform/ds.c #-}  module System.IO.Uniform.External where @@ -10,13 +11,13 @@  data Nethandler -- | A bounded IP port from where to accept SocketIO connections.-newtype BoundedPort = BoundedPort {lis :: (Ptr Nethandler)}+newtype BoundedPort = BoundedPort {lis :: Ptr Nethandler} data Ds data TlsDs -- | UniformIO IP connections.-data SocketIO = SocketIO {sock :: (Ptr Ds)} | TlsSocketIO {bio :: (Ptr TlsDs)}+data SocketIO = SocketIO {sock :: Ptr Ds} | TlsSocketIO {bio :: Ptr TlsDs} -- | UniformIO type for file IO.-newtype FileIO = FileIO {fd :: (Ptr Ds)}+newtype FileIO = FileIO {fd :: Ptr Ds} -- | UniformIO that reads from stdin and writes to stdout. data StdIO = StdIO @@ -35,7 +36,7 @@ foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr Ds)  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 "getPeer" c_getPeer :: Ptr Ds -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO CInt  --foreign import ccall safe "getFd" c_getFd :: Ptr Ds -> IO CInt --foreign import ccall safe "getTlsFd" c_getTlsFd :: Ptr TlsDs -> IO CInt

@@ -1,3 +1,4 @@+-- | UniformIO functions for file access module System.IO.Uniform.File (   FileIO,   openFile@@ -7,49 +8,32 @@ import System.IO.Uniform.External  import Foreign---import Foreign.C.Types import Foreign.C.String import Foreign.C.Error---import qualified Data.IP as IP---import Data.ByteString (ByteString) import qualified Data.ByteString as BS---import qualified Data.ByteString.Lazy as LBS---import qualified Data.ByteString.Builder as BSBuild---import qualified Data.List as L---import Control.Exception-import Control.Applicative ((<$>))---import Data.Monoid (mappend)---import qualified Network.Socket as Soc---import System.IO.Error---import Control.Concurrent.MVar----import Data.Default.Class+import Control.Monad  import System.Posix.Types (Fd(..))   -- | UniformIO type for file IO. instance UniformIO FileIO where-  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 ()-      )+  uRead s n = 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 = BS.useAsCStringLen t (+    \(str, n) -> do+      count <- c_send (fd s) str $ fromIntegral n+      when (count < 0) $ throwErrno "could not write"+    )   uClose s = do     f <- Fd <$> c_prepareToClose (fd s)     closeFd f-  startTls _ f = return f+  startTls _ = return   isSecure _ = True      @@ -57,7 +41,7 @@ openFile :: String -> IO FileIO openFile fileName = do   r <- withCString fileName (-    \f -> fmap FileIO $ c_createFile f+    fmap FileIO . c_createFile     )   if fd r == nullPtr     then throwErrno "could not open file"

@@ -0,0 +1,36 @@+{- |+IO into a pair of Haskell handles, like the ones+created with stdin and stdout of a forked process.+-}+module System.IO.Uniform.HandlePair (+  HandlePair,+  fromHandles+  ) where++import System.IO (Handle, hClose)+import System.IO.Uniform+import qualified Data.ByteString as BS++{- |+A pair of handles, the first for input,+and the second for output.+-}+data HandlePair = HandlePair Handle Handle++{- |+> fromHandles inputHandler outputHandler++Creates a uniform io target from a pair of handlers.+-}+fromHandles :: Handle -> Handle -> HandlePair+fromHandles = HandlePair++-- | UniformIO that reads from stdin and writes to stdout.+instance UniformIO HandlePair where+  uRead (HandlePair i _) = BS.hGetSome i+  uPut (HandlePair _ o) = BS.hPut o+  uClose (HandlePair i o) = do+    hClose i+    hClose o+  startTls _ = return+  isSecure _ = True

@@ -1,3 +1,4 @@+-- | UniformIO functions for TCP connections module System.IO.Uniform.Network (   SocketIO,   BoundedPort,@@ -17,56 +18,41 @@ import Foreign.C.String import Foreign.C.Error import qualified Data.IP as IP---import Data.ByteString (ByteString) import qualified Data.ByteString as BS---import qualified Data.ByteString.Lazy as LBS---import qualified Data.ByteString.Builder as BSBuild import qualified Data.List as L import Control.Exception-import Control.Applicative ((<$>))---import Data.Monoid (mappend)+import Control.Monad import qualified Network.Socket as Soc import System.IO.Error---import Control.Concurrent.MVar ---import Data.Default.Class- import System.Posix.Types (Fd(..)) --- | UniformIO IP connections.+-- | UniformIO TCP connections. instance UniformIO SocketIO where-  uRead (SocketIO s) n = do-    allocaArray n (-      \b -> do-        count <- c_recv s b (fromIntegral n)-        if count < 0-          then throwErrno "could not read"-          else BS.packCStringLen (b, fromIntegral count)-      )-  uRead (TlsSocketIO s) n = do-    allocaArray n (-      \b -> do-        count <- c_recvTls s b $ fromIntegral n-        if count < 0-          then throwErrno "could not read"-          else BS.packCStringLen (b, fromIntegral count)-      )-  uPut (SocketIO s) t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_send s str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )-  uPut (TlsSocketIO s) t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_sendTls s str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )+  uRead (SocketIO s) n = allocaArray n (+    \b -> do+      count <- c_recv s b (fromIntegral n)+      if count < 0+        then throwErrno "could not read"+        else BS.packCStringLen (b, fromIntegral count)+    )+  uRead (TlsSocketIO s) n = allocaArray n (+    \b -> do+      count <- c_recvTls s b $ fromIntegral n+      if count < 0+        then throwErrno "could not read"+        else BS.packCStringLen (b, fromIntegral count)+    )+  uPut (SocketIO s) t = BS.useAsCStringLen t (+    \(str, n) -> do+      count <- c_send s str $ fromIntegral n+      when (count < 0) $ throwErrno "could not write"+    )+  uPut (TlsSocketIO s) t = BS.useAsCStringLen t (+    \(str, n) -> do+      count <- c_sendTls s str $ fromIntegral n+      when (count < 0) $ throwErrno "could not write"+    )   uClose (SocketIO s) = do     f <- Fd <$> c_prepareToClose s     closeFd f@@ -115,8 +101,8 @@ connectTo :: IP.IP -> Int -> IO SocketIO connectTo host port = do   r <- case host of-    IP.IPv4 host' -> fmap SocketIO $ c_connect4 (fromIntegral . IP.toHostAddress $ host') (fromIntegral port)-    IP.IPv6 host' -> fmap SocketIO $ withArray (ipToArray host') (+    IP.IPv4 host' -> SocketIO <$> c_connect4 (fromIntegral . IP.toHostAddress $ host') (fromIntegral port)+    IP.IPv6 host' -> SocketIO <$> withArray (ipToArray host') (       \add -> c_connect6 add (fromIntegral port)       )   if sock r == nullPtr@@ -153,7 +139,7 @@ --  Accept clients on a port previously bound with bindPort. accept :: BoundedPort -> IO SocketIO accept port = do-  r <- fmap SocketIO $ c_accept (lis port)+  r <- SocketIO <$> c_accept (lis port)   if sock r == nullPtr     then throwErrno "could not accept connection"     else return r

@@ -1,3 +1,4 @@+-- | UniformIO over stdin and stdout module System.IO.Uniform.Std (   StdIO(StdIO)   ) where@@ -8,25 +9,22 @@ import Foreign import Foreign.C.Error import qualified Data.ByteString as BS+import Control.Monad  -- | UniformIO that reads from stdin and writes to stdout. 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 ()-      )+  uRead _ n = 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 = BS.useAsCStringLen t (+    \(str, n) -> do+      count <- c_sendStd str $ fromIntegral n+      when (count < 0) $ throwErrno "could not write"+    )   uClose _ = return ()-  startTls _ a = return a+  startTls _ = return   isSecure _ = True

@@ -1,45 +1,59 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} --- |--- Streamline exports a monad that, given an uniform IO target, emulates--- character tream IO using high performance block IO.+{- |+Streamline exports a monad that, given an uniform IO target, emulates+character stream IO using high performance block IO.+-} module System.IO.Uniform.Streamline (+  -- * Basic Type   Streamline,-  IOScannerState(..),+  -- * Running streamline targets+  -- ** Single pass runners   withClient,   withServer,   withTarget,+  -- ** Interruptible support+  inStreamlineCtx,+  peelStreamlineCtx,+  closeTarget,+  -- * Sending and recieving data   send,   send',   recieveLine,   recieveLine',-  lazyRecieveLine,   recieveN,   recieveN',-  lazyRecieveN,-  recieveTill,-  recieveTill',-  startTls,+  -- ** Running a parser   runAttoparsec,   runAttoparsecAndReturn,-  isSecure,-  setTimeout,-  setEcho,+  -- ** Scanning the input   runScanner,   runScanner',   scan,   scan',-  textScanner+  recieveTill,+  recieveTill',+  -- * Behavior settings+  startTls,+  isSecure,+  setTimeout,+  echoTo,+  setEcho   ) where +import System.IO (stdout, Handle) import qualified System.IO.Uniform as S import qualified System.IO.Uniform.Network as N+import qualified System.IO.Uniform.Std as Std import System.IO.Uniform (UniformIO, SomeIO(..), TlsSettings) import System.IO.Uniform.Streamline.Scanner+import Data.Default.Class  import Control.Monad.Trans.Class-import Control.Applicative-import Control.Monad (ap)+import Control.Monad.Trans.Interruptible+import Control.Monad.Trans.Control+import Control.Monad (ap, liftM)+import Control.Monad.Base import Control.Monad.IO.Class import System.IO.Error import Data.ByteString (ByteString)@@ -47,65 +61,71 @@ import qualified Data.ByteString.Lazy as LBS import Data.Word8 (Word8) import Data.IP (IP)-import qualified Data.Char as C  import qualified Data.Attoparsec.ByteString as A -data Data = Data {str :: SomeIO, timeout :: Int, buff :: ByteString, isEOF :: Bool, echo :: Bool}+-- | Internal state for a Streamline monad+data StreamlineState = StreamlineState {str :: SomeIO, timeout :: Int, buff :: ByteString, isEOF :: Bool, echo :: Maybe Handle}+instance Default StreamlineState where+  -- | Will open StdIO+  def = StreamlineState (SomeIO Std.StdIO) defaultTimeout BS.empty False Nothing+ -- | Monad that emulates character stream IO over block IO.-newtype Streamline m a = Streamline {withTarget' :: Data -> m (a, Data)}+newtype Streamline m a = Streamline {withTarget' :: StreamlineState -> m (a, StreamlineState)}  blockSize :: Int blockSize = 4096 defaultTimeout :: Int defaultTimeout = 1000000 * 600 -readF :: MonadIO m => Data -> m ByteString-readF cl = if echo cl-          then do-            l <- liftIO $ S.uRead (str cl) blockSize-            liftIO $ BS.putStr "<"-            liftIO $ BS.putStr l-            return l-          else liftIO $ S.uRead (str cl) blockSize+readF :: MonadIO m => StreamlineState -> m ByteString+readF cl = case echo cl of+  Just h -> do+    l <- liftIO $ S.uRead (str cl) blockSize+    liftIO $ BS.hPutStr h "<"+    liftIO $ BS.hPutStr h l+    return l+  Nothing -> liftIO $ S.uRead (str cl) blockSize -writeF :: MonadIO m => Data -> ByteString -> m ()-writeF cl l = if echo cl-             then do-               liftIO $ BS.putStr ">"-               liftIO $ BS.putStr l-               liftIO $ S.uPut (str cl) l-             else liftIO $ S.uPut (str cl) l+writeF :: MonadIO m => StreamlineState -> ByteString -> m ()+writeF cl l = case echo cl of+  Just h -> do+    liftIO $ BS.hPutStr h ">"+    liftIO $ BS.hPutStr h l+    liftIO $ S.uPut (str cl) l+  Nothing -> liftIO $ S.uPut (str cl) l --- | withServer f serverIP port+-- | > withServer f serverIP port -- --  Connects to the given server port, runs f, and closes the connection. withServer :: MonadIO m => IP -> Int -> Streamline m a -> m a withServer host port f = do   ds <- liftIO $ N.connectTo host port-  (ret, _) <- withTarget' f $ Data (SomeIO ds) defaultTimeout "" False False+  (ret, _) <- withTarget' f def{str=SomeIO ds}   liftIO $ S.uClose ds   return ret --- | withClient f boundPort+-- | > withClient f boundPort -- --  Accepts a connection at the bound port, runs f and closes the connection. withClient :: MonadIO m => N.BoundedPort -> (IP -> Int -> Streamline m a) -> m a withClient port f = do   ds <- liftIO $ N.accept port   (peerIp, peerPort) <- liftIO $ N.getPeer ds-  (ret, _) <- withTarget' (f peerIp peerPort) $ Data (SomeIO ds) defaultTimeout "" False False+  (ret, _) <- withTarget' (f peerIp peerPort) def{str=SomeIO ds}   liftIO $ S.uClose ds   return ret --- | withTarget f someIO------  Runs f wrapped on a Streamline monad that does IO on nomeIO.-withTarget :: (MonadIO m, UniformIO a) => a -> Streamline m b -> m b-withTarget s f = do  -  (ret, _) <- withTarget' f $ Data (SomeIO s) defaultTimeout "" False False-  return ret+{- |+> withTarget f someIO +Runs f wrapped on a Streamline monad that does IO on someIO.+-}+withTarget :: (Monad m, UniformIO a) => a -> Streamline m b -> m b+withTarget s f = do+  (r, _) <- withTarget' f def{str=SomeIO s}+  return r+ instance Monad m => Monad (Streamline m) where   --return :: (Monad m) => a -> Streamline m a   return x = Streamline  $ \cl -> return (x, cl)@@ -133,7 +153,7 @@ instance MonadIO m => MonadIO (Streamline m) where   liftIO = lift . liftIO --- | Sends data over the streamlines an IO target.+-- | Sends data over the IO target. send :: MonadIO m => ByteString -> Streamline m () send r = Streamline $ \cl -> do   writeF cl r@@ -143,20 +163,13 @@ send' :: MonadIO m => LBS.ByteString -> Streamline m () send' r = Streamline $ \cl -> do   let dd = LBS.toChunks r-  mapM (writeF cl) dd+  mapM_ (writeF cl) dd   return ((), cl) --- | Equivalent to runScanner', but returns a strict, completely---   evaluated ByteString.-runScanner :: MonadIO m => s -> IOScanner s -> Streamline m (ByteString, s)-runScanner state scanner = do-  (rt, st) <- runScanner' state scanner-  return (LBS.toStrict rt, st)- {- | Very much like Attoparsec's runScanner: -runScanner' scanner initial_state+> runScanner scanner initial_state  Recieves data, running the scanner on each byte, using the scanner result as initial state for the@@ -165,13 +178,20 @@  Returns the scanned ByteString.  -} +runScanner :: MonadIO m => s -> IOScanner s -> Streamline m (ByteString, s)+runScanner state scanner = do+  (rt, st) <- runScanner' state scanner+  return (LBS.toStrict rt, st)++-- | Equivalent to runScanner, but returns a strict, completely+--   evaluated ByteString. runScanner' :: MonadIO m => s -> IOScanner s -> Streamline m (LBS.ByteString, s) runScanner' state scanner = Streamline $ \d ->   do     (tx, st, d') <- in_scan d state     return ((LBS.fromChunks tx, st), d')   where-    --in_scan :: Data -> s -> m ([ByteString], s, Data)+    --in_scan :: StreamlineState -> s -> m ([ByteString], s, StreamlineState)     in_scan d st       | isEOF d = eofError "System.IO.Uniform.Streamline.scan'"       | BS.null (buff d) = do@@ -197,11 +217,11 @@ data ScanResult s = SplitAt Int s | AllInput s  --- | Equivalent to runScanner, but dischards the final state+-- | Equivalent to runScanner, but discards the final state scan :: MonadIO m => s -> IOScanner s -> Streamline m ByteString scan state scanner = fst <$> runScanner state scanner --- | Equivalent to runScanner', but dischards the final state+-- | Equivalent to runScanner', but discards the final state scan' :: MonadIO m => s -> IOScanner s -> Streamline m LBS.ByteString scan' state scanner = fst <$> runScanner' state scanner @@ -213,42 +233,20 @@ recieveLine' :: MonadIO m => Streamline m LBS.ByteString recieveLine' = recieveTill' "\n" --- | Use recieveLine'.-lazyRecieveLine :: MonadIO m => Streamline m [ByteString]-{-# DEPRECATED #-}-lazyRecieveLine = Streamline $ \cl -> lazyRecieveLine' cl-  where-    lazyRecieveLine' :: MonadIO m => Data -> m ([ByteString], Data)-    lazyRecieveLine' cl' = -      if isEOF cl'-      then eofError "System.IO.Uniform.Streamline.lazyRecieveLine"-      else-        if BS.null $ buff cl'-        then do-          dt <- readF cl'-          lazyRecieveLine' cl'{buff=dt}{isEOF=BS.null dt}-        else do-          let l = A.parseOnly lineWithEol $ buff cl'-          case l of-            Left _ -> do-              l' <- readF cl'-              (ret, cl'') <- lazyRecieveLine' cl'{buff=l'}{isEOF=BS.null l'}-              return ((buff cl') : ret, cl'')-            Right (ret, dt) -> return ([ret], cl'{buff=dt})- -- | Recieves the given number of bytes. recieveN :: MonadIO m => Int -> Streamline m ByteString recieveN n = LBS.toStrict <$> recieveN' n  -- | Lazy version of recieveN recieveN' :: MonadIO m => Int -> Streamline m LBS.ByteString-recieveN' n = Streamline $ \cl ->-  do-    (tt, cl') <- recieve cl n-    return (LBS.fromChunks tt, cl')+recieveN' n | n <= 0 = return ""+            | otherwise = Streamline $ \cl ->+            do+              (tt, cl') <- recieve cl n+              return (LBS.fromChunks tt, cl')   where     recieve d b-      | isEOF d = eofError "System.IO.Uniform.Streamline.lazyRecieveN"+      | isEOF d = eofError "System.IO.Uniform.Streamline.recieveN"       | BS.null . buff $ d = do         dt <- readF d         recieve d{buff=dt}{isEOF=BS.null dt} b@@ -259,35 +257,6 @@         (r, d') <- recieve d{buff=""} $ b - (BS.length . buff $ d)         return (buff d : r, d') --- | Use recieveN'.-lazyRecieveN :: (Functor m, MonadIO m) => Int -> Streamline m [ByteString]-{-# DEPRECATED #-}-lazyRecieveN n' = Streamline $ \cl' -> lazyRecieveN' cl' n'-  where-    lazyRecieveN' :: (Functor m, MonadIO m) => Data -> Int -> m ([ByteString], Data)-    lazyRecieveN' cl n =-      if isEOF cl-      then eofError "System.IO.Uniform.Streamline.lazyRecieveN"-      else-        if BS.null (buff cl)-        then do-          b <- readF cl-          let eof = BS.null b-          let cl' = cl{buff=b}{isEOF=eof}-          lazyRecieveN' cl' n-        else-          if n <= BS.length (buff cl)-          then let-            ret = [BS.take n (buff cl)]-            buff' = BS.drop n (buff cl)-            in return (ret, cl{buff=buff'})-          else let-            cl' = cl{buff=""}-            b = buff cl-            in fmap (appFst b) $ lazyRecieveN' cl' (n - BS.length b)-    appFst :: a -> ([a], b) -> ([a], b)-    appFst a (l, b) = (a:l, b)- -- | Recieves data until it matches the argument. --   Returns all of it, including the matching data. recieveTill :: MonadIO m => ByteString -> Streamline m ByteString@@ -295,7 +264,7 @@  -- | Lazy version of recieveTill recieveTill' :: MonadIO m => ByteString -> Streamline m LBS.ByteString-recieveTill' t = recieve . BS.unpack $ t+recieveTill' = recieve . BS.unpack   where     recieve t' = scan' [] (textScanner t') @@ -318,7 +287,7 @@     (cl', i, a) <- liftIO $ continueResult cl c     return ((i, a), cl')   where-    continueResult :: Data -> A.Result a -> IO (Data, ByteString, (Either String a))+    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, ByteString, Either String a)     -- tx eof ds      continueResult cl c = case c of       A.Fail i _ msg -> return (cl{buff=i}, BS.take (BS.length (buff cl) - BS.length i) (buff cl), Left msg)@@ -339,7 +308,7 @@     (cl', a) <- liftIO $ continueResult cl c     return (a, cl')   where-    continueResult :: Data -> A.Result a -> IO (Data, (Either String a))+    continueResult :: StreamlineState -> A.Result a -> IO (StreamlineState, Either String a)     continueResult cl c = case c of         A.Fail i _ msg -> return (cl{buff=i}, Left msg)         A.Done i r -> return (cl{buff=i}, Right r)@@ -347,7 +316,7 @@           d <- readF cl           let eof' = BS.null d           continueResult cl{buff=d}{isEOF=eof'} (c' d)-  + -- | Indicates whether transport layer security is being used. isSecure :: Monad m => Streamline m Bool isSecure = Streamline $ \cl -> return (S.isSecure $ str cl, cl)@@ -361,19 +330,53 @@ --   will be echoed in stdout, with ">" and "<" markers indicating --   what is read and written. setEcho :: Monad m => Bool -> Streamline m ()-setEcho e = Streamline $ \cl -> return ((), cl{echo=e})+setEcho e = Streamline $ \cl ->+  if e then return ((), cl{echo=Just stdout}) else return ((), cl{echo=Nothing}) -lineWithEol :: A.Parser (ByteString, ByteString)-lineWithEol = do-  l <- A.scan False lineScanner-  r <- A.takeByteString-  return (l, r)-  +{- |+Sets echo of the streamlined IO target.++If echo is set, all the data read an written to the target+will be echoed to the handle, with ">" and "<" markers indicating+what is read and written.++Setting to Nothing will disable echo.+-}+echoTo :: Monad m => Maybe Handle -> Streamline m ()+echoTo h = Streamline $ \cl -> return ((), cl{echo=h})+ eofError :: MonadIO m => String -> m a eofError msg = liftIO . ioError $ mkIOError eofErrorType msg Nothing Nothing -lineScanner :: Bool -> Word8 -> Maybe Bool-lineScanner False c -  | c == (fromIntegral . C.ord $ '\n') = Just True-  | otherwise = Just False-lineScanner True _ = Nothing+instance Interruptible Streamline where+  type RSt Streamline a = (a, StreamlineState)+  resume f (a, st) = withTarget' (f a) st++-- | Creates a Streamline interrutible context+inStreamlineCtx :: UniformIO io => io -> a -> RSt Streamline a+inStreamlineCtx io a = (a, def{str = SomeIO io})++-- | Closes the target of a streamline state, releasing any resource.+closeTarget :: MonadIO m => Streamline m ()+closeTarget = Streamline $ \st -> do+  liftIO . S.uClose . str $ st+  return ((), st)++-- | Removes a Streamline interruptible context+peelStreamlineCtx :: RSt Streamline a -> (a, SomeIO)+peelStreamlineCtx (a, dt) = (a, str dt)++instance MonadTransControl Streamline where+  type StT Streamline a = (a, StreamlineState)+  liftWith f = Streamline $ \s ->+                   liftM (\x -> (x, s))+                         (f $ \t -> withTarget' t s)+  restoreT = Streamline . const++instance MonadBase b m => MonadBase b (Streamline m) where+  liftBase = liftBaseDefault++instance MonadBaseControl b m => MonadBaseControl b (Streamline m) where+  type StM (Streamline m) a = ComposeSt Streamline m a+  liftBaseWith     = defaultLiftBaseWith+  restoreM         = defaultRestoreM

@@ -1,6 +1,13 @@-module System.IO.Uniform.Streamline.Scanner where+{- |+IO scanners for use with the Streamline monad transformer.+-}+module System.IO.Uniform.Streamline.Scanner (+  IOScanner,+  IOScannerState(..),+  textScanner,+  anyScanner+  )where -import Control.Applicative import Data.Default.Class import Data.Word8 (Word8) @@ -25,7 +32,7 @@   fmap f (LastPass x) = LastPass $ f x   fmap f (Running x) = Running $ f x instance Applicative IOScannerState where-  pure a = Running a+  pure = Running   Finished <*> _ = Finished   _ <*> Finished = Finished   (LastPass f) <*> (LastPass x) = LastPass $ f x@@ -41,8 +48,10 @@     Running y -> LastPass y   (Running x) >>= f = f x +-- | IOScanner type, as required by the scan functions of Streamline type IOScanner a = a -> Word8 -> IOScannerState a +-- | Creates a scanner that'll finish when any of the given scanners finish. anyScanner :: Default a => [IOScanner a] -> IOScanner [a] anyScanner scanners = scan   where@@ -54,7 +63,11 @@     apScanner (s:ss) (t:tt) h = s t h : apScanner ss tt h  -textScanner :: [Word8] -> (IOScanner [[Word8]])+{- |+Given a sequence of bytes, creates a scanner that will scan+its input untill that sequence is found.+-}+textScanner :: [Word8] -> IOScanner [[Word8]] textScanner [] = \_ _ -> Finished textScanner t@(c:_) = scanner   where@@ -67,8 +80,8 @@     popStacks ((h':hh):ss) h       | h == h' && null hh = case popStacks ss h of         Finished -> Finished-        LastPass ss' -> LastPass $ ss'-        Running ss' -> LastPass $ ss'+        LastPass ss' -> LastPass ss'+        Running ss' -> LastPass ss'       | h == h' = case popStacks ss h of         Finished -> Finished         LastPass ss' -> LastPass $ hh:ss'

@@ -1,318 +0,0 @@-#include <malloc.h>-#include <unistd.h>-#include <string.h>-//#include <sys/select.h>-#include <sys/types.h>-#include <sys/socket.h>-#include <sys/stat.h>-#include <fcntl.h>-#include <netinet/in.h>-#include <errno.h>-#include <openssl/bio.h>-#include <openssl/ssl.h>-#include <openssl/err.h>-#include <pthread.h>--#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;-  if(ptr){-    free(ptr);-  }-  errno = e;-  return NULL;-}--pthread_mutex_t loadLock;--void loadOpenSSL(const char *dh){-  if(openSslLoaded)-    return;-  pthread_mutex_lock(&loadLock);-  if(!openSslLoaded){-    SSL_load_error_strings();-    ERR_load_BIO_strings();-    ERR_load_crypto_strings();-    SSL_library_init();-    OpenSSL_add_all_algorithms();    -    openSslLoaded = 1;    -  }-  pthread_mutex_unlock(&loadLock);-}--void copy6addr(unsigned char d[16], const unsigned char s[16]){-  int i;-  for(i = 0; i < 16; i++)-    d[i] = s[i];-}--void zero6addr(unsigned char d[16]){-  int i;-  for(i = 0; i < 16; i++)-    d[i] = 0;-}--nethandler getNethandler(const int ipv6, const int port){-  nethandler h = (nethandler)malloc(sizeof(s_nethandler));-  h->ipv6 = ipv6;-  if(ipv6){-    h->fd = socket(AF_INET6, SOCK_STREAM, 0);-  }else{-    h->fd = socket(AF_INET, SOCK_STREAM, 0);-  }-  int optval = 1;-  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->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->fd, (struct sockaddr*) &add, sizeof(add));-  }-  if(e)-    return clear(h);-  e = listen(h->fd, DEFAULT_LISTENNING_QUEUE);-  if(e)-    return clear(h);-  return h;-}--nethandler getIPv4Port(const int port){-  return getNethandler(0, port);-}--nethandler getPort(const int port){-  return getNethandler(1, port);-}--ds createFromFile(int f){-  ds d = (ds)malloc(sizeof(s_ds));-  d->tp = file;-  d->fd = f;-  return d;-}--ds createFromFileName(const char *f){-  int fd = open(f, O_CREAT | O_RDWR, 0666);-  if(fd == -1){-    return NULL;-  }-  return createFromFile(fd);-}--ds createFromHandler(nethandler h){-  ds d = (ds)malloc(sizeof(s_ds));-  d->tp = sock;-  unsigned int s = sizeof(d->peer);-  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;-}--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->fd = socket(AF_INET6, SOCK_STREAM, 0);-  }else{-    d->fd = socket(AF_INET, SOCK_STREAM, 0);-  }-  if(connect(d->fd, add, add_size) < 0){-    int e = errno;-    free(d);-    errno = e;-    return NULL;-  }-  d->server = 0;-  return d;-}--ds createToIPv4Host(const unsigned long host, const int port){-  struct sockaddr_in add;-  add.sin_family = AF_INET;-  add.sin_port = htons(port);-  add.sin_addr.s_addr = host;-  return createToHost((struct sockaddr*) &add, sizeof(add), 0);-}--ds createToIPv6Host(const unsigned char host[16], const int port){-  struct sockaddr_in6 add;-  add.sin6_family = AF_INET6;-  add.sin6_port = htons(port);-  add.sin6_flowinfo = 0;-  copy6addr(add.sin6_addr.s6_addr, host);-  add.sin6_scope_id = 0;-  return createToHost((struct sockaddr*) &add, sizeof(add), 1);-}--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->fd, (struct sockaddr*)&peer, &peer_size)){-    return 0;-  }-  if(peer.ss_family == AF_INET){-    struct sockaddr_in *a = (struct sockaddr_in*)&(peer);-    zero6addr(ipv6peer);-    *ipv6 = -1;-    *ipv4peer = a->sin_addr.s_addr;-    port = a->sin_port;-  }else{-    struct sockaddr_in6 *a = (struct sockaddr_in6*)&(peer);-    *ipv4peer = 0;-    *ipv6 = 1;-    copy6addr(ipv6peer, a->sin6_addr.s6_addr);-    port = a->sin6_port;-  }-  return port;-}--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);-}-int stdDsSend(const char *b, const int s){-  return write(1, 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);-}-int stdDsRecv(char *b, const int s){-  return read(0, b, s);-}---int prepareToClose(ds d){-  int fd = d->fd;-  free(d);-  return fd;-}--ds closeTls(tlsDs d){-  ds original = d->original;-  SSL_shutdown(d->s);-  //No bidirectional shutdown supported-  //SSL_shutdown(d->s);-  SSL_free(d->s);-  free(d);-  return original;-}--void closeHandler(nethandler h){-  close(h->fd);-  free(h);-}--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_1_server_method());-  else-    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){-      int f = prepareToClose(d);-      closeFd(f);-      return clear(ctx);-    }-  if(key)-    if(SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) != 1){-      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))){-    int f = prepareToClose(d);-    closeFd(f);-    clear(ctx);-    return clear(t);-  }-  if(!SSL_set_fd(t->s, d->fd)){-    closeTls(t);-    return NULL;-  }-  int retry = 1;-  int e;-  while(retry){-    retry = 0;-    if(d->server){-      SSL_set_accept_state(t->s);-      e = SSL_accept(t->s);-    }else{-      SSL_set_connect_state(t->s);-      e = SSL_connect(t->s);-    }-    if(e <= 0){-      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{-	closeTls(t);-	return NULL;-      }-    }-  }-  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);-}

@@ -1,58 +0,0 @@-#include <sys/types.h>-#include <netinet/in.h>-#include <openssl/ssl.h>--typedef enum {-  file, std, sock-} dstype;--typedef struct {-  int fd;-  dstype tp;-  int ipv6;-  int server;-  struct sockaddr_storage peer;-} *ds, s_ds;--#define DEFAULT_LISTENNING_QUEUE 5--typedef struct{-  int fd;-  int ipv6;-} *nethandler, s_nethandler;--typedef struct {-  dstype tp;-  void *original;-  SSL *s;-} *tlsDs, s_tlsDs;--nethandler getIPv4Port(const int port);-nethandler getPort(const int port);--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(ds, const char*, const char*, const char*);--int getPeer(ds, unsigned long*, unsigned char[16], int*);--int closeDs(ds);-void closeHandler(nethandler);-ds closeTls(tlsDs);--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);--int stdDsSend(const char[const], const int);-int stdDsRecv(char[], const int);--int getFd(ds);-int getTlsFd(tlsDs);-void closeFd(int);

@@ -3,14 +3,20 @@ module Base (simpleTest) where  import Distribution.TestSuite+import System.IO.Error  simpleTest :: String -> IO Progress -> Test simpleTest n t =    let test = TestInstance-        {run = t,+        {run = t',          name = n,          tags = [],          options = [],          setOption = \_ _ -> Right test         }   in Test test+  where+    t' :: IO Progress+    t' = catchIOError t (+      \e -> return . Finished . Fail $ "Raised exception: " ++ show e+      )

@@ -18,15 +18,11 @@ tests :: IO [Test] tests = return [   simpleTest "recieveLine"-  (successTimeout "A test\n" (S.recieveLine)),+  (successTimeout "A test\n" S.recieveLine),   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.lazyRecieveN 5))),   simpleTest "recieveTill"   (failTimeout "abcde" (restoreLine $ S.recieveTill "de"))   ]

@@ -4,12 +4,14 @@  import Distribution.TestSuite import Base (simpleTest)-import Control.Concurrent(forkIO) +import Control.Concurrent(forkIO)+import qualified System.IO as I import System.IO.Uniform import System.IO.Uniform.Network import System.IO.Uniform.File --import System.IO.Uniform.Std import System.IO.Uniform.ByteString+import System.IO.Uniform.HandlePair import System.Timeout (timeout) import qualified Data.ByteString.Char8 as C8 import Data.ByteString (ByteString)@@ -20,7 +22,8 @@   simpleTest "network" testNetwork,   simpleTest "file" testFile,   simpleTest "network TLS" testTls,-  simpleTest "byte string" testBS+  simpleTest "byte string" testBS,+  simpleTest "handle pair" testHandlePair   ]  testNetwork :: IO Progress@@ -102,3 +105,18 @@     countAndEcho io initial dt = do       uPut io dt       return $ initial + BS.length dt++testHandlePair :: IO Progress+testHandlePair = do+  let l = "abcde\n"+  h <- I.openFile "test/testHandles" I.WriteMode+  let s = fromHandles h h+  uPut s l+  uClose s+  h' <- I.openFile "test/testHandles" I.ReadMode+  let s' = fromHandles h' h'+  l' <- uRead s' 100+  uClose s'+  if l == l'+    then return . Finished $ Pass+    else return . Finished . Fail . C8.unpack $ l'

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:    1.1.1.0+version:    1.2.0.0  -- A short (one-line) description of the package. synopsis:   Uniform IO over files, network, anything.@@ -22,10 +22,10 @@     It also includes implementations for standard IO, files and     network IO, and easy to use TLS wrapping of network data,     with an extensible interface for user supplied instances.-+    .     Currently there's no support for TLS certificate verification.     That is planned to be added soon.-+    .     Requires a '-threaded' compiler switch.  @@ -60,7 +60,7 @@ cabal-version: >=1.10  Extra-Source-Files:-  src/System/IO/Uniform/ds.c+  cbits/ds.c  source-repository head   type:     git@@ -70,7 +70,7 @@ source-repository this   type:     git   location: https://sealgram.com/git/haskell/uniform-io-  tag:   1.1.1.0+  tag:   1.2.0.0  library   -- Modules exported by the library.@@ -80,6 +80,7 @@       System.IO.Uniform.File,       System.IO.Uniform.Std,       System.IO.Uniform.ByteString,+      System.IO.Uniform.HandlePair,       System.IO.Uniform.Streamline,       System.IO.Uniform.Streamline.Scanner @@ -96,17 +97,23 @@       ForeignFunctionInterface       InterruptibleFFI       EmptyDataDecls+      TypeFamilies+      FlexibleInstances+      UndecidableInstances      -- Other library packages from which modules are imported.   build-depends:-      base >=4.7 && <4.8,-      iproute >=1.4 && <2.0,-      bytestring >=0.10 && <1.0,-      network >=2.4 && <3.0,-      transformers >=0.3 && <1.0,-      word8 >=0.1 && <1.0,-      attoparsec >=0.13.0.1 && <1.0,-      data-default-class >= 0.0.1 && <1.0+      base >=4.8 && <4.9 ,+      iproute >=1.4,+      bytestring >=0.10,+      network >=2.4,+      transformers >=0.3,+      word8 >=0.1,+      attoparsec >=0.13.0.1,+      data-default-class >= 0.0.1,+      monad-control,+      transformers-base,+      interruptible      -- Directories containing source files.   hs-source-dirs: src@@ -114,10 +121,10 @@   -- Base language which the package is written in.   default-language: Haskell2010 -  include-dirs: src/System/IO/Uniform+  include-dirs: cbits   includes: ds.h   install-includes: ds.h-  C-Sources: src/System/IO/Uniform/ds.c+  C-Sources: cbits/ds.c   extra-libraries: ssl, crypto, pthread  Test-suite targets