{-# Language BlockArguments #-}
module Hookup
(
Connection,
connect,
connectWithSocket,
close,
upgradeTls,
recv,
recvLine,
send,
putBuf,
ConnectionParams(..),
SocksParams(..),
TlsParams(..),
TlsVerify(..),
PEM.PemPasswordSupply(..),
defaultTlsParams,
ConnectionFailure(..),
CommandReply(..)
, getClientCertificate
, getPeerCertificate
, getPeerCertFingerprintSha1
, getPeerCertFingerprintSha256
, getPeerCertFingerprintSha512
, getPeerPubkeyFingerprintSha1
, getPeerPubkeyFingerprintSha256
, getPeerPubkeyFingerprintSha512
) where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.IO.Error (isDoesNotExistError, ioeGetErrorString)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Foldable
import Data.List (intercalate, partition)
import Data.Maybe (fromMaybe, mapMaybe)
import Foreign.C.String (withCStringLen)
import Foreign.Ptr (nullPtr)
import Network.Socket (AddrInfo, HostName, PortNumber, SockAddr, Socket, Family)
import qualified Network.Socket as Socket
import qualified Network.Socket.ByteString as SocketB
import OpenSSL.Session (SSL, SSLContext)
import qualified OpenSSL as SSL
import qualified OpenSSL.Session as SSL
import OpenSSL.X509.SystemStore
import OpenSSL.X509 (X509)
import qualified OpenSSL.X509 as X509
import qualified OpenSSL.PEM as PEM
import qualified OpenSSL.EVP.Digest as Digest
import Data.Attoparsec.ByteString (Parser)
import qualified Data.Attoparsec.ByteString as Parser
import Hookup.Concurrent (concurrentAttempts)
import Hookup.OpenSSL
import Hookup.Socks5
data ConnectionParams = ConnectionParams
{ ConnectionParams -> HostName
cpHost :: HostName
, ConnectionParams -> PortNumber
cpPort :: PortNumber
, ConnectionParams -> Maybe SocksParams
cpSocks :: Maybe SocksParams
, ConnectionParams -> Maybe TlsParams
cpTls :: Maybe TlsParams
, ConnectionParams -> Maybe HostName
cpBind :: Maybe HostName
}
data SocksParams = SocksParams
{ SocksParams -> HostName
spHost :: HostName
, SocksParams -> PortNumber
spPort :: PortNumber
}
data TlsParams = TlsParams
{ TlsParams -> Maybe HostName
tpClientCertificate :: Maybe FilePath
, TlsParams -> Maybe HostName
tpClientPrivateKey :: Maybe FilePath
, TlsParams -> Maybe ByteString
tpClientPrivateKeyPassword :: Maybe ByteString
, TlsParams -> Maybe HostName
tpServerCertificate :: Maybe FilePath
, TlsParams -> HostName
tpCipherSuite :: String
, TlsParams -> Maybe HostName
tpCipherSuiteTls13 :: Maybe String
, TlsParams -> TlsVerify
tpVerify :: TlsVerify
}
data TlsVerify
= VerifyDefault
| VerifyNone
| VerifyHostname String
deriving Int -> TlsVerify -> ShowS
[TlsVerify] -> ShowS
TlsVerify -> HostName
(Int -> TlsVerify -> ShowS)
-> (TlsVerify -> HostName)
-> ([TlsVerify] -> ShowS)
-> Show TlsVerify
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [TlsVerify] -> ShowS
$cshowList :: [TlsVerify] -> ShowS
show :: TlsVerify -> HostName
$cshow :: TlsVerify -> HostName
showsPrec :: Int -> TlsVerify -> ShowS
$cshowsPrec :: Int -> TlsVerify -> ShowS
Show
data ConnectionFailure
= HostnameResolutionFailure HostName String
| ConnectionFailure [ConnectError]
| LineTooLong
| LineTruncated
| SocksError CommandReply
| SocksAuthenticationError
| SocksProtocolError
| SocksBadDomainName
deriving Int -> ConnectionFailure -> ShowS
[ConnectionFailure] -> ShowS
ConnectionFailure -> HostName
(Int -> ConnectionFailure -> ShowS)
-> (ConnectionFailure -> HostName)
-> ([ConnectionFailure] -> ShowS)
-> Show ConnectionFailure
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionFailure] -> ShowS
$cshowList :: [ConnectionFailure] -> ShowS
show :: ConnectionFailure -> HostName
$cshow :: ConnectionFailure -> HostName
showsPrec :: Int -> ConnectionFailure -> ShowS
$cshowsPrec :: Int -> ConnectionFailure -> ShowS
Show
instance Exception ConnectionFailure where
displayException :: ConnectionFailure -> HostName
displayException ConnectionFailure
LineTruncated = HostName
"connection closed while reading line"
displayException ConnectionFailure
LineTooLong = HostName
"line length exceeded maximum"
displayException (ConnectionFailure [ConnectError]
xs) =
HostName
"connection attempt failed due to: " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++
HostName -> [HostName] -> HostName
forall a. [a] -> [[a]] -> [a]
intercalate HostName
", " ((ConnectError -> HostName) -> [ConnectError] -> [HostName]
forall a b. (a -> b) -> [a] -> [b]
map ConnectError -> HostName
forall e. Exception e => e -> HostName
displayException [ConnectError]
xs)
displayException (HostnameResolutionFailure HostName
h HostName
s) =
HostName
"hostname resolution failed (" HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
h HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
"): " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
s
displayException ConnectionFailure
SocksAuthenticationError =
HostName
"SOCKS authentication method rejected"
displayException ConnectionFailure
SocksProtocolError =
HostName
"SOCKS server protocol error"
displayException ConnectionFailure
SocksBadDomainName =
HostName
"SOCKS domain name length limit exceeded"
displayException (SocksError CommandReply
reply) =
HostName
"SOCKS command rejected: " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++
case CommandReply
reply of
CommandReply
Succeeded -> HostName
"succeeded"
CommandReply
GeneralFailure -> HostName
"general SOCKS server failure"
CommandReply
NotAllowed -> HostName
"connection not allowed by ruleset"
CommandReply
NetUnreachable -> HostName
"network unreachable"
CommandReply
HostUnreachable -> HostName
"host unreachable"
CommandReply
ConnectionRefused -> HostName
"connection refused"
CommandReply
TTLExpired -> HostName
"TTL expired"
CommandReply
CmdNotSupported -> HostName
"command not supported"
CommandReply
AddrNotSupported -> HostName
"address type not supported"
CommandReply Word8
n -> HostName
"unknown reply " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> HostName
forall a. Show a => a -> HostName
show Word8
n
data ConnectError = ConnectError SockAddr IOError
deriving Int -> ConnectError -> ShowS
[ConnectError] -> ShowS
ConnectError -> HostName
(Int -> ConnectError -> ShowS)
-> (ConnectError -> HostName)
-> ([ConnectError] -> ShowS)
-> Show ConnectError
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [ConnectError] -> ShowS
$cshowList :: [ConnectError] -> ShowS
show :: ConnectError -> HostName
$cshow :: ConnectError -> HostName
showsPrec :: Int -> ConnectError -> ShowS
$cshowsPrec :: Int -> ConnectError -> ShowS
Show
instance Exception ConnectError where
displayException :: ConnectError -> HostName
displayException (ConnectError SockAddr
addr IOError
e) = SockAddr -> HostName
forall a. Show a => a -> HostName
show SockAddr
addr HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
": " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> HostName
forall e. Exception e => e -> HostName
displayException IOError
e
defaultTlsParams :: TlsParams
defaultTlsParams :: TlsParams
defaultTlsParams = TlsParams :: Maybe HostName
-> Maybe HostName
-> Maybe ByteString
-> Maybe HostName
-> HostName
-> Maybe HostName
-> TlsVerify
-> TlsParams
TlsParams
{ tpClientCertificate :: Maybe HostName
tpClientCertificate = Maybe HostName
forall a. Maybe a
Nothing
, tpClientPrivateKey :: Maybe HostName
tpClientPrivateKey = Maybe HostName
forall a. Maybe a
Nothing
, tpClientPrivateKeyPassword :: Maybe ByteString
tpClientPrivateKeyPassword = Maybe ByteString
forall a. Maybe a
Nothing
, tpServerCertificate :: Maybe HostName
tpServerCertificate = Maybe HostName
forall a. Maybe a
Nothing
, tpCipherSuite :: HostName
tpCipherSuite = HostName
"HIGH"
, tpCipherSuiteTls13 :: Maybe HostName
tpCipherSuiteTls13 = Maybe HostName
forall a. Maybe a
Nothing
, tpVerify :: TlsVerify
tpVerify = TlsVerify
VerifyDefault
}
openSocket :: ConnectionParams -> IO Socket
openSocket :: ConnectionParams -> IO Socket
openSocket ConnectionParams
params =
case ConnectionParams -> Maybe SocksParams
cpSocks ConnectionParams
params of
Maybe SocksParams
Nothing -> HostName -> PortNumber -> Maybe HostName -> IO Socket
openSocket' (ConnectionParams -> HostName
cpHost ConnectionParams
params) (ConnectionParams -> PortNumber
cpPort ConnectionParams
params) (ConnectionParams -> Maybe HostName
cpBind ConnectionParams
params)
Just SocksParams
sp ->
do Socket
sock <- HostName -> PortNumber -> Maybe HostName -> IO Socket
openSocket' (SocksParams -> HostName
spHost SocksParams
sp) (SocksParams -> PortNumber
spPort SocksParams
sp) (ConnectionParams -> Maybe HostName
cpBind ConnectionParams
params)
(Socket
sock Socket -> IO () -> IO Socket
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> HostName -> PortNumber -> IO ()
socksConnect Socket
sock (ConnectionParams -> HostName
cpHost ConnectionParams
params) (ConnectionParams -> PortNumber
cpPort ConnectionParams
params))
IO Socket -> IO () -> IO Socket
forall a b. IO a -> IO b -> IO a
`onException` Socket -> IO ()
Socket.close Socket
sock
netParse :: Show a => Socket -> Parser a -> IO a
netParse :: Socket -> Parser a -> IO a
netParse Socket
sock Parser a
parser =
do
Result a
result <- IO ByteString -> Parser a -> ByteString -> IO (Result a)
forall (m :: * -> *) a.
Monad m =>
m ByteString -> Parser a -> ByteString -> m (Result a)
Parser.parseWith
(Socket -> Int -> IO ByteString
SocketB.recv Socket
sock Int
1)
Parser a
parser
ByteString
B.empty
case Result a
result of
Parser.Done ByteString
i a
x | ByteString -> Bool
B.null ByteString
i -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Result a
_ -> ConnectionFailure -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectionFailure
SocksProtocolError
socksConnect :: Socket -> HostName -> PortNumber -> IO ()
socksConnect :: Socket -> HostName -> PortNumber -> IO ()
socksConnect Socket
sock HostName
host PortNumber
port =
do Socket -> ByteString -> IO ()
SocketB.sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
ClientHello -> ByteString
buildClientHello ClientHello :: [AuthMethod] -> ClientHello
ClientHello
{ cHelloMethods :: [AuthMethod]
cHelloMethods = [AuthMethod
AuthNoAuthenticationRequired] }
ServerHello -> IO ()
validateHello (ServerHello -> IO ()) -> IO ServerHello -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Socket -> Parser ServerHello -> IO ServerHello
forall a. Show a => Socket -> Parser a -> IO a
netParse Socket
sock Parser ServerHello
parseServerHello
let dnBytes :: ByteString
dnBytes = HostName -> ByteString
B8.pack HostName
host
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
dnBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256)
(ConnectionFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO ConnectionFailure
SocksBadDomainName)
Socket -> ByteString -> IO ()
SocketB.sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
Request -> ByteString
buildRequest Request :: Command -> Address -> Request
Request
{ reqCommand :: Command
reqCommand = Command
Connect
, reqAddress :: Address
reqAddress = Host -> PortNumber -> Address
Address (ByteString -> Host
DomainName ByteString
dnBytes) PortNumber
port
}
Response -> IO ()
validateResponse (Response -> IO ()) -> IO Response -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Socket -> Parser Response -> IO Response
forall a. Show a => Socket -> Parser a -> IO a
netParse Socket
sock Parser Response
parseResponse
validateHello :: ServerHello -> IO ()
validateHello :: ServerHello -> IO ()
validateHello ServerHello
hello =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ServerHello -> AuthMethod
sHelloMethod ServerHello
hello AuthMethod -> AuthMethod -> Bool
forall a. Eq a => a -> a -> Bool
== AuthMethod
AuthNoAuthenticationRequired)
(ConnectionFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO ConnectionFailure
SocksAuthenticationError)
validateResponse :: Response -> IO ()
validateResponse :: Response -> IO ()
validateResponse Response
response =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response -> CommandReply
rspReply Response
response CommandReply -> CommandReply -> Bool
forall a. Eq a => a -> a -> Bool
== CommandReply
Succeeded )
(ConnectionFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CommandReply -> ConnectionFailure
SocksError (Response -> CommandReply
rspReply Response
response)))
openSocket' ::
HostName ->
PortNumber ->
Maybe HostName ->
IO Socket
openSocket' :: HostName -> PortNumber -> Maybe HostName -> IO Socket
openSocket' HostName
h PortNumber
p Maybe HostName
mbBind =
do Maybe [AddrInfo]
mbSrc <- (HostName -> IO [AddrInfo])
-> Maybe HostName -> IO (Maybe [AddrInfo])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe PortNumber -> HostName -> IO [AddrInfo]
resolve Maybe PortNumber
forall a. Maybe a
Nothing) Maybe HostName
mbBind
[AddrInfo]
dst <- Maybe PortNumber -> HostName -> IO [AddrInfo]
resolve (PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just PortNumber
p) HostName
h
let pairs :: [(Maybe SockAddr, AddrInfo)]
pairs = [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
interleaveAddressFamilies (Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
matchBindAddrs Maybe [AddrInfo]
mbSrc [AddrInfo]
dst)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Maybe SockAddr, AddrInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe SockAddr, AddrInfo)]
pairs)
(ConnectionFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HostName -> HostName -> ConnectionFailure
HostnameResolutionFailure HostName
h HostName
"No source/destination address family match"))
Either [SomeException] Socket
res <- Int
-> (Socket -> IO ())
-> [IO Socket]
-> IO (Either [SomeException] Socket)
forall a.
Int -> (a -> IO ()) -> [IO a] -> IO (Either [SomeException] a)
concurrentAttempts Int
connAttemptDelay Socket -> IO ()
Socket.close ((Maybe SockAddr -> AddrInfo -> IO Socket)
-> (Maybe SockAddr, AddrInfo) -> IO Socket
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo ((Maybe SockAddr, AddrInfo) -> IO Socket)
-> [(Maybe SockAddr, AddrInfo)] -> [IO Socket]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe SockAddr, AddrInfo)]
pairs)
case Either [SomeException] Socket
res of
Left [SomeException]
es -> ConnectionFailure -> IO Socket
forall e a. Exception e => e -> IO a
throwIO ([ConnectError] -> ConnectionFailure
ConnectionFailure ((SomeException -> Maybe ConnectError)
-> [SomeException] -> [ConnectError]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SomeException -> Maybe ConnectError
forall e. Exception e => SomeException -> Maybe e
fromException [SomeException]
es))
Right Socket
s -> Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
s
hints :: AddrInfo
hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints
{ addrSocketType :: SocketType
Socket.addrSocketType = SocketType
Socket.Stream
, addrFlags :: [AddrInfoFlag]
Socket.addrFlags = [AddrInfoFlag
Socket.AI_NUMERICSERV]
}
resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo]
resolve :: Maybe PortNumber -> HostName -> IO [AddrInfo]
resolve Maybe PortNumber
mbPort HostName
host =
do Either IOError [AddrInfo]
res <- IO [AddrInfo] -> IO (Either IOError [AddrInfo])
forall e a. Exception e => IO a -> IO (Either e a)
try (Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host) (PortNumber -> HostName
forall a. Show a => a -> HostName
show(PortNumber -> HostName) -> Maybe PortNumber -> Maybe HostName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>Maybe PortNumber
mbPort))
case Either IOError [AddrInfo]
res of
Right [AddrInfo]
ais -> [AddrInfo] -> IO [AddrInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [AddrInfo]
ais
Left IOError
ioe
| IOError -> Bool
isDoesNotExistError IOError
ioe ->
ConnectionFailure -> IO [AddrInfo]
forall e a. Exception e => e -> IO a
throwIO (HostName -> HostName -> ConnectionFailure
HostnameResolutionFailure HostName
host (IOError -> HostName
ioeGetErrorString IOError
ioe))
| Bool
otherwise -> IOError -> IO [AddrInfo]
forall e a. Exception e => e -> IO a
throwIO IOError
ioe
matchBindAddrs :: Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
matchBindAddrs :: Maybe [AddrInfo] -> [AddrInfo] -> [(Maybe SockAddr, AddrInfo)]
matchBindAddrs Maybe [AddrInfo]
Nothing [AddrInfo]
dst = [ (Maybe SockAddr
forall a. Maybe a
Nothing, AddrInfo
x) | AddrInfo
x <- [AddrInfo]
dst ]
matchBindAddrs (Just [AddrInfo]
src) [AddrInfo]
dst =
[ (SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
s), AddrInfo
d)
| AddrInfo
d <- [AddrInfo]
dst
, let ss :: [AddrInfo]
ss = [AddrInfo
s | AddrInfo
s <- [AddrInfo]
src, AddrInfo -> Family
Socket.addrFamily AddrInfo
d Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== AddrInfo -> Family
Socket.addrFamily AddrInfo
s]
, AddrInfo
s <- Int -> [AddrInfo] -> [AddrInfo]
forall a. Int -> [a] -> [a]
take Int
1 [AddrInfo]
ss ]
connAttemptDelay :: Int
connAttemptDelay :: Int
connAttemptDelay = Int
150 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
interleaveAddressFamilies [(Maybe SockAddr, AddrInfo)]
xs = [(Maybe SockAddr, AddrInfo)]
-> [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
forall a. [a] -> [a] -> [a]
interleave [(Maybe SockAddr, AddrInfo)]
sixes [(Maybe SockAddr, AddrInfo)]
others
where
([(Maybe SockAddr, AddrInfo)]
sixes, [(Maybe SockAddr, AddrInfo)]
others) = ((Maybe SockAddr, AddrInfo) -> Bool)
-> [(Maybe SockAddr, AddrInfo)]
-> ([(Maybe SockAddr, AddrInfo)], [(Maybe SockAddr, AddrInfo)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Maybe SockAddr, AddrInfo) -> Bool
forall a. (a, AddrInfo) -> Bool
is6 [(Maybe SockAddr, AddrInfo)]
xs
is6 :: (a, AddrInfo) -> Bool
is6 (a, AddrInfo)
x = Family
Socket.AF_INET6 Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== AddrInfo -> Family
Socket.addrFamily ((a, AddrInfo) -> AddrInfo
forall a b. (a, b) -> b
snd (a, AddrInfo)
x)
interleave :: [a] -> [a] -> [a]
interleave (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
interleave [a]
xs [a]
ys
interleave [] [a]
ys = [a]
ys
interleave [a]
xs [] = [a]
xs
connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo Maybe SockAddr
mbSrc AddrInfo
info
= let addr :: SockAddr
addr = AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
info in
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (AddrInfo -> IO Socket
socket' AddrInfo
info) Socket -> IO ()
Socket.close ((Socket -> IO Socket) -> IO Socket)
-> (Socket -> IO Socket) -> IO Socket
forall a b. (a -> b) -> a -> b
$ \Socket
s ->
do (SockAddr -> IO ()) -> Maybe SockAddr -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Socket -> SockAddr -> IO ()
bind' Socket
s) Maybe SockAddr
mbSrc
Socket -> SockAddr -> IO ()
Socket.connect Socket
s SockAddr
addr
Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
s
IO Socket -> (IOError -> IO Socket) -> IO Socket
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (ConnectError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (ConnectError -> IO Socket)
-> (IOError -> ConnectError) -> IOError -> IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SockAddr -> IOError -> ConnectError
ConnectError SockAddr
addr)
bind' :: Socket -> SockAddr -> IO ()
bind' :: Socket -> SockAddr -> IO ()
bind' Socket
_ (Socket.SockAddrInet PortNumber
_ HostAddress
0) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
bind' Socket
_ (Socket.SockAddrInet6 PortNumber
_ HostAddress
_ (HostAddress
0,HostAddress
0,HostAddress
0,HostAddress
0) HostAddress
_) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
bind' Socket
s SockAddr
a = Socket -> SockAddr -> IO ()
Socket.bind Socket
s SockAddr
a
socket' :: AddrInfo -> IO Socket
socket' :: AddrInfo -> IO Socket
socket' AddrInfo
ai =
Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket
(AddrInfo -> Family
Socket.addrFamily AddrInfo
ai)
(AddrInfo -> SocketType
Socket.addrSocketType AddrInfo
ai)
(AddrInfo -> ProtocolNumber
Socket.addrProtocol AddrInfo
ai)
data NetworkHandle = SSL (Maybe X509) SSL | Socket Socket
openNetworkHandle ::
ConnectionParams ->
IO Socket ->
IO NetworkHandle
openNetworkHandle :: ConnectionParams -> IO Socket -> IO NetworkHandle
openNetworkHandle ConnectionParams
params IO Socket
mkSocket =
case ConnectionParams -> Maybe TlsParams
cpTls ConnectionParams
params of
Maybe TlsParams
Nothing -> Socket -> NetworkHandle
Socket (Socket -> NetworkHandle) -> IO Socket -> IO NetworkHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Socket
mkSocket
Just TlsParams
tls ->
do (Maybe X509
clientCert, SSL
ssl) <- TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
startTls TlsParams
tls (ConnectionParams -> HostName
cpHost ConnectionParams
params) IO Socket
mkSocket
NetworkHandle -> IO NetworkHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe X509 -> SSL -> NetworkHandle
SSL Maybe X509
clientCert SSL
ssl)
closeNetworkHandle :: NetworkHandle -> IO ()
closeNetworkHandle :: NetworkHandle -> IO ()
closeNetworkHandle (Socket Socket
s) = Socket -> IO ()
Socket.close Socket
s
closeNetworkHandle (SSL Maybe X509
_ SSL
s) =
do SSL -> ShutdownType -> IO ()
SSL.shutdown SSL
s ShutdownType
SSL.Unidirectional
(Socket -> IO ()) -> Maybe Socket -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Socket -> IO ()
Socket.close (SSL -> Maybe Socket
SSL.sslSocket SSL
s)
networkSend :: NetworkHandle -> ByteString -> IO ()
networkSend :: NetworkHandle -> ByteString -> IO ()
networkSend (Socket Socket
s) = Socket -> ByteString -> IO ()
SocketB.sendAll Socket
s
networkSend (SSL Maybe X509
_ SSL
s) = SSL -> ByteString -> IO ()
SSL.write SSL
s
networkRecv :: NetworkHandle -> Int -> IO ByteString
networkRecv :: NetworkHandle -> Int -> IO ByteString
networkRecv (Socket Socket
s) = Socket -> Int -> IO ByteString
SocketB.recv Socket
s
networkRecv (SSL Maybe X509
_ SSL
s) = SSL -> Int -> IO ByteString
SSL.read SSL
s
data Connection =
Connection
{-# UNPACK #-} !(MVar ByteString)
{-# UNPACK #-} !(MVar NetworkHandle)
connect ::
ConnectionParams ->
IO Connection
connect :: ConnectionParams -> IO Connection
connect ConnectionParams
params =
do NetworkHandle
h <- ConnectionParams -> IO Socket -> IO NetworkHandle
openNetworkHandle ConnectionParams
params (ConnectionParams -> IO Socket
openSocket ConnectionParams
params)
MVar ByteString -> MVar NetworkHandle -> Connection
Connection (MVar ByteString -> MVar NetworkHandle -> Connection)
-> IO (MVar ByteString) -> IO (MVar NetworkHandle -> Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
B.empty IO (MVar NetworkHandle -> Connection)
-> IO (MVar NetworkHandle) -> IO Connection
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NetworkHandle -> IO (MVar NetworkHandle)
forall a. a -> IO (MVar a)
newMVar NetworkHandle
h
connectWithSocket ::
ConnectionParams ->
Socket ->
IO Connection
connectWithSocket :: ConnectionParams -> Socket -> IO Connection
connectWithSocket ConnectionParams
params Socket
sock =
do NetworkHandle
h <- ConnectionParams -> IO Socket -> IO NetworkHandle
openNetworkHandle ConnectionParams
params (Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
MVar ByteString -> MVar NetworkHandle -> Connection
Connection (MVar ByteString -> MVar NetworkHandle -> Connection)
-> IO (MVar ByteString) -> IO (MVar NetworkHandle -> Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
B.empty IO (MVar NetworkHandle -> Connection)
-> IO (MVar NetworkHandle) -> IO Connection
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NetworkHandle -> IO (MVar NetworkHandle)
forall a. a -> IO (MVar a)
newMVar NetworkHandle
h
close ::
Connection ->
IO ()
close :: Connection -> IO ()
close (Connection MVar ByteString
_ MVar NetworkHandle
m) = MVar NetworkHandle -> (NetworkHandle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar NetworkHandle
m ((NetworkHandle -> IO ()) -> IO ())
-> (NetworkHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NetworkHandle
h -> NetworkHandle -> IO ()
closeNetworkHandle NetworkHandle
h
recv ::
Connection ->
Int ->
IO ByteString
recv :: Connection -> Int -> IO ByteString
recv (Connection MVar ByteString
bufVar MVar NetworkHandle
hVar) Int
n =
MVar ByteString
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
bufVar ((ByteString -> IO (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
bufChunk ->
do if ByteString -> Bool
B.null ByteString
bufChunk
then do NetworkHandle
h <- MVar NetworkHandle -> IO NetworkHandle
forall a. MVar a -> IO a
readMVar MVar NetworkHandle
hVar
ByteString
bs <- NetworkHandle -> Int -> IO ByteString
networkRecv NetworkHandle
h Int
n
(ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
B.empty, ByteString
bs)
else (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
B.empty, ByteString
bufChunk)
recvLine ::
Connection ->
Int ->
IO (Maybe ByteString)
recvLine :: Connection -> Int -> IO (Maybe ByteString)
recvLine (Connection MVar ByteString
bufVar MVar NetworkHandle
hVar) Int
n =
MVar ByteString
-> (ByteString -> IO (ByteString, Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
bufVar ((ByteString -> IO (ByteString, Maybe ByteString))
-> IO (Maybe ByteString))
-> (ByteString -> IO (ByteString, Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
do NetworkHandle
h <- MVar NetworkHandle -> IO NetworkHandle
forall a. MVar a -> IO a
readMVar MVar NetworkHandle
hVar
NetworkHandle
-> Int
-> ByteString
-> [ByteString]
-> IO (ByteString, Maybe ByteString)
go NetworkHandle
h (ByteString -> Int
B.length ByteString
bs) ByteString
bs []
where
go :: NetworkHandle
-> Int
-> ByteString
-> [ByteString]
-> IO (ByteString, Maybe ByteString)
go NetworkHandle
h Int
bsn ByteString
bs [ByteString]
bss =
case Char -> ByteString -> Maybe Int
B8.elemIndex Char
'\n' ByteString
bs of
Just Int
i -> (ByteString, Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
B.tail ByteString
b,
ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString
cleanEnd ([ByteString] -> ByteString
B.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
bss)))))
where
(ByteString
a,ByteString
b) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
i ByteString
bs
Maybe Int
Nothing ->
do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bsn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n) (ConnectionFailure -> IO ()
forall e a. Exception e => e -> IO a
throwIO ConnectionFailure
LineTooLong)
ByteString
more <- NetworkHandle -> Int -> IO ByteString
networkRecv NetworkHandle
h Int
n
if ByteString -> Bool
B.null ByteString
more
then if Int
bsn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (ByteString, Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
B.empty, Maybe ByteString
forall a. Maybe a
Nothing)
else ConnectionFailure -> IO (ByteString, Maybe ByteString)
forall e a. Exception e => e -> IO a
throwIO ConnectionFailure
LineTruncated
else NetworkHandle
-> Int
-> ByteString
-> [ByteString]
-> IO (ByteString, Maybe ByteString)
go NetworkHandle
h (Int
bsn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
more) ByteString
more (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
bss)
putBuf ::
Connection ->
ByteString ->
IO ()
putBuf :: Connection -> ByteString -> IO ()
putBuf (Connection MVar ByteString
bufVar MVar NetworkHandle
_) ByteString
bs =
MVar ByteString -> (ByteString -> IO ByteString) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ByteString
bufVar (\ByteString
old -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString -> ByteString
B.append ByteString
bs ByteString
old)
cleanEnd :: ByteString -> ByteString
cleanEnd :: ByteString -> ByteString
cleanEnd ByteString
bs
| ByteString -> Bool
B.null ByteString
bs Bool -> Bool -> Bool
|| ByteString -> Char
B8.last ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r' = ByteString
bs
| Bool
otherwise = ByteString -> ByteString
B.init ByteString
bs
send ::
Connection ->
ByteString ->
IO ()
send :: Connection -> ByteString -> IO ()
send (Connection MVar ByteString
_ MVar NetworkHandle
hVar) ByteString
bs =
do NetworkHandle
h <- MVar NetworkHandle -> IO NetworkHandle
forall a. MVar a -> IO a
readMVar MVar NetworkHandle
hVar
NetworkHandle -> ByteString -> IO ()
networkSend NetworkHandle
h ByteString
bs
upgradeTls ::
TlsParams ->
String ->
Connection ->
IO ()
upgradeTls :: TlsParams -> HostName -> Connection -> IO ()
upgradeTls TlsParams
tp HostName
hostname (Connection MVar ByteString
bufVar MVar NetworkHandle
hVar) =
MVar ByteString -> (ByteString -> IO ByteString) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ByteString
bufVar ((ByteString -> IO ByteString) -> IO ())
-> (ByteString -> IO ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
buf ->
MVar NetworkHandle
-> (NetworkHandle -> IO (NetworkHandle, ByteString))
-> IO ByteString
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar NetworkHandle
hVar ((NetworkHandle -> IO (NetworkHandle, ByteString))
-> IO ByteString)
-> (NetworkHandle -> IO (NetworkHandle, ByteString))
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \NetworkHandle
h ->
case NetworkHandle
h of
SSL{} -> (NetworkHandle, ByteString) -> IO (NetworkHandle, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (NetworkHandle
h, ByteString
buf)
Socket Socket
s ->
do (Maybe X509
cert, SSL
ssl) <- TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
startTls TlsParams
tp HostName
hostname (Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
s)
(NetworkHandle, ByteString) -> IO (NetworkHandle, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe X509 -> SSL -> NetworkHandle
SSL Maybe X509
cert SSL
ssl, ByteString
B.empty)
startTls ::
TlsParams ->
String ->
IO Socket ->
IO (Maybe X509, SSL)
startTls :: TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
startTls TlsParams
tp HostName
hostname IO Socket
mkSocket = IO (Maybe X509, SSL) -> IO (Maybe X509, SSL)
forall a. IO a -> IO a
SSL.withOpenSSL (IO (Maybe X509, SSL) -> IO (Maybe X509, SSL))
-> IO (Maybe X509, SSL) -> IO (Maybe X509, SSL)
forall a b. (a -> b) -> a -> b
$
do SSLContext
ctx <- IO SSLContext
SSL.context
SSLContext -> HostName -> IO ()
SSL.contextSetCiphers SSLContext
ctx (TlsParams -> HostName
tpCipherSuite TlsParams
tp)
(HostName -> IO ()) -> Maybe HostName -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SSLContext -> HostName -> IO ()
contextSetTls13Ciphers SSLContext
ctx) (TlsParams -> Maybe HostName
tpCipherSuiteTls13 TlsParams
tp)
case TlsParams -> TlsVerify
tpVerify TlsParams
tp of
TlsVerify
VerifyDefault ->
do SSLContext -> HostName -> IO ()
installVerification SSLContext
ctx HostName
hostname
SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx VerificationMode
verifyPeer
VerifyHostname HostName
h ->
do SSLContext -> HostName -> IO ()
installVerification SSLContext
ctx HostName
h
SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx VerificationMode
verifyPeer
TlsVerify
VerifyNone -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SSLContext -> SSLOption -> IO ()
SSL.contextAddOption SSLContext
ctx SSLOption
SSL.SSL_OP_ALL
SSLContext -> SSLOption -> IO ()
SSL.contextRemoveOption SSLContext
ctx SSLOption
SSL.SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS
SSLContext -> Maybe HostName -> IO ()
setupCaCertificates SSLContext
ctx (TlsParams -> Maybe HostName
tpServerCertificate TlsParams
tp)
Maybe X509
clientCert <- (HostName -> IO X509) -> Maybe HostName -> IO (Maybe X509)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SSLContext -> HostName -> IO X509
setupCertificate SSLContext
ctx) (TlsParams -> Maybe HostName
tpClientCertificate TlsParams
tp)
Maybe HostName -> (HostName -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (TlsParams -> Maybe HostName
tpClientPrivateKey TlsParams
tp) ((HostName -> IO ()) -> IO ()) -> (HostName -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HostName
path ->
SSLContext -> Maybe ByteString -> IO () -> IO ()
forall a. SSLContext -> Maybe ByteString -> IO a -> IO a
withDefaultPassword SSLContext
ctx (TlsParams -> Maybe ByteString
tpClientPrivateKeyPassword TlsParams
tp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
SSLContext -> HostName -> IO ()
SSL.contextSetPrivateKeyFile SSLContext
ctx HostName
path
SSL
ssl <- SSLContext -> Socket -> IO SSL
SSL.connection SSLContext
ctx (Socket -> IO SSL) -> IO Socket -> IO SSL
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Socket
mkSocket
Bool
isip <- HostName -> IO Bool
isIpAddress HostName
hostname
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isip (SSL -> HostName -> IO ()
SSL.setTlsextHostName SSL
ssl HostName
hostname)
SSL -> IO ()
SSL.connect SSL
ssl
(Maybe X509, SSL) -> IO (Maybe X509, SSL)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe X509
clientCert, SSL
ssl)
isIpAddress :: HostName -> IO Bool
isIpAddress :: HostName -> IO Bool
isIpAddress HostName
host =
do Either IOError [AddrInfo]
res <- IO [AddrInfo] -> IO (Either IOError [AddrInfo])
forall e a. Exception e => IO a -> IO (Either e a)
try (Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
Socket.getAddrInfo
(AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
Socket.defaultHints{addrFlags :: [AddrInfoFlag]
Socket.addrFlags=[AddrInfoFlag
Socket.AI_NUMERICHOST]})
(HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host) Maybe HostName
forall a. Maybe a
Nothing)
case Either IOError [AddrInfo]
res :: Either IOError [AddrInfo] of
Right{} -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Left {} -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
setupCaCertificates :: SSLContext -> Maybe FilePath -> IO ()
setupCaCertificates :: SSLContext -> Maybe HostName -> IO ()
setupCaCertificates SSLContext
ctx Maybe HostName
mbPath =
case Maybe HostName
mbPath of
Maybe HostName
Nothing -> SSLContext -> IO ()
contextLoadSystemCerts SSLContext
ctx
Just HostName
path -> SSLContext -> Maybe ByteString -> IO () -> IO ()
forall a. SSLContext -> Maybe ByteString -> IO a -> IO a
withDefaultPassword SSLContext
ctx Maybe ByteString
forall a. Maybe a
Nothing (SSLContext -> HostName -> IO ()
SSL.contextSetCAFile SSLContext
ctx HostName
path)
setupCertificate :: SSLContext -> FilePath -> IO X509
setupCertificate :: SSLContext -> HostName -> IO X509
setupCertificate SSLContext
ctx HostName
path =
do X509
x509 <- HostName -> IO X509
PEM.readX509 (HostName -> IO X509) -> IO HostName -> IO X509
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HostName -> IO HostName
readFile HostName
path
SSLContext -> X509 -> IO ()
SSL.contextSetCertificate SSLContext
ctx X509
x509
X509 -> IO X509
forall (f :: * -> *) a. Applicative f => a -> f a
pure X509
x509
verifyPeer :: SSL.VerificationMode
verifyPeer :: VerificationMode
verifyPeer = VerifyPeer :: Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
SSL.VerifyPeer
{ vpFailIfNoPeerCert :: Bool
SSL.vpFailIfNoPeerCert = Bool
True
, vpClientOnce :: Bool
SSL.vpClientOnce = Bool
True
, vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool)
SSL.vpCallback = Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing
}
getPeerCertificate :: Connection -> IO (Maybe X509.X509)
getPeerCertificate :: Connection -> IO (Maybe X509)
getPeerCertificate (Connection MVar ByteString
_ MVar NetworkHandle
hVar) =
MVar NetworkHandle
-> (NetworkHandle -> IO (Maybe X509)) -> IO (Maybe X509)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar NetworkHandle
hVar ((NetworkHandle -> IO (Maybe X509)) -> IO (Maybe X509))
-> (NetworkHandle -> IO (Maybe X509)) -> IO (Maybe X509)
forall a b. (a -> b) -> a -> b
$ \NetworkHandle
h ->
case NetworkHandle
h of
Socket{} -> Maybe X509 -> IO (Maybe X509)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe X509
forall a. Maybe a
Nothing
SSL Maybe X509
_ SSL
ssl -> SSL -> IO (Maybe X509)
SSL.getPeerCertificate SSL
ssl
getClientCertificate :: Connection -> IO (Maybe X509.X509)
getClientCertificate :: Connection -> IO (Maybe X509)
getClientCertificate (Connection MVar ByteString
_ MVar NetworkHandle
hVar) =
do NetworkHandle
h <- MVar NetworkHandle -> IO NetworkHandle
forall a. MVar a -> IO a
readMVar MVar NetworkHandle
hVar
Maybe X509 -> IO (Maybe X509)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe X509 -> IO (Maybe X509)) -> Maybe X509 -> IO (Maybe X509)
forall a b. (a -> b) -> a -> b
$ case NetworkHandle
h of
Socket{} -> Maybe X509
forall a. Maybe a
Nothing
SSL Maybe X509
c SSL
_ -> Maybe X509
c
getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint HostName
"sha1"
getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint HostName
"sha256"
getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint HostName
"sha512"
getPeerCertFingerprint :: String -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint HostName
name Connection
h =
do Maybe X509
mb <- Connection -> IO (Maybe X509)
getPeerCertificate Connection
h
case Maybe X509
mb of
Maybe X509
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just X509
x509 ->
do ByteString
der <- X509 -> IO ByteString
X509.writeDerX509 X509
x509
Maybe Digest
mbdigest <- HostName -> IO (Maybe Digest)
Digest.getDigestByName HostName
name
case Maybe Digest
mbdigest of
Maybe Digest
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just Digest
digest -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! Digest -> ByteString -> ByteString
Digest.digestLBS Digest
digest ByteString
der
getPeerPubkeyFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha1 = HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint HostName
"sha1"
getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint HostName
"sha256"
getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint HostName
"sha512"
getPeerPubkeyFingerprint :: String -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint HostName
name Connection
h =
do Maybe X509
mb <- Connection -> IO (Maybe X509)
getPeerCertificate Connection
h
case Maybe X509
mb of
Maybe X509
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just X509
x509 ->
do ByteString
der <- X509 -> IO ByteString
getPubKeyDer X509
x509
Maybe Digest
mbdigest <- HostName -> IO (Maybe Digest)
Digest.getDigestByName HostName
name
case Maybe Digest
mbdigest of
Maybe Digest
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just Digest
digest -> Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$! Digest -> ByteString -> ByteString
Digest.digestBS Digest
digest ByteString
der