module Hookup
(
Connection,
connect,
connectWithSocket,
close,
recv,
recvLine,
send,
putBuf,
ConnectionParams(..),
SocksParams(..),
TlsParams(..),
PEM.PemPasswordSupply(..),
defaultTlsParams,
ConnectionFailure(..),
CommandReply(..)
, getClientCertificate
, getPeerCertificate
, getPeerCertFingerprintSha1
, getPeerCertFingerprintSha256
, getPeerCertFingerprintSha512
, getPeerPubkeyFingerprintSha1
, getPeerPubkeyFingerprintSha256
, getPeerPubkeyFingerprintSha512
) where
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 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.OpenSSL (installVerification, getPubKeyDer)
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 -> PemPasswordSupply
tpClientPrivateKeyPassword :: PEM.PemPasswordSupply
, TlsParams -> Maybe HostName
tpServerCertificate :: Maybe FilePath
, TlsParams -> HostName
tpCipherSuite :: String
, TlsParams -> Bool
tpInsecure :: Bool
}
data ConnectionFailure
= HostnameResolutionFailure HostName String
| ConnectionFailure [IOError]
| 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 LineTruncated = "connection closed while reading line"
displayException LineTooLong = "line length exceeded maximum"
displayException (ConnectionFailure xs :: [IOError]
xs) =
"connection attempt failed due to: " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++
HostName -> [HostName] -> HostName
forall a. [a] -> [[a]] -> [a]
intercalate ", " ((IOError -> HostName) -> [IOError] -> [HostName]
forall a b. (a -> b) -> [a] -> [b]
map IOError -> HostName
forall e. Exception e => e -> HostName
displayException [IOError]
xs)
displayException (HostnameResolutionFailure h :: HostName
h s :: HostName
s) =
"hostname resolution failed (" HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
h HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ "): " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ HostName
s
displayException SocksAuthenticationError =
"SOCKS authentication method rejected"
displayException SocksProtocolError =
"SOCKS server protocol error"
displayException SocksBadDomainName =
"SOCKS domain name length limit exceeded"
displayException (SocksError reply :: CommandReply
reply) =
"SOCKS command rejected: " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++
case CommandReply
reply of
Succeeded -> "succeeded"
GeneralFailure -> "general SOCKS server failure"
NotAllowed -> "connection not allowed by ruleset"
NetUnreachable -> "network unreachable"
HostUnreachable -> "host unreachable"
ConnectionRefused -> "connection refused"
TTLExpired -> "TTL expired"
CmdNotSupported -> "command not supported"
AddrNotSupported -> "address type not supported"
CommandReply n :: Word8
n -> "unknown reply " HostName -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> HostName
forall a. Show a => a -> HostName
show Word8
n
defaultTlsParams :: TlsParams
defaultTlsParams :: TlsParams
defaultTlsParams = TlsParams :: Maybe HostName
-> Maybe HostName
-> PemPasswordSupply
-> Maybe HostName
-> HostName
-> Bool
-> 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 :: PemPasswordSupply
tpClientPrivateKeyPassword = PemPasswordSupply
PEM.PwNone
, tpServerCertificate :: Maybe HostName
tpServerCertificate = Maybe HostName
forall a. Maybe a
Nothing
, tpCipherSuite :: HostName
tpCipherSuite = "HIGH"
, tpInsecure :: Bool
tpInsecure = Bool
False
}
openSocket :: ConnectionParams -> IO Socket
openSocket :: ConnectionParams -> IO Socket
openSocket params :: ConnectionParams
params =
case ConnectionParams -> Maybe SocksParams
cpSocks ConnectionParams
params of
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 sp :: 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 sock :: Socket
sock parser :: 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 1)
Parser a
parser
ByteString
B.empty
case Result a
result of
Parser.Done i :: ByteString
i x :: a
x | ByteString -> Bool
B.null ByteString
i -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
_ -> 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 sock :: Socket
sock host :: HostName
host port :: 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
< 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 hello :: 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
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' h :: HostName
h p :: PortNumber
p mbBind :: 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 "No source/destination address family match"))
[(Maybe SockAddr, AddrInfo)] -> IO Socket
attempt [(Maybe SockAddr, AddrInfo)]
pairs
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 mbPort :: Maybe PortNumber
mbPort host :: 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 ais :: [AddrInfo]
ais -> [AddrInfo] -> IO [AddrInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [AddrInfo]
ais
Left ioe :: 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 Nothing dst :: [AddrInfo]
dst = [ (Maybe SockAddr
forall a. Maybe a
Nothing, AddrInfo
x) | AddrInfo
x <- [AddrInfo]
dst ]
matchBindAddrs (Just src :: [AddrInfo]
src) dst :: [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 1 [AddrInfo]
ss ]
connAttemptDelay :: Int
connAttemptDelay :: Int
connAttemptDelay = 150 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000
attempt ::
[(Maybe SockAddr, AddrInfo)] ->
IO Socket
attempt :: [(Maybe SockAddr, AddrInfo)] -> IO Socket
attempt xs :: [(Maybe SockAddr, AddrInfo)]
xs =
do MVar (Either IOError Socket)
comm <- IO (MVar (Either IOError Socket))
forall a. IO (MVar a)
newEmptyMVar
let mkThread :: Int -> (Maybe SockAddr, AddrInfo) -> IO ThreadId
mkThread i :: Int
i (mbSrc :: Maybe SockAddr
mbSrc, ai :: AddrInfo
ai) =
((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \unmask :: forall a. IO a -> IO a
unmask ->
IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Int -> IO ()
threadDelay (Int
connAttemptDelay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)
MVar (Either IOError Socket) -> Either IOError Socket -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either IOError Socket)
comm (Either IOError Socket -> IO ())
-> IO (Either IOError Socket) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Socket -> IO (Either IOError Socket)
forall e a. Exception e => IO a -> IO (Either e a)
try (Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo Maybe SockAddr
mbSrc AddrInfo
ai)
IO [ThreadId]
-> ([ThreadId] -> IO ()) -> ([ThreadId] -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((Int -> (Maybe SockAddr, AddrInfo) -> IO ThreadId)
-> [Int] -> [(Maybe SockAddr, AddrInfo)] -> IO [ThreadId]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> (Maybe SockAddr, AddrInfo) -> IO ThreadId
mkThread [0..] [(Maybe SockAddr, AddrInfo)]
xs)
((ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ThreadId -> IO ()
killThread)
(\_ -> Int -> [IOError] -> MVar (Either IOError Socket) -> IO Socket
gather ([(Maybe SockAddr, AddrInfo)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe SockAddr, AddrInfo)]
xs) [] MVar (Either IOError Socket)
comm)
gather ::
Int ->
[IOError] ->
MVar (Either IOError Socket) ->
IO Socket
gather :: Int -> [IOError] -> MVar (Either IOError Socket) -> IO Socket
gather 0 exs :: [IOError]
exs _ = ConnectionFailure -> IO Socket
forall e a. Exception e => e -> IO a
throwIO ([IOError] -> ConnectionFailure
ConnectionFailure [IOError]
exs)
gather n :: Int
n exs :: [IOError]
exs comm :: MVar (Either IOError Socket)
comm =
do Either IOError Socket
res <- MVar (Either IOError Socket) -> IO (Either IOError Socket)
forall a. MVar a -> IO a
takeMVar MVar (Either IOError Socket)
comm
case Either IOError Socket
res of
Right s :: Socket
s -> Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
s
Left ex :: IOError
ex -> Int -> [IOError] -> MVar (Either IOError Socket) -> IO Socket
gather (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (IOError
exIOError -> [IOError] -> [IOError]
forall a. a -> [a] -> [a]
:[IOError]
exs) MVar (Either IOError Socket)
comm
interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
interleaveAddressFamilies :: [(Maybe SockAddr, AddrInfo)] -> [(Maybe SockAddr, AddrInfo)]
interleaveAddressFamilies xs :: [(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
(sixes :: [(Maybe SockAddr, AddrInfo)]
sixes, others :: [(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 x :: (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 (x :: a
x:xs :: [a]
xs) (y :: a
y:ys :: [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 [] ys :: [a]
ys = [a]
ys
interleave xs :: [a]
xs [] = [a]
xs
connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo :: Maybe SockAddr -> AddrInfo -> IO Socket
connectToAddrInfo mbSrc :: Maybe SockAddr
mbSrc info :: AddrInfo
info
= 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
$ \s :: 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 (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
info)
Socket -> IO Socket
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
s
bind' :: Socket -> SockAddr -> IO ()
bind' :: Socket -> SockAddr -> IO ()
bind' _ (Socket.SockAddrInet _ 0) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
bind' _ (Socket.SockAddrInet6 _ _ (0,0,0,0) _) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
bind' s :: Socket
s a :: SockAddr
a = Socket -> SockAddr -> IO ()
Socket.bind Socket
s SockAddr
a
socket' :: AddrInfo -> IO Socket
socket' :: AddrInfo -> IO Socket
socket' ai :: 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 params :: ConnectionParams
params mkSocket :: IO Socket
mkSocket =
case ConnectionParams -> Maybe TlsParams
cpTls ConnectionParams
params of
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 tls :: TlsParams
tls ->
do (clientCert :: Maybe X509
clientCert, ssl :: 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 s :: Socket
s) = Socket -> IO ()
Socket.close Socket
s
closeNetworkHandle (SSL _ s :: 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 s :: Socket
s) = Socket -> ByteString -> IO ()
SocketB.sendAll Socket
s
networkSend (SSL _ s :: SSL
s) = SSL -> ByteString -> IO ()
SSL.write SSL
s
networkRecv :: NetworkHandle -> Int -> IO ByteString
networkRecv :: NetworkHandle -> Int -> IO ByteString
networkRecv (Socket s :: Socket
s) = Socket -> Int -> IO ByteString
SocketB.recv Socket
s
networkRecv (SSL _ s :: SSL
s) = SSL -> Int -> IO ByteString
SSL.read SSL
s
data Connection = Connection (MVar ByteString) NetworkHandle
connect ::
ConnectionParams ->
IO Connection
connect :: ConnectionParams -> IO Connection
connect params :: ConnectionParams
params =
do NetworkHandle
h <- ConnectionParams -> IO Socket -> IO NetworkHandle
openNetworkHandle ConnectionParams
params (ConnectionParams -> IO Socket
openSocket ConnectionParams
params)
MVar ByteString
b <- ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
B.empty
Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ByteString -> NetworkHandle -> Connection
Connection MVar ByteString
b NetworkHandle
h)
connectWithSocket ::
ConnectionParams ->
Socket ->
IO Connection
connectWithSocket :: ConnectionParams -> Socket -> IO Connection
connectWithSocket params :: ConnectionParams
params sock :: 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
b <- ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar ByteString
B.empty
Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar ByteString -> NetworkHandle -> Connection
Connection MVar ByteString
b NetworkHandle
h)
close ::
Connection ->
IO ()
close :: Connection -> IO ()
close (Connection _ h :: NetworkHandle
h) = NetworkHandle -> IO ()
closeNetworkHandle NetworkHandle
h
recv ::
Connection ->
Int ->
IO ByteString
recv :: Connection -> Int -> IO ByteString
recv (Connection buf :: MVar ByteString
buf h :: NetworkHandle
h) n :: Int
n =
do ByteString
bufChunk <- MVar ByteString -> ByteString -> IO ByteString
forall a. MVar a -> a -> IO a
swapMVar MVar ByteString
buf ByteString
B.empty
if ByteString -> Bool
B.null ByteString
bufChunk
then NetworkHandle -> Int -> IO ByteString
networkRecv NetworkHandle
h Int
n
else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bufChunk
recvLine ::
Connection ->
Int ->
IO (Maybe ByteString)
recvLine :: Connection -> Int -> IO (Maybe ByteString)
recvLine (Connection buf :: MVar ByteString
buf h :: NetworkHandle
h) n :: 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
buf ((ByteString -> IO (ByteString, Maybe ByteString))
-> IO (Maybe ByteString))
-> (ByteString -> IO (ByteString, Maybe ByteString))
-> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \bs :: ByteString
bs ->
Int
-> ByteString -> [ByteString] -> IO (ByteString, Maybe ByteString)
go (ByteString -> Int
B.length ByteString
bs) ByteString
bs []
where
go :: Int
-> ByteString -> [ByteString] -> IO (ByteString, Maybe ByteString)
go bsn :: Int
bsn bs :: ByteString
bs bss :: [ByteString]
bss =
case Char -> ByteString -> Maybe Int
B8.elemIndex '\n' ByteString
bs of
Just i :: 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
(a :: ByteString
a,b :: ByteString
b) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
i ByteString
bs
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
== 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 Int
-> ByteString -> [ByteString] -> IO (ByteString, Maybe ByteString)
go (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 buf :: MVar ByteString
buf h :: NetworkHandle
h) bs :: ByteString
bs =
MVar ByteString -> (ByteString -> IO ByteString) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ByteString
buf (\old :: 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 bs :: 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
/= '\r' = ByteString
bs
| Bool
otherwise = ByteString -> ByteString
B.init ByteString
bs
send ::
Connection ->
ByteString ->
IO ()
send :: Connection -> ByteString -> IO ()
send (Connection _ h :: NetworkHandle
h) = NetworkHandle -> ByteString -> IO ()
networkSend NetworkHandle
h
startTls ::
TlsParams ->
String ->
IO Socket ->
IO (Maybe X509, SSL)
startTls :: TlsParams -> HostName -> IO Socket -> IO (Maybe X509, SSL)
startTls tp :: TlsParams
tp hostname :: HostName
hostname mkSocket :: 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)
SSLContext -> HostName -> IO ()
installVerification SSLContext
ctx HostName
hostname
SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx (Bool -> VerificationMode
verificationMode (TlsParams -> Bool
tpInsecure TlsParams
tp))
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)
(HostName -> IO ()) -> Maybe HostName -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SSLContext -> PemPasswordSupply -> HostName -> IO ()
setupPrivateKey SSLContext
ctx (TlsParams -> PemPasswordSupply
tpClientPrivateKeyPassword TlsParams
tp)) (TlsParams -> Maybe HostName
tpClientPrivateKey TlsParams
tp)
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
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)
setupCaCertificates :: SSLContext -> Maybe FilePath -> IO ()
setupCaCertificates :: SSLContext -> Maybe HostName -> IO ()
setupCaCertificates ctx :: SSLContext
ctx mbPath :: Maybe HostName
mbPath =
case Maybe HostName
mbPath of
Nothing -> SSLContext -> IO ()
contextLoadSystemCerts SSLContext
ctx
Just path :: HostName
path -> SSLContext -> HostName -> IO ()
SSL.contextSetCAFile SSLContext
ctx HostName
path
setupCertificate :: SSLContext -> FilePath -> IO X509
setupCertificate :: SSLContext -> HostName -> IO X509
setupCertificate ctx :: SSLContext
ctx path :: 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
setupPrivateKey :: SSLContext -> PEM.PemPasswordSupply -> FilePath -> IO ()
setupPrivateKey :: SSLContext -> PemPasswordSupply -> HostName -> IO ()
setupPrivateKey ctx :: SSLContext
ctx password :: PemPasswordSupply
password path :: HostName
path =
do HostName
str <- HostName -> IO HostName
readFile HostName
path
SomeKeyPair
key <- HostName -> PemPasswordSupply -> IO SomeKeyPair
PEM.readPrivateKey HostName
str PemPasswordSupply
password
SSLContext -> SomeKeyPair -> IO ()
forall k. KeyPair k => SSLContext -> k -> IO ()
SSL.contextSetPrivateKey SSLContext
ctx SomeKeyPair
key
verificationMode :: Bool -> SSL.VerificationMode
verificationMode :: Bool -> VerificationMode
verificationMode insecure :: Bool
insecure
| Bool
insecure = VerificationMode
SSL.VerifyNone
| Bool
otherwise = 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 _ h :: 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 _ ssl :: SSL
ssl -> SSL -> IO (Maybe X509)
SSL.getPeerCertificate SSL
ssl
getClientCertificate :: Connection -> Maybe X509.X509
getClientCertificate :: Connection -> Maybe X509
getClientCertificate (Connection _ h :: NetworkHandle
h) =
case NetworkHandle
h of
Socket{} -> Maybe X509
forall a. Maybe a
Nothing
SSL c :: Maybe X509
c _ -> Maybe X509
c
getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint "sha1"
getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint "sha256"
getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint "sha512"
getPeerCertFingerprint :: String -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
getPeerCertFingerprint name :: HostName
name h :: Connection
h =
do Maybe X509
mb <- Connection -> IO (Maybe X509)
getPeerCertificate Connection
h
case Maybe X509
mb of
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
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
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
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 "sha1"
getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 = HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint "sha256"
getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 :: Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 = HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint "sha512"
getPeerPubkeyFingerprint :: String -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint :: HostName -> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprint name :: HostName
name h :: Connection
h =
do Maybe X509
mb <- Connection -> IO (Maybe X509)
getPeerCertificate Connection
h
case Maybe X509
mb of
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
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
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
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