module System.IO.Streams.OpenSSL
( TLSConnection
, connect
, connectWithVerifier
, sslToConnection
, accept
, module Data.OpenSSLSetting
) where
import qualified Control.Exception as E
import Control.Monad (unless)
import Data.Connection
import qualified Data.ByteString as S
import Data.OpenSSLSetting
import qualified Network.Socket as N
import OpenSSL (withOpenSSL)
import qualified OpenSSL.Session as SSL
import qualified OpenSSL.X509 as X509
import qualified System.IO.Streams as Streams
import qualified System.IO.Streams.TCP as TCP
type TLSConnection = Connection (SSL.SSL , N.SockAddr)
sslToConnection :: (SSL.SSL, N.SockAddr)
-> IO TLSConnection
sslToConnection (ssl, addr) = do
is <- Streams.makeInputStream input
return (Connection is (SSL.lazyWrite ssl) (closeSSL ssl) (ssl, addr))
where
input = ( do
s <- SSL.read ssl TCP.defaultChunkSize
return $! if S.null s then Nothing else Just s
) `E.catch` (\(_::E.SomeException) -> return Nothing)
closeSSL :: SSL.SSL -> IO ()
closeSSL ssl = withOpenSSL $ do
SSL.shutdown ssl SSL.Unidirectional
maybe (return ()) N.close (SSL.sslSocket ssl)
connect :: SSL.SSLContext
-> Maybe String
-> N.HostName
-> N.PortNumber
-> IO TLSConnection
connect ctx vhost host port = withOpenSSL $ do
connectWithVerifier ctx verify host port
where
verify trusted cnname = trusted
&& maybe False (matchDomain verifyHost) cnname
verifyHost = maybe host id vhost
matchDomain :: String -> String -> Bool
matchDomain n1 n2 =
let n1' = reverse (splitDot n1)
n2' = reverse (splitDot n2)
cmp src target = src == "*" || target == "*" || src == target
in and (zipWith cmp n1' n2')
splitDot :: String -> [String]
splitDot "" = [""]
splitDot x =
let (y, z) = break (== '.') x in
y : (if z == "" then [] else splitDot $ drop 1 z)
connectWithVerifier :: SSL.SSLContext
-> (Bool -> Maybe String -> Bool)
-> N.HostName
-> N.PortNumber
-> IO TLSConnection
connectWithVerifier ctx f host port = withOpenSSL $ do
(sock, addr) <- TCP.connectSocket host port
E.bracketOnError (SSL.connection ctx sock) closeSSL $ \ ssl -> do
SSL.connect ssl
trusted <- SSL.getVerifyResult ssl
cert <- SSL.getPeerCertificate ssl
subnames <- maybe (return []) (`X509.getSubjectName` False) cert
let cnname = lookup "CN" subnames
verified = f trusted cnname
unless verified (E.throwIO $ SSL.ProtocolError "fail to verify certificate")
sslToConnection (ssl, addr)
accept :: SSL.SSLContext
-> N.Socket
-> IO TLSConnection
accept ctx sock = withOpenSSL $ do
(sock', addr) <- N.accept sock
E.bracketOnError (SSL.connection ctx sock') closeSSL $ \ ssl -> do
SSL.accept ssl
trusted <- SSL.getVerifyResult ssl
unless trusted (E.throwIO $ SSL.ProtocolError "fail to verify certificate")
sslToConnection (ssl, addr)