module System.IO.Streams.TLS (
connect
, withConnection
, accept
, tlsToStreams
, closeTLS
) where
import qualified Control.Exception as E
import Control.Monad (void)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Lazy (fromStrict)
import Network.Socket (HostName, PortNumber, Socket)
import qualified Network.Socket as N
import Network.TLS (ClientParams, Context, ServerParams)
import qualified Network.TLS as TLS
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Stream
import qualified System.IO.Streams.TCP as TCP
tlsToStreams :: Context
-> IO (InputStream ByteString, OutputStream ByteString)
tlsToStreams ctx = do
is <- Stream.makeInputStream input
os <- Stream.makeOutputStream output
return (is, os)
where
input = do
s <- TLS.recvData ctx
return $! if B.null s then Nothing else Just s
output Nothing = return ()
output (Just s) = TLS.sendData ctx (fromStrict s)
closeTLS :: Context -> IO ()
closeTLS ctx = TLS.bye ctx >> TLS.contextClose ctx
connect :: ClientParams
-> Maybe String
-> HostName
-> PortNumber
-> IO (InputStream ByteString, OutputStream ByteString, Context)
connect prms subname host port = do
let subname' = maybe host id subname
prms' = prms { TLS.clientServerIdentification = (subname', BC.pack (show port)) }
sock <- TCP.connectSocket host port
E.bracketOnError (TLS.contextNew sock prms') closeTLS $ \ ctx -> do
TLS.handshake ctx
(is, os) <- tlsToStreams ctx
return (is, os, ctx)
withConnection :: ClientParams
-> Maybe HostName
-> HostName
-> PortNumber
-> (InputStream ByteString -> OutputStream ByteString -> Context -> IO a)
-> IO a
withConnection prms subname host port action =
E.bracket (connect prms subname host port) cleanup go
where
go (is, os, ctx) = action is os ctx
cleanup (_, os, ctx) = E.mask_ $
eatException $! Stream.write Nothing os >> closeTLS ctx
eatException m = void m `E.catch` (\(_::E.SomeException) -> return ())
accept :: ServerParams
-> Socket
-> IO (InputStream ByteString, OutputStream ByteString, Context, N.SockAddr)
accept prms sock = do
(sock', sockAddr) <- N.accept sock
E.bracketOnError (TLS.contextNew sock' prms) closeTLS $ \ ctx -> do
TLS.handshake ctx
(is, os) <- tlsToStreams ctx
return (is, os, ctx, sockAddr)