|
@@ -21,7 +21,6 @@ import System.IO.Error
|
|
|
|
|
|
import Data.Default.Class
|
|
|
|
|
|
-import GHC.Conc (closeFdWith, threadWaitRead, threadWaitWrite)
|
|
|
import System.Posix.Types (Fd(..))
|
|
|
|
|
|
-- | Settings for starttls functions.
|
|
@@ -78,23 +77,25 @@ newtype TlsStream = TlsStream {tls :: (Ptr TlsDs)}
|
|
|
|
|
|
-- | UniformIO IP connections.
|
|
|
instance UniformIO SocketIO where
|
|
|
- uRead s n = 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 = BS.useAsCStringLen t (
|
|
|
- \(str, n) -> do
|
|
|
- count <- c_send (sock s) str $ fromIntegral n
|
|
|
- if count < 0
|
|
|
- then throwErrno "could not write"
|
|
|
- else return ()
|
|
|
- )
|
|
|
+ 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)
|
|
|
- closeFdWith closeFd f
|
|
|
+ closeFd f
|
|
|
startTls st s = withCString (tlsCertificateChainFile st) (
|
|
|
\cert -> withCString (tlsPrivateKeyFile st) (
|
|
|
\key -> withCString (tlsDHParametersFile st) (
|
|
@@ -110,23 +111,25 @@ instance UniformIO SocketIO where
|
|
|
|
|
|
-- | UniformIO type for file IO.
|
|
|
instance UniformIO FileIO where
|
|
|
- uRead s n = allocaArray n (
|
|
|
- \b -> do
|
|
|
- count <- c_recv (fd s) b $ fromIntegral n
|
|
|
- if count < 0
|
|
|
- then throwErrno "could not read"
|
|
|
- else BS.packCStringLen (b, fromIntegral count)
|
|
|
- )
|
|
|
- uPut s t = BS.useAsCStringLen t (
|
|
|
- \(str, n) -> do
|
|
|
- count <- c_send (fd s) str $ fromIntegral n
|
|
|
- if count < 0
|
|
|
- then throwErrno "could not write"
|
|
|
- else return ()
|
|
|
- )
|
|
|
+ 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)
|
|
|
- closeFdWith closeFd f
|
|
|
+ closeFd f
|
|
|
-- Not implemented yet.
|
|
|
startTls _ _ = return . TlsStream $ nullPtr
|
|
|
isSecure _ = False
|
|
@@ -134,24 +137,26 @@ instance UniformIO FileIO where
|
|
|
-- | 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 ()
|
|
|
- )
|
|
|
+ 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
|
|
|
- closeFdWith closeFd f
|
|
|
+ closeFd f
|
|
|
startTls _ s = return s
|
|
|
isSecure _ = True
|
|
|
|
|
@@ -271,7 +276,8 @@ foreign import ccall interruptible "createToIPv6Host" c_connect6 :: Ptr CUChar -
|
|
|
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 -> 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
|
|
@@ -279,9 +285,9 @@ 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 "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 "stdDsRecv" c_recvStd :: Ptr CChar -> CInt -> IO CInt
|
|
|
foreign import ccall interruptible "tlsDsRecv" c_recvTls :: Ptr TlsDs -> Ptr CChar -> CInt -> IO CInt
|