Initial version

.gitignore

@@ -0,0 +1,9 @@
+dist/
+.cabal-sandbox/
+cabal.sandbox.config
+*~
+*.[ao]
+**/*~
+**/*.[ao]
+
+

LICENSE

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

@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

src/System/IO/Uniform.hs

@@ -0,0 +1,3 @@
+module System.IO.Uniform (module System.IO.Uniform.Targets) where
+
+import System.IO.Uniform.Targets

src/System/IO/Uniform/Streamline.hs

@@ -0,0 +1,257 @@
+{-# 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.fRead (str cl) blockSize
+            liftIO $ BS.putStr "<"
+            liftIO $ BS.putStr l
+            return l
+          else liftIO $ S.fRead (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.fPut (str cl) l
+             else liftIO $ S.fPut (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.fClose 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.BoundPort -> 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.fClose 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

@@ -0,0 +1,263 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- |
+-- Filelike provides a typeclass for Unix style "everything is a file" IO,
+-- and implementations for abstracting standard IO, files and network connections.
+-- This module also provides TLS wraping over other filelike types.
+module System.IO.Uniform.Targets (TlsSettings(..), UniformIO(..), SocketIO, FileIO, TlsStream, BoundPort, 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 IO objects that behave like a Unix file (independent of seeking support).
+class UniformIO a where
+  -- | fRead fd n
+  --  Reads a block of at most n bytes of data from the filelike object fd.
+  --  Reading will block if there's no data available, but will return immediately
+  --  if any amount of data is availble.
+  fRead  :: a -> Int -> IO ByteString
+  -- | fPut fd text
+  --  Writes all the bytes of text into the filelike object. Takes care of retrying if needed.
+  fPut   :: a -> ByteString -> IO ()
+  -- | fClose fd
+  --  Closes the filelike object, releasing any allocated resource. Resources may leak if not called
+  --  for every oppened fd.
+  fClose :: a -> IO ()
+  -- | startTLS fd
+  --  Starts a TLS connection over the filelike object.
+  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
+  fRead (SomeIO s) n = fRead s n
+  fPut (SomeIO s) t  = fPut s t
+  fClose (SomeIO s) = fClose s
+  startTls set (SomeIO s) = startTls set s
+  isSecure (SomeIO s) = isSecure s
+
+data Nethandler
+-- | A bound IP port from where to accept SocketIO connections.
+newtype BoundPort = BoundPort {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
+  fRead 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)
+    )
+  fPut 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 ()
+    )
+  fClose 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
+  fRead 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)
+    )
+  fPut 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 ()
+    )
+  fClose s = c_closeFile (fd s)
+  -- Not implemented yet.
+  startTls _ _ = return . TlsStream $ nullPtr
+  isSecure _ = False
+  
+-- | UniformIO wrapper that applies TLS to communication on filelike objects.
+instance UniformIO TlsStream where
+  fRead 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)
+    )
+  fPut 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 ()
+    )
+  fClose 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 bound, a process can reduce its privileges and still accept clients on that port.
+bindPort :: Int -> IO BoundPort
+bindPort port = do
+  r <- fmap BoundPort $ 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 :: BoundPort -> 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 BoundPort, and releases any resource used by it.
+closePort :: BoundPort -> 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

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

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

@@ -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:   http://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