packages feed

uniform-io (empty) → 0.1.0.0

raw patch · 8 files changed

+1023/−0 lines, 8 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, data-default-class, iproute, network, transformers, word8

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Marcos Dumay de Medeiros++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ src/System/IO/Uniform.hs view
@@ -0,0 +1,8 @@+-- |+-- Uniform-IO provides a typeclass for uniform access of different types of targets,+-- and implementations for abstracting standard streams, files and network connections.+-- This module also provides TLS wraping over other IO targets.+module System.IO.Uniform (module System.IO.Uniform.Targets) where+++import System.IO.Uniform.Targets
+ src/System/IO/Uniform/Streamline.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Streamline exports a monad that, given an uniform IO target, emulates+-- character tream IO using high performance block IO.+module System.IO.Uniform.Streamline (Streamline, withClient, withServer, withTarget, send, receiveLine, lazyRecieveLine, lazyReceiveN, startTls, runAttoparsec, runAttoparsecAndReturn, isSecure, setTimeout, setEcho) where++import qualified System.IO.Uniform as S+import System.IO.Uniform (UniformIO, SomeIO(..), TlsSettings)++import Control.Monad.Trans.Class+import Control.Applicative+import Control.Monad (ap)+import Control.Monad.IO.Class+import System.IO.Error+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Char (ord)+import Data.Word8 (Word8)+import Data.IP (IP)++import qualified Data.Attoparsec.ByteString as A++data Data = Data {str :: SomeIO, timeout :: Int, buff :: ByteString, isEOF :: Bool, echo :: Bool}+-- | Monad that emulates character stream IO over block IO.+newtype Streamline m a = Streamline {withTarget' :: Data -> m (a, Data)}++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++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++-- | withServer f serverIP port+--+--  Connects to the given server port, runs f, and closes the connection.+withServer :: MonadIO m => Streamline m a -> IP -> Int -> m a+withServer f host port = do+  ds <- liftIO $ S.connectTo host port+  (ret, _) <- withTarget' f $ Data (SomeIO ds) defaultTimeout "" False False+  liftIO $ S.uClose ds+  return ret++-- | withClient f boundPort+--+--  Accepts a connection at the bound port, runs f and closes the connection.+withClient :: MonadIO m => (IP -> Int -> Streamline m a) -> S.BoundedPort -> m a+withClient f port = do+  ds <- liftIO $ S.accept port+  (peerIp, peerPort) <- liftIO $ S.getPeer ds+  (ret, _) <- withTarget' (f peerIp peerPort) $ Data (SomeIO ds) defaultTimeout "" False False+  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) => Streamline m b -> a -> m b+withTarget f s = do  +  (ret, _) <- withTarget' f $ Data (SomeIO s) defaultTimeout "" False False+  return ret++instance Monad m => Monad (Streamline m) where+  --return :: (Monad m) => a -> Streamline m a+  return x = Streamline  $ \cl -> return (x, cl)+  --(>>=) :: Monad m => Streamline m a -> (a -> Streamline m b) -> Streamline m b+  a >>= b = Streamline $ \cl -> do+    (x, cl') <- withTarget' a cl+    withTarget' (b x) cl'++instance Monad m => Functor (Streamline m) where+  --fmap :: (a -> b) -> Streamline m a -> Streamline m b+  fmap f m = Streamline $ \cl -> do+    (x, cl') <- withTarget' m cl+    return (f x, cl')++instance (Functor m, Monad m) => Applicative (Streamline m) where+    pure = return+    (<*>) = ap++instance MonadTrans Streamline where+  --lift :: Monad m => m a -> Streamline m a+  lift x = Streamline $ \cl -> do+    a <- x+    return (a, cl)++instance MonadIO m => MonadIO (Streamline m) where+  liftIO = lift . liftIO++-- | Sends data over the streamlines an IO target.+send :: MonadIO m => ByteString -> Streamline m ()+send r = Streamline $ \cl -> do+  writeF cl r+  return ((), cl)++-- | Receives a line from the streamlined IO target.+receiveLine :: MonadIO m => Streamline m ByteString+receiveLine = do+  l <- runAttoparsec parseLine+  case l of+    Left _ -> return ""+    Right l' -> return l'+    +-- | Receives a line from the streamlined IO target,+--  but breaks the line on reasonably sized chuncks, and+--  reads them lazyly, so that IO can be done in constant+--  memory space.+lazyRecieveLine :: MonadIO m => Streamline m [ByteString]+lazyRecieveLine = Streamline $ \cl -> lazyReceiveLine' cl+  where+    lazyReceiveLine' :: MonadIO m => Data -> m ([ByteString], Data)+    lazyReceiveLine' cl' = +      if isEOF cl'+      then eofError "System.IO.Uniform.Streamline.lazyReceiveLine"+      else+        if BS.null $ buff cl'+        then do+          dt <- readF cl'+          lazyReceiveLine' 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'') <- lazyReceiveLine' cl'{buff=l'}{isEOF=BS.null l'}+              return ((buff cl') : ret, cl'')+            Right (ret, dt) -> return ([ret], cl'{buff=dt})++-- | lazyReceiveN n+--  Receives n bytes of data from the streamlined IO target,+--  but breaks the data on reasonably sized chuncks, and reads+--  them lazyly, so that IO can be done in constant memory space.+lazyReceiveN :: (Functor m, MonadIO m) => Int -> Streamline m [ByteString]+lazyReceiveN n' = Streamline $ \cl' -> lazyReceiveN' cl' n'+  where+    lazyReceiveN' :: (Functor m, MonadIO m) => Data -> Int -> m ([ByteString], Data)+    lazyReceiveN' cl n =+      if isEOF cl+      then eofError "System.IO.Uniform.Streamline.lazyReceiveN"+      else+        if BS.null (buff cl)+        then do+          b <- readF cl+          let eof = BS.null b+          let cl' = cl{buff=b}{isEOF=eof}+          lazyReceiveN' 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) $ lazyReceiveN' cl' (n - BS.length b)+    appFst :: a -> ([a], b) -> ([a], b)+    appFst a (l, b) = (a:l, b)++-- | Wraps the streamlined IO target on TLS, streamlining+--  the new wrapper afterwads.+startTls :: MonadIO m => TlsSettings -> Streamline m ()+startTls st = Streamline $ \cl -> do    +  ds' <- liftIO $ S.startTls st $ str cl+  return ((), cl{str=SomeIO ds'}{buff=""})++-- | Runs an Attoparsec parser over the data read from the+--  streamlined IO target. Returns both the parser+--  result and the string consumed by it.+runAttoparsecAndReturn :: MonadIO m => A.Parser a -> Streamline m (ByteString, Either String a)+runAttoparsecAndReturn p = Streamline $ \cl ->+  if isEOF cl+  then eofError "System.IO.Uniform.Streamline.runAttoparsecAndReturn"+  else do+    let c = A.parse p $ buff cl+    (cl', i, a) <- liftIO $ continueResult cl c+    return ((i, a), cl')+  where+    continueResult :: Data -> A.Result a -> IO (Data, 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)+      A.Done i r -> return (cl{buff=i}, BS.take (BS.length (buff cl) - BS.length i) (buff cl), Right r)+      A.Partial c' -> do+        d <- readF cl+        let cl' = cl{buff=BS.append (buff cl) d}{isEOF=BS.null d}+        continueResult cl' (c' d)++-- | Runs an Attoparsec parser over the data read from the+--  streamlined IO target. Returning the parser result.+runAttoparsec :: MonadIO m => A.Parser a -> Streamline m (Either String a)+runAttoparsec p = Streamline $ \cl -> +  if isEOF cl+  then eofError "System.IO.Uniform.Streamline.runAttoparsec"+  else do+    let c = A.parse p $ buff cl+    (cl', a) <- liftIO $ continueResult cl c+    return (a, cl')+  where+    continueResult :: Data -> A.Result a -> IO (Data, (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)+        A.Partial c' -> do+          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)++-- | Sets the timeout for the streamlined IO target.+setTimeout :: Monad m => Int -> Streamline m ()+setTimeout t = Streamline $ \cl -> return ((), cl{timeout=t})++-- | Sets echo of the streamlines IO target.+--   If echo is set, all the data read an written to the target+--   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})++parseLine :: A.Parser ByteString+parseLine = do+  l <- A.takeTill isEol+  (A.string "\r\n" <|> A.string "\n")+  return l+  +lineWithEol :: A.Parser (ByteString, ByteString)+lineWithEol = do+  l <- A.scan False lineScanner+  r <- A.takeByteString+  return (l, r)+  +lineScanner :: Bool -> Word8 -> Maybe Bool+lineScanner False c = Just $ isEol c+lineScanner True c = if isEol c then Just True else Nothing++isEol :: Word8 -> Bool+isEol c = elem c (map (fromIntegral . ord) "\r\n")++eofError :: MonadIO m => String -> m a+eofError msg = liftIO . ioError $ mkIOError eofErrorType msg Nothing Nothing
+ src/System/IO/Uniform/Targets.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module System.IO.Uniform.Targets (TlsSettings(..), UniformIO(..), SocketIO, FileIO, TlsStream, BoundedPort, SomeIO(..), connectTo, connectToHost, bindPort, accept, openFile, getPeer, closePort) where++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.List as L+import Control.Exception+import qualified Network.Socket as Soc+import System.IO.Error++import Data.Default.Class++-- | Settings for starttls functions.+data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String} deriving (Read, Show)++instance Default TlsSettings where+  def = TlsSettings "" ""++-- |+-- Typeclass for uniform IO targets.+class UniformIO a where+  -- | uRead fd n+  --+  --  Reads a block of at most n bytes of data from the IO target.+  --  Reading will block if there's no data available, but will return immediately+  --  if any amount of data is availble.+  uRead  :: a -> Int -> IO ByteString+  -- | uPut fd text+  --+  --  Writes all the bytes of text into the IO target. Takes care of retrying if needed.+  uPut   :: a -> ByteString -> IO ()+  -- | fClose fd+  --+  --  Closes the IO target, releasing any allocated resource. Resources may leak if not called+  --  for every oppened fd.+  uClose :: a -> IO ()+  -- | startTLS fd+  --+  --  Starts a TLS connection over the IO target.+  startTls :: TlsSettings -> a -> IO TlsStream+  -- | isSecure fd+  --+  --  Indicates whether the data written or read from fd is secure at transport.+  isSecure :: a -> Bool+  +-- | A type that wraps any type in the UniformIO class.+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+  uClose (SomeIO s) = uClose s+  startTls set (SomeIO s) = startTls set s+  isSecure (SomeIO s) = isSecure s++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 TlsDs+newtype TlsStream = TlsStream {tls :: (Ptr TlsDs)}++-- | 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)+  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+      )+    )+  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)+  -- Not implemented yet.+  startTls _ _ = return . TlsStream $ nullPtr+  isSecure _ = False+  +-- | 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)+  startTls _ s = return s+  isSecure _ = True++-- | connectToHost hostName port+--+--  Connects to the given host and port.+connectToHost :: String -> Int -> IO SocketIO+connectToHost host port = do+  ip <- getAddr+  connectTo ip port+  where+    getAddr :: IO IP.IP+    getAddr = do+      add <- Soc.getAddrInfo Nothing (Just host) Nothing+      case add of+        [] -> throwIO $ mkIOError doesNotExistErrorType "host not found" Nothing Nothing+        (a:_) -> case Soc.addrAddress a of+          Soc.SockAddrInet _ a'  -> return . IP.IPv4 . IP.fromHostAddress $ a'+          Soc.SockAddrInet6 _ _ a' _ -> return . IP.IPv6 . IP.fromHostAddress6 $ a'+          _ -> throwIO $ mkIOError doesNotExistErrorType "host not found" Nothing Nothing+++-- | ConnecctTo ipAddress port+--+--  Connects to the given port of the host at the given IP address.+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') (+      \add -> c_connect6 add (fromIntegral port)+      )+  if sock r == nullPtr+    then throwErrno "could not connect to host"+    else return r+  where+    ipToArray :: IP.IPv6 -> [CUChar]+    ipToArray ip = let+      (w0, w1, w2, w3) = IP.toHostAddress6 ip+      in L.concat [wtoc w0, wtoc w1, wtoc w2, wtoc w3]+    wtoc :: Word32 -> [CUChar]+    wtoc w = let+      c0 = fromIntegral $ mod w 256+      w1 = div w 256+      c1 = fromIntegral $ mod w1 256+      w2 = div w1 256+      c2 = fromIntegral $ mod w2 256+      c3 = fromIntegral $ div w2 256+      in [c3, c2, c1, c0]+  +-- | bindPort port+--  Binds to the given IP port, becoming ready to accept connections on it.+--  Binding to port numbers under 1024 will fail unless performed by the superuser,+--  once bounded, a process can reduce its privileges and still accept clients on that port.+bindPort :: Int -> IO BoundedPort+bindPort port = do+  r <- fmap BoundedPort $ c_getPort $ fromIntegral port+  if lis r == nullPtr+    then throwErrno "could not bind to port"+    else return r+  +-- | accept port+--+--  Accept clients on a port previously bound with bindPort.+accept :: BoundedPort -> IO SocketIO+accept port = do+  r <- fmap SocketIO $ c_accept (lis port)+  if sock r == nullPtr+    then throwErrno "could not accept connection"+    else return r+  +-- | Open a file for bidirectional IO.+openFile :: String -> IO FileIO+openFile fileName = do+  r <- withCString fileName (+    \f -> fmap FileIO $ c_createFile f+    )+  if fd r == nullPtr+    then throwErrno "could not open file"+    else return r++-- | Gets the address of the peer socket of a internet connection.+getPeer :: SocketIO -> IO (IP.IP, Int)+getPeer s = allocaArray 16 (+  \p6 -> alloca (+    \p4 -> alloca (+      \iptype -> do+        p <- c_getPeer (sock s) p4 p6 iptype+        if p == -1+          then throwErrno "could not get peer address"+          else do+          iptp <- peek iptype+          if iptp == 1+            then do --IPv6+            add <- peekArray 16 p6+            return (IP.IPv6 . IP.toIPv6b $ map fromIntegral add, fromIntegral p)+            else do --IPv4+            add <- peek p4+            return (IP.IPv4 . IP.fromHostAddress . fromIntegral $ add, fromIntegral p)+      )+    )+  )+    +-- | Closes a BoundedPort, and releases any resource used by it.+closePort :: BoundedPort -> IO ()+closePort p = c_closePort (lis p)++foreign import ccall "getPort" c_getPort :: CInt -> IO (Ptr Nethandler)+foreign import ccall "createFromHandler" c_accept :: Ptr Nethandler -> IO (Ptr SockDs)+foreign import ccall "createFromFileName" c_createFile :: CString -> IO (Ptr FileDs)+foreign import ccall "createToIPv4Host" c_connect4 :: CUInt -> CInt -> IO (Ptr SockDs)+foreign import ccall "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr SockDs)++foreign import ccall "startSockTls" c_startSockTls :: Ptr SockDs -> CString -> CString -> IO (Ptr TlsDs)+foreign import ccall "getPeer" c_getPeer :: Ptr SockDs -> Ptr CUInt -> Ptr CUChar -> Ptr CInt -> IO (CInt)++foreign import ccall "closeSockDs" c_closeSock :: Ptr SockDs -> IO ()+foreign import ccall "closeFileDs" c_closeFile :: Ptr FileDs -> IO ()+foreign import ccall "closeHandler" c_closePort :: Ptr Nethandler -> IO ()+foreign import ccall "closeTlsDs" c_closeTls :: Ptr TlsDs -> IO ()++foreign import ccall "fileDsSend" c_sendFile :: Ptr FileDs -> Ptr CChar -> CInt -> IO CInt+foreign import ccall "sockDsSend" c_sendSock :: Ptr SockDs -> Ptr CChar -> CInt -> IO CInt+foreign import ccall "tlsDsSend" c_sendTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt++foreign import ccall "fileDsRecv" c_recvFile :: Ptr FileDs -> Ptr CChar -> CInt -> IO CInt+foreign import ccall "sockDsRecv" c_recvSock :: Ptr SockDs -> Ptr CChar -> CInt -> IO CInt+foreign import ccall "tlsDsRecv" c_recvTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt
+ src/System/IO/Uniform/ds.c view
@@ -0,0 +1,285 @@+#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 "ds.h"++int openSslLoaded = 0;++void *clear(void *ptr){+  int e = errno;+  if(ptr){+    free(ptr);+  }+  errno = e;+  return NULL;+}++void loadOpenSSL(){+  if(!openSslLoaded){+    openSslLoaded = 1;+    SSL_load_error_strings();+    ERR_load_BIO_strings();+    ERR_load_crypto_strings();+    SSL_library_init();+    OpenSSL_add_all_algorithms();+  }+}++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->s = socket(AF_INET6, SOCK_STREAM, 0);+  }else{+    h->s = socket(AF_INET, SOCK_STREAM, 0);+  }+  int optval = 1;+  setsockopt(h->s, 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));+  }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));+  }+  if(e)+    return clear(h);+  e = listen(h->s, 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);+}++fileDs createFromFile(int f){+  fileDs d = (fileDs)malloc(sizeof(s_fileDs));+  d->f = f;+  return d;+}++fileDs createFromFileName(const char *f){+  int fd = open(f, O_CREAT | O_RDWR);+  if(fd == -1){+    return NULL;+  }+  return createFromFile(fd);+}++sockDs createFromHandler(nethandler h){+  sockDs d = (sockDs)malloc(sizeof(s_sockDs));+  unsigned int s = sizeof(d->peer);+  d->s = accept(h->s, (struct sockaddr*)&(d->peer), &s);+  if(d->s <= 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));+  if(ipv6){+    d->s = socket(AF_INET6, SOCK_STREAM, 0);+  }else{+    d->s = socket(AF_INET, SOCK_STREAM, 0);+  }+  if(connect(d->s, add, add_size) < 0){+    int e = errno;+    free(d);+    errno = e;+    return NULL;+  }+  d->server = 0;+  return d;+}++sockDs 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);+}++sockDs 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(sockDs 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)){+    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 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 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 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 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);+}+++void closeFileDs(fileDs d){+  close(d->f);+  free(d);+}+void closeSockDs(sockDs d){+  close(d->s);+  free(d);+}++void closeTlsDs(tlsDs d){+  SSL_shutdown(d->s);+  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);+}++void closeHandler(nethandler h){+  close(h->s);+  free(h);+}++tlsDs startSockTls(sockDs d, const char *cert, const char *key){+  loadOpenSSL();+  SSL_CTX * ctx = NULL;+  if(d->server)+    ctx = SSL_CTX_new(TLSv1_server_method());+  else+    ctx = SSL_CTX_new(TLSv1_client_method());+  if(!ctx)+    return NULL;+  SSL_CTX_set_options(ctx, SSL_OP_SINGLE_DH_USE);+  if(cert)+    if(SSL_CTX_use_certificate_chain_file(ctx, cert) != 1){+      closeSockDs(d);+      return clear(ctx);+    }+  if(key)+    if(SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) != 1){+      closeSockDs(d);+      return clear(ctx);+    }+  tlsDs t = (tlsDs)malloc(sizeof(s_tlsDs));+  t->original = d;+  if(!(t->s = SSL_new(ctx))){+    closeSockDs(d);+    clear(ctx);+    return clear(t);+  }+  if(!SSL_set_fd(t->s, d->s)){+    closeTlsDs(t);+    return NULL;+  }+  printf("Starting handshake\n");+  int retry = 1;+  int e;+  while(retry){+    retry = 0;+    if(d->server)+      e = SSL_accept(t->s);+    else+      e = SSL_connect(t->s);+    if(e <= 0){+      retry = 1;+      int erval = SSL_get_error(t->s, e);+      if((erval == SSL_ERROR_WANT_READ) || (erval == SSL_ERROR_WANT_WRITE)){+	+      }else{+	printf("Error\n");+	ERR_print_errors(t->s->bbio);+	closeTlsDs(t);+	return NULL;+      }+    }+  }+  printf("Success\n");+  return t;+}
+ src/System/IO/Uniform/ds.h view
@@ -0,0 +1,62 @@+#include <sys/types.h>+#include <netinet/in.h>+#include <openssl/ssl.h>++typedef struct {+  int s;+  int ipv6;+  int server;+  struct sockaddr_storage peer;+} *sockDs, s_sockDs;++typedef struct {+  int f;+} *fileDs, s_fileDs;++#define DEFAULT_LISTENNING_QUEUE 5++typedef struct{+  int s;+  int ipv6;+} *nethandler, s_nethandler;++typedef enum {+  file, sock+} dstype;++typedef struct {+  dstype tp;+  void *original;+  SSL *s;+} *tlsDs, s_tlsDs;++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);++tlsDs startSockTls(sockDs, const char*, const char*);++int getPeer(sockDs, unsigned long*, unsigned char[16], int*);++void closeSockDs(sockDs);+void closeFileDs(fileDs);+void closeHandler(nethandler);+void closeTlsDs(tlsDs);++int fileDsSend(fileDs, const char[const], const int);+int fileDsRecv(fileDs, char[], const int);++int sockDsSend(sockDs, const char[const], const int);+int sockDsRecv(sockDs, 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);+
+ uniform-io.cabal view
@@ -0,0 +1,114 @@+-- Initial filelike.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                uniform-io++-- 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.1.0.0++-- A short (one-line) description of the package.+synopsis:   Uniform IO over files, network, watever.++-- A longer description of the package.+description:+    This library defines a typeclass for abstracting+    the differences between the several IO channels available.+    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.++    Requires a '-threaded' compiler switch.+++-- URL for the project homepage or repository.+homepage:   https://sealgram.com/git/haskell/uniform-io++-- The license under which the package is released.+license:    MIT++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author:     Marcos Dumay de Medeiros++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: marcos@marcosdumay.com++-- A copyright notice.+-- copyright:           ++category:   System++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10++Extra-Source-Files:+  src/System/IO/Uniform/ds.c++source-repository head+  type:     git+  location: https://sealgram.com/git/haskell/uniform-io+  branch:   master++source-repository this+  type:     git+  location: https://sealgram.com/git/haskell/uniform-io+  tag:   0.1.0.0++library+  -- Modules exported by the library.+  exposed-modules:+      System.IO.Uniform,+      System.IO.Uniform.Streamline++  ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns++  -- Modules included in this library but not exported.+  other-modules:       +        System.IO.Uniform.Targets++  -- LANGUAGE extensions used by modules in this package.+  other-extensions:+      OverloadedStrings,+      ExistentialQuantification,+      ForeignFunctionInterface+  +  -- Other library packages from which modules are imported.+  build-depends:+      base >=4.7 && <5.0,+      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.10 && <1.0,+      data-default-class >= 0.0.1 && <1.0+  +  -- Directories containing source files.+  hs-source-dirs: src+  +  -- Base language which the package is written in.+  default-language: Haskell2010++  include-dirs: src/System/IO/Uniform+  includes: ds.h+  install-includes: ds.h+  C-Sources: src/System/IO/Uniform/ds.c+  extra-libraries: ssl