|
@@ -4,7 +4,14 @@
|
|
|
{-# 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
|
|
|
+module System.IO.Uniform.Targets (
|
|
|
+ TlsSettings(..),
|
|
|
+ UniformIO(..),
|
|
|
+ SocketIO, FileIO, StdIO, TlsIO, SomeIO(..),
|
|
|
+ BoundedPort, connectTo, connectToHost, bindPort, accept, closePort,
|
|
|
+ openFile, getPeer,
|
|
|
+ mapOverInput)
|
|
|
+ where
|
|
|
|
|
|
import Foreign
|
|
|
import Foreign.C.Types
|
|
@@ -37,6 +44,8 @@ class UniformIO a where
|
|
|
|
|
|
|
|
|
|
|
|
+
|
|
|
+
|
|
|
uRead :: a -> Int -> IO ByteString
|
|
|
|
|
|
|
|
@@ -50,7 +59,7 @@ class UniformIO a where
|
|
|
|
|
|
|
|
|
|
|
|
- startTls :: TlsSettings -> a -> IO TlsStream
|
|
|
+ startTls :: TlsSettings -> a -> IO TlsIO
|
|
|
|
|
|
|
|
|
|
|
@@ -73,7 +82,7 @@ data Ds
|
|
|
newtype SocketIO = SocketIO {sock :: (Ptr Ds)}
|
|
|
newtype FileIO = FileIO {fd :: (Ptr Ds)}
|
|
|
data TlsDs
|
|
|
-newtype TlsStream = TlsStream {tls :: (Ptr TlsDs)}
|
|
|
+newtype TlsIO = TlsIO {tls :: (Ptr TlsDs)}
|
|
|
data StdIO
|
|
|
|
|
|
|
|
@@ -104,7 +113,7 @@ instance UniformIO SocketIO where
|
|
|
r <- c_startSockTls (sock s) cert key para
|
|
|
if r == nullPtr
|
|
|
then throwErrno "could not start TLS"
|
|
|
- else return . TlsStream $ r
|
|
|
+ else return . TlsIO $ r
|
|
|
)
|
|
|
)
|
|
|
)
|
|
@@ -129,7 +138,7 @@ instance UniformIO StdIO where
|
|
|
else return ()
|
|
|
)
|
|
|
uClose _ = return ()
|
|
|
- startTls _ _ = return . TlsStream $ nullPtr
|
|
|
+ startTls _ _ = return . TlsIO $ nullPtr
|
|
|
isSecure _ = False
|
|
|
|
|
|
|
|
@@ -154,12 +163,12 @@ instance UniformIO FileIO where
|
|
|
f <- Fd <$> c_prepareToClose (fd s)
|
|
|
closeFd f
|
|
|
|
|
|
- startTls _ _ = return . TlsStream $ nullPtr
|
|
|
+ startTls _ _ = return . TlsIO $ nullPtr
|
|
|
isSecure _ = False
|
|
|
|
|
|
|
|
|
|
|
|
-instance UniformIO TlsStream where
|
|
|
+instance UniformIO TlsIO where
|
|
|
uRead s n = do
|
|
|
allocaArray n (
|
|
|
\b -> do
|
|
@@ -290,6 +299,18 @@ closeFd (Fd f) = c_closeFd f
|
|
|
closePort :: BoundedPort -> IO ()
|
|
|
closePort p = c_closePort (lis p)
|
|
|
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+mapOverInput :: UniformIO io => io -> Int -> (a -> ByteString -> 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
|
|
|
+ Right dt -> mapOverInput io block f (f initial dt)
|
|
|
+
|
|
|
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)
|