uniform-io 0.2.0.0 → 1.0.0.0

raw patch · 11 files changed

+623/−371 lines, 11 filesdep ~iproutedep ~uniform-ioPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: iproute, uniform-io

API changes (from Hackage documentation)

Files

• src/System/IO/Uniform.hs +119/−2
• src/System/IO/Uniform/ByteString.hs +74/−0
• src/System/IO/Uniform/External.hs +54/−0
• src/System/IO/Uniform/File.hs +72/−0
• src/System/IO/Uniform/Network.hs +166/−0
• src/System/IO/Uniform/Std.hs +54/−0
• src/System/IO/Uniform/Streamline.hs +5/−4
• src/System/IO/Uniform/Targets.hs +0/−316
• test/Blocking.hs +5/−5
• test/Targets.hs +59/−35
• uniform-io.cabal +15/−9

@@ -1,8 +1,125 @@+{-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE ForeignFunctionInterface #-}+-- {-# LANGUAGE InterruptibleFFI #-}+-- {-# LANGUAGE EmptyDataDecls #-}+ -- | -- 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+module System.IO.Uniform (+  UniformIO(..),+  TlsSettings(..),+  SomeIO(..), TlsIO,+  mapOverInput+  ) where +import System.IO.Uniform.External -import System.IO.Uniform.Targets+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 System.Posix.Types (Fd(..))++-- |+-- 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.+  --+  --  Must thow System.IO.Error.EOFError if reading beihond EOF.+  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 TlsIO+  -- | 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++-- | Settings for starttls functions.+data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String, tlsDHParametersFile :: String} deriving (Read, Show)++instance Default TlsSettings where+  def = TlsSettings "" "" ""+  +-- | UniformIO wrapper that applies TLS to communication on IO target.+-- This type is constructed by calling startTls on other targets.+instance UniformIO TlsIO where+  uRead s n = do+    allocaArray n (+      \b -> do+        count <- c_recvTls (tls s) b $ fromIntegral n+        if count < 0+          then throwErrno "could not read"+          else BS.packCStringLen (b, fromIntegral count)+      )+  uPut s t = do+    BS.useAsCStringLen t (+      \(str, n) -> do+        count <- c_sendTls (tls s) str $ fromIntegral n+        if count < 0+          then throwErrno "could not write"+          else return ()+      )+  uClose s = do+    d <- c_closeTls (tls s)+    f <- Fd <$> c_prepareToClose d+    closeFd f+  startTls _ s = return s+  isSecure _ = True+++-- | mapOverInput io block_size f initial+--   Reads io untill the end of file, evaluating a(i) <- f a(i-1) read_data+--   where a(0) = initial and the last value after io reaches EOF is returned.+--+--   Notice that the length of read_data might not be equal block_size.+mapOverInput :: forall a io. UniformIO io => io -> Int -> (a -> ByteString -> IO a) -> a -> IO a+mapOverInput io block f initial = do+  a <- tryIOError $ uRead io block+  case a of+    Left e -> if isEOFError e then return initial else throw e -- EOF+    Right dt -> do+      i <- f initial dt+      mapOverInput io block f i

@@ -0,0 +1,74 @@+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE ForeignFunctionInterface #-}+-- {-# LANGUAGE InterruptibleFFI #-}+-- {-# LANGUAGE EmptyDataDecls #-}++module System.IO.Uniform.ByteString (+  ByteStringIO,+  withByteStringIO, withByteStringIO'+  ) where++import System.IO.Uniform+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 System.Posix.Types (Fd(..))++-- | Wrapper that does UniformIO that reads and writes on the memory.+data ByteStringIO = ByteStringIO {bsioinput :: MVar (ByteString, Bool), bsiooutput :: MVar BSBuild.Builder}+instance UniformIO ByteStringIO where+  uRead s n = do+    (i, eof) <- takeMVar . bsioinput $ s+    if eof+    then do+      putMVar (bsioinput s) (i, eof)+      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)+      putMVar (bsioinput s) (i', eof')+      return r+  uPut s t = do+    o <- takeMVar . bsiooutput $ s+    let o' = mappend o $ BSBuild.byteString t+    putMVar (bsiooutput s) o'+  uClose _ = return ()+  startTls _ _ = return . TlsIO $ nullPtr+  isSecure _ = True++-- | withByteStringIO input f+--   Runs f with a ByteStringIO that has the given input, returns f's output and+--   the ByteStringIO output.+withByteStringIO :: ByteString -> (ByteStringIO -> IO a) -> IO (a, LBS.ByteString)+withByteStringIO input f = do+  ivar <- newMVar (input, False)+  ovar <- newMVar . BSBuild.byteString $ BS.empty+  let bsio = ByteStringIO ivar ovar+  a <- f bsio+  out <- takeMVar . bsiooutput $ bsio+  return (a, BSBuild.toLazyByteString out)++-- | The same as withByteStringIO, but returns an strict ByteString+withByteStringIO' :: ByteString -> (ByteStringIO -> IO a) -> IO (a, ByteString)+withByteStringIO' input f = do+  (a, t) <- withByteStringIO input f+  return (a, LBS.toStrict t)

@@ -0,0 +1,54 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE EmptyDataDecls #-}++module System.IO.Uniform.External where++import Foreign+import Foreign.C.Types+import Foreign.C.String++import System.Posix.Types (Fd(..))++data Nethandler+-- | A bounded IP port from where to accept SocketIO connections.+newtype BoundedPort = BoundedPort {lis :: (Ptr Nethandler)}+data Ds+newtype SocketIO = SocketIO {sock :: (Ptr Ds)}+newtype FileIO = FileIO {fd :: (Ptr Ds)}+data TlsDs+newtype TlsIO = TlsIO {tls :: (Ptr TlsDs)}+data StdIO++closeFd :: Fd -> IO ()+closeFd (Fd f) = c_closeFd f+            +-- | Closes a BoundedPort, and releases any resource used by it.+closePort :: BoundedPort -> IO ()+closePort p = c_closePort (lis p)+++foreign import ccall interruptible "getPort" c_getPort :: CInt -> IO (Ptr Nethandler)+foreign import ccall interruptible "createFromHandler" c_accept :: Ptr Nethandler -> IO (Ptr Ds)+foreign import ccall safe "createFromFileName" c_createFile :: CString -> IO (Ptr Ds)+foreign import ccall interruptible "createToIPv4Host" c_connect4 :: CUInt -> CInt -> IO (Ptr Ds)+foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr Ds)++foreign import ccall 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 "getFd" c_getFd :: Ptr Ds -> IO CInt+--foreign import ccall safe "getTlsFd" c_getTlsFd :: Ptr TlsDs -> IO CInt+foreign import ccall safe "closeFd" c_closeFd :: CInt -> IO ()++foreign import ccall safe "prepareToClose" c_prepareToClose :: Ptr Ds -> IO CInt+foreign import ccall safe "closeHandler" c_closePort :: Ptr Nethandler -> IO ()+foreign import ccall safe "closeTls" c_closeTls :: Ptr TlsDs -> IO (Ptr Ds)++foreign import ccall interruptible "sendDs" c_send :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt+foreign import ccall interruptible "stdDsSend" c_sendStd :: Ptr CChar -> CInt -> IO CInt+foreign import ccall interruptible "tlsDsSend" c_sendTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt++foreign import ccall interruptible "recvDs" c_recv :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt+foreign import ccall interruptible "stdDsRecv" c_recvStd :: Ptr CChar -> CInt -> IO CInt+foreign import ccall interruptible "tlsDsRecv" c_recvTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt

@@ -0,0 +1,72 @@+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE ForeignFunctionInterface #-}+-- {-# LANGUAGE InterruptibleFFI #-}+-- {-# LANGUAGE EmptyDataDecls #-}++module System.IO.Uniform.File (+  FileIO,+  openFile+  ) where++import System.IO.Uniform+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 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 ()+      )+  uClose s = do+    f <- Fd <$> c_prepareToClose (fd s)+    closeFd f+  -- Not implemented yet.+  startTls _ _ = return . TlsIO $ nullPtr+  isSecure _ = False+  +  +-- | 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+

@@ -0,0 +1,166 @@+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE ForeignFunctionInterface #-}+-- {-# LANGUAGE InterruptibleFFI #-}+-- {-# LANGUAGE EmptyDataDecls #-}++module System.IO.Uniform.Network (+  SocketIO,+  BoundedPort,+  connectTo,+  connectToHost,+  bindPort,+  accept,+  closePort,+  getPeer+  ) where++import System.IO.Uniform+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 System.Posix.Types (Fd(..))++-- | UniformIO IP connections.+instance UniformIO SocketIO where+  uRead s n = do+    allocaArray n (+      \b -> do+        count <- c_recv (sock s) b (fromIntegral n)+        if count < 0+          then throwErrno "could not read"+          else BS.packCStringLen (b, fromIntegral count)+      )+  uPut s t = do+    BS.useAsCStringLen t (+      \(str, n) -> do+        count <- c_send (sock s) str $ fromIntegral n+        if count < 0+          then throwErrno "could not write"+          else return ()+      )+  uClose s = do+    f <- Fd <$> c_prepareToClose (sock s)+    closeFd f+  startTls st s = withCString (tlsCertificateChainFile st) (+    \cert -> withCString (tlsPrivateKeyFile st) (+      \key -> withCString (tlsDHParametersFile st) (+        \para -> do+          r <- c_startSockTls (sock s) cert key para+          if r == nullPtr+            then throwErrno "could not start TLS"+            else return . TlsIO $ r+        )+      )+    )+  isSecure _ = False+++-- | 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++-- | 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)+      )+    )+  )+

@@ -0,0 +1,54 @@+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE ForeignFunctionInterface #-}+-- {-# LANGUAGE InterruptibleFFI #-}+-- {-# LANGUAGE EmptyDataDecls #-}++module System.IO.Uniform.Std (+  StdIO+  ) where++import System.IO.Uniform+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 System.Posix.Types (Fd(..))+-- | 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 ()+      )+  uClose _ = return ()+  startTls _ _ = return . TlsIO $ nullPtr+  isSecure _ = False

@@ -6,6 +6,7 @@ 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 qualified System.IO.Uniform.Network as N import System.IO.Uniform (UniformIO, SomeIO(..), TlsSettings)  import Control.Monad.Trans.Class@@ -51,7 +52,7 @@ --  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+  ds <- liftIO $ N.connectTo host port   (ret, _) <- withTarget' f $ Data (SomeIO ds) defaultTimeout "" False False   liftIO $ S.uClose ds   return ret@@ -59,10 +60,10 @@ -- | 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 :: MonadIO m => (IP -> Int -> Streamline m a) -> N.BoundedPort -> m a withClient f port = do-  ds <- liftIO $ S.accept port-  (peerIp, peerPort) <- liftIO $ S.getPeer ds+  ds <- liftIO $ N.accept port+  (peerIp, peerPort) <- liftIO $ N.getPeer ds   (ret, _) <- withTarget' (f peerIp peerPort) $ Data (SomeIO ds) defaultTimeout "" False False   liftIO $ S.uClose ds   return ret

@@ -1,316 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE EmptyDataDecls #-}--module System.IO.Uniform.Targets (TlsSettings(..), UniformIO(..), SocketIO, FileIO, StdIO, TlsStream, BoundedPort, SomeIO(..), connectTo, connectToHost, bindPort, accept, openFile, getPeer, closePort) where--import Foreign-import Foreign.C.Types-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 Control.Applicative ((<$>))-import qualified Network.Socket as Soc-import System.IO.Error--import Data.Default.Class--import System.Posix.Types (Fd(..))---- | Settings for starttls functions.-data TlsSettings = TlsSettings {tlsPrivateKeyFile :: String, tlsCertificateChainFile :: String, tlsDHParametersFile :: 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 Ds-newtype SocketIO = SocketIO {sock :: (Ptr Ds)}-newtype FileIO = FileIO {fd :: (Ptr Ds)}-data TlsDs-newtype TlsStream = TlsStream {tls :: (Ptr TlsDs)}-data StdIO---- | UniformIO IP connections.-instance UniformIO SocketIO where-  uRead s n = do-    allocaArray n (-      \b -> do-        count <- c_recv (sock s) b (fromIntegral n)-        if count < 0-          then throwErrno "could not read"-          else BS.packCStringLen (b, fromIntegral count)-      )-  uPut s t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_send (sock s) str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )-  uClose s = do-    f <- Fd <$> c_prepareToClose (sock s)-    closeFd f-  startTls st s = withCString (tlsCertificateChainFile st) (-    \cert -> withCString (tlsPrivateKeyFile st) (-      \key -> withCString (tlsDHParametersFile st) (-        \para -> do-          r <- c_startSockTls (sock s) cert key para-          if r == nullPtr-            then throwErrno "could not start TLS"-            else return . TlsStream $ r-        )-      )-    )-  isSecure _ = False-  --- | UniformIO IP connections.-instance UniformIO StdIO where-  uRead _ n = do-    allocaArray n (-      \b -> do-        count <- c_recvStd b (fromIntegral n)-        if count < 0-          then throwErrno "could not read"-          else BS.packCStringLen (b, fromIntegral count)-      )-  uPut _ t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_sendStd str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )-  uClose _ = return ()-  startTls _ _ = return . TlsStream $ nullPtr-  isSecure _ = False-  --- | UniformIO type for file IO.-instance UniformIO FileIO where-  uRead s n = do-    allocaArray n (-      \b -> do-        count <- c_recv (fd s) b $ fromIntegral n-        if count < 0-          then throwErrno "could not read"-          else  BS.packCStringLen (b, fromIntegral count)-      )-  uPut s t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_send (fd s) str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )-  uClose s = do-    f <- Fd <$> c_prepareToClose (fd s)-    closeFd f-  -- Not implemented yet.-  startTls _ _ = return . TlsStream $ nullPtr-  isSecure _ = False-  --- | 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 = do-    allocaArray n (-      \b -> do-        count <- c_recvTls (tls s) b $ fromIntegral n-        if count < 0-          then throwErrno "could not read"-          else BS.packCStringLen (b, fromIntegral count)-      )-  uPut s t = do-    BS.useAsCStringLen t (-      \(str, n) -> do-        count <- c_sendTls (tls s) str $ fromIntegral n-        if count < 0-          then throwErrno "could not write"-          else return ()-      )-  uClose s = do-    d <- c_closeTls (tls s)-    f <- Fd <$> c_prepareToClose d-    closeFd f-  startTls _ s = return s-  isSecure _ = True---- | 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)-      )-    )-  )-    -closeFd :: Fd -> IO ()-closeFd (Fd f) = c_closeFd f-            --- | Closes a BoundedPort, and releases any resource used by it.-closePort :: BoundedPort -> IO ()-closePort p = c_closePort (lis p)--foreign import ccall interruptible "getPort" c_getPort :: CInt -> IO (Ptr Nethandler)-foreign import ccall interruptible "createFromHandler" c_accept :: Ptr Nethandler -> IO (Ptr Ds)-foreign import ccall safe "createFromFileName" c_createFile :: CString -> IO (Ptr Ds)-foreign import ccall interruptible "createToIPv4Host" c_connect4 :: CUInt -> CInt -> IO (Ptr Ds)-foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -> CInt -> IO (Ptr Ds)--foreign import ccall 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 "getFd" c_getFd :: Ptr Ds -> IO CInt---foreign import ccall safe "getTlsFd" c_getTlsFd :: Ptr TlsDs -> IO CInt-foreign import ccall safe "closeFd" c_closeFd :: CInt -> IO ()--foreign import ccall safe "prepareToClose" c_prepareToClose :: Ptr Ds -> IO CInt-foreign import ccall safe "closeHandler" c_closePort :: Ptr Nethandler -> IO ()-foreign import ccall safe "closeTls" c_closeTls :: Ptr TlsDs -> IO (Ptr Ds)--foreign import ccall interruptible "sendDs" c_send :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt-foreign import ccall interruptible "stdDsSend" c_sendStd :: Ptr CChar -> CInt -> IO CInt-foreign import ccall interruptible "tlsDsSend" c_sendTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt--foreign import ccall interruptible "recvDs" c_recv :: Ptr Ds -> Ptr CChar -> CInt -> IO CInt-foreign import ccall interruptible "stdDsRecv" c_recvStd :: Ptr CChar -> CInt -> IO CInt-foreign import ccall interruptible "tlsDsRecv" c_recvTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt

@@ -5,7 +5,7 @@ import Distribution.TestSuite import Base (simpleTest) import Control.Concurrent(forkIO) -import qualified System.IO.Uniform as U+import System.IO.Uniform.Network import qualified System.IO.Uniform.Streamline as S import System.Timeout (timeout) import Data.ByteString (ByteString)@@ -49,7 +49,7 @@ --   the command must not block. successTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress successTimeout txt f = do-  recv <- U.bindPort 8888+  recv <- bindPort 8888   forkIO $ S.withClient (\_ _ -> do                             l <- f                             S.send l@@ -62,7 +62,7 @@                                        then return . Finished $ Pass                                        else return . Finished . Fail . C8.unpack $ t                                  ) "127.0.0.1" 8888-  U.closePort recv+  closePort recv   case r' of     Just r -> return r     Nothing -> return . Finished . Fail $ "Execution blocked"@@ -71,7 +71,7 @@ --   Does not care about the result of the command, just wether it blocks. failTimeout :: ByteString -> S.Streamline IO ByteString -> IO Progress failTimeout txt f = do-  recv <- U.bindPort 8888+  recv <- bindPort 8888   forkIO $ S.withClient (\_ _ -> do                             f                             S.send "\n"@@ -82,7 +82,7 @@                                      S.receiveLine                                      return . Finished $ Pass                                  ) "127.0.0.1" 8888-  U.closePort recv+  closePort recv   case r' of     Just r -> return r     Nothing -> return . Finished . Fail $ "Execution blocked"

@@ -5,36 +5,43 @@ import Distribution.TestSuite import Base (simpleTest) import Control.Concurrent(forkIO) -import qualified System.IO.Uniform as U+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.Timeout (timeout) import qualified Data.ByteString.Char8 as C8+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS  tests :: IO [Test] tests = return [   simpleTest "network" testNetwork,   simpleTest "file" testFile,-  simpleTest "network TLS" testTls+  simpleTest "network TLS" testTls,+  simpleTest "byte string" testBS   ]  testNetwork :: IO Progress testNetwork = do-  recv <- U.bindPort 8888+  recv <- bindPort 8888   forkIO $ do-    s <- U.accept recv-    l <- U.uRead s 100-    U.uPut s l-    U.uClose s+    s <- accept recv+    l <- uRead s 100+    uPut s l+    uClose s     return ()   r' <- timeout 1000000 $ do-        s <- U.connectToHost "127.0.0.1" 8888-        let l = "abcdef\n"-        U.uPut s l-        l' <- U.uRead s 100-        U.uClose s-        if l == l'-          then return . Finished $ Pass-          else return . Finished . Fail . C8.unpack $ l'-  U.closePort recv+    s <- connectToHost "127.0.0.1" 8888+    let l = "abcdef\n"+    uPut s l+    l' <- uRead s 100+    uClose s+    if l == l'+      then return . Finished $ Pass+      else return . Finished . Fail . C8.unpack $ l'+  closePort recv   case r' of     Just r -> return r     Nothing -> return . Finished . Fail $ "Execution blocked"@@ -42,39 +49,56 @@ testFile :: IO Progress testFile = do   let file = "test/testFile"-  s <- U.openFile file+  s <- openFile file   let l = "abcde\n"-  U.uPut s l-  U.uClose s-  s' <- U.openFile file-  l' <- U.uRead s' 100-  U.uClose s'+  uPut s l+  uClose s+  s' <- openFile file+  l' <- uRead s' 100+  uClose s'   if l == l'     then return . Finished $ Pass     else return . Finished . Fail . C8.unpack $ l'  testTls :: IO Progress testTls = do-  recv <- U.bindPort 8888-  let set = U.TlsSettings "test/key.pem" "test/cert.pem" "test/dh.pem"+  recv <- bindPort 8888+  let set = TlsSettings "test/key.pem" "test/cert.pem" "test/dh.pem"   forkIO $ do-    s' <- U.accept recv-    s <- U.startTls set s'-    l <- U.uRead s 100-    U.uPut s l-    U.uClose s+    s' <- accept recv+    s <- startTls set s'+    l <- uRead s 100+    uPut s l+    uClose s     return ()   r' <- timeout 1000000 $ do-    s' <- U.connectToHost "127.0.0.1" 8888-    s <- U.startTls set s'+    s' <- connectToHost "127.0.0.1" 8888+    s <- startTls set s'     let l = "abcdef\n"-    U.uPut s l-    l' <- U.uRead s 100-    U.uClose s+    uPut s l+    l' <- uRead s 100+    uClose s     if l == l'       then return . Finished $ Pass       else return . Finished . Fail . C8.unpack $ l'-  U.closePort recv+  closePort recv   case r' of     Just r -> return r     Nothing -> return . Finished . Fail $ "Execution blocked"++testBS :: IO Progress+testBS = do+  let dt = "Some data to test ByteString"+  (len, echo) <- withByteStringIO' dt (+    \io -> let+      count = countAndEcho io :: Int -> ByteString -> IO Int+      in mapOverInput io 2 count 0+    ) :: IO (Int, ByteString)+  if dt /= echo || BS.length dt /= len+    then return . Finished . Fail $ "Failure on ByteStringIO test"+    else return . Finished $ Pass+  where+    countAndEcho :: UniformIO io => io -> Int -> ByteString -> IO Int+    countAndEcho io initial dt = do+      uPut io dt+      return $ initial + BS.length dt

@@ -10,10 +10,10 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:    0.2.0.0+version:    1.0.0.0  -- A short (one-line) description of the package.-synopsis:   Uniform IO over files, network, watever.+synopsis:   Uniform IO over files, network, anything.  -- A longer description of the package. description:@@ -70,19 +70,23 @@ source-repository this   type:     git   location: https://sealgram.com/git/haskell/uniform-io-  tag:   0.2.0.0+  tag:   1.0.0.0  library   -- Modules exported by the library.   exposed-modules:       System.IO.Uniform,+      System.IO.Uniform.Network,+      System.IO.Uniform.File,+      System.IO.Uniform.Std,+      System.IO.Uniform.ByteString,       System.IO.Uniform.Streamline -  ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns+  ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -fno-warn-orphans    -- Modules included in this library but not exported.-  other-modules:       -        System.IO.Uniform.Targets+  other-modules:+      System.IO.Uniform.External    -- LANGUAGE extensions used by modules in this package.   other-extensions:@@ -111,7 +115,7 @@   includes: ds.h   install-includes: ds.h   C-Sources: src/System/IO/Uniform/ds.c-  extra-libraries: ssl, pthread+  extra-libraries: ssl, crypto, pthread  Test-suite targets   type: detailed-0.9@@ -122,8 +126,9 @@     base >=4.7 && <5.0,     Cabal >= 1.9.2,     bytestring >=0.10 && <1.0,-    uniform-io == 0.2.0.0+    uniform-io == 1.0.0.0   ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded+  default-language: Haskell2010  Test-suite blocking   type: detailed-0.9@@ -135,5 +140,6 @@     Cabal >= 1.9.2,     bytestring >=0.10 && <1.0,     attoparsec >=0.10 && <1.0,-    uniform-io == 0.2.0.0+    uniform-io == 1.0.0.0   ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded+  default-language: Haskell2010