module Hookup
(
Connection,
connect,
connectWithSocket,
close,
recv,
recvLine,
send,
putBuf,
ConnectionParams(..),
SocksParams(..),
TlsParams(..),
defaultFamily,
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)
import Network.Socket (Socket, AddrInfo, PortNumber, HostName, 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 -> Family
cpFamily :: Family
, ConnectionParams -> HostName
cpHost :: HostName
, ConnectionParams -> PortNumber
cpPort :: PortNumber
, ConnectionParams -> Maybe SocksParams
cpSocks :: Maybe SocksParams
, ConnectionParams -> Maybe TlsParams
cpTls :: Maybe TlsParams
}
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 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
defaultFamily :: Socket.Family
defaultFamily :: Family
defaultFamily = Family
Socket.AF_UNSPEC
defaultTlsParams :: TlsParams
defaultTlsParams :: TlsParams
defaultTlsParams = TlsParams :: Maybe HostName
-> Maybe HostName
-> 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
, 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 -> Family -> HostName -> PortNumber -> IO Socket
openSocket' (ConnectionParams -> Family
cpFamily ConnectionParams
params) (ConnectionParams -> HostName
cpHost ConnectionParams
params) (ConnectionParams -> PortNumber
cpPort ConnectionParams
params)
Just sp :: SocksParams
sp ->
do Socket
sock <- Family -> HostName -> PortNumber -> IO Socket
openSocket' (ConnectionParams -> Family
cpFamily ConnectionParams
params) (SocksParams -> HostName
spHost SocksParams
sp) (SocksParams -> PortNumber
spPort SocksParams
sp)
(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' :: Family -> HostName -> PortNumber -> IO Socket
openSocket' :: Family -> HostName -> PortNumber -> IO Socket
openSocket' family :: Family
family h :: HostName
h p :: PortNumber
p =
do let hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints
{ addrFamily :: Family
Socket.addrFamily = Family
family
, addrSocketType :: SocketType
Socket.addrSocketType = SocketType
Socket.Stream
, addrFlags :: [AddrInfoFlag]
Socket.addrFlags = [AddrInfoFlag
Socket.AI_ADDRCONFIG
,AddrInfoFlag
Socket.AI_NUMERICSERV]
}
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
h) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
p)))
case Either IOError [AddrInfo]
res of
Right ais :: [AddrInfo]
ais -> [IOError] -> [AddrInfo] -> IO Socket
attemptConnections [] [AddrInfo]
ais
Left ioe :: IOError
ioe
| IOError -> Bool
isDoesNotExistError IOError
ioe ->
ConnectionFailure -> IO Socket
forall e a. Exception e => e -> IO a
throwIO (HostName -> HostName -> ConnectionFailure
HostnameResolutionFailure HostName
h (IOError -> HostName
ioeGetErrorString IOError
ioe))
| Bool
otherwise -> IOError -> IO Socket
forall e a. Exception e => e -> IO a
throwIO IOError
ioe
attemptConnections ::
[IOError] ->
[Socket.AddrInfo] ->
IO Socket
attemptConnections :: [IOError] -> [AddrInfo] -> IO Socket
attemptConnections exs :: [IOError]
exs [] = ConnectionFailure -> IO Socket
forall e a. Exception e => e -> IO a
throwIO ([IOError] -> ConnectionFailure
ConnectionFailure [IOError]
exs)
attemptConnections exs :: [IOError]
exs (ai :: AddrInfo
ai:ais :: [AddrInfo]
ais) =
do Either IOError Socket
res <- IO Socket -> IO (Either IOError Socket)
forall e a. Exception e => IO a -> IO (Either e a)
try (AddrInfo -> IO Socket
connectToAddrInfo AddrInfo
ai)
case Either IOError Socket
res of
Left ex :: IOError
ex -> [IOError] -> [AddrInfo] -> IO Socket
attemptConnections (IOError
exIOError -> [IOError] -> [IOError]
forall a. a -> [a] -> [a]
:[IOError]
exs) [AddrInfo]
ais
Right s :: Socket
s -> Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
s
connectToAddrInfo :: AddrInfo -> IO Socket
connectToAddrInfo :: AddrInfo -> IO Socket
connectToAddrInfo 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 -> Socket
s Socket -> IO () -> IO Socket
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> SockAddr -> IO ()
Socket.connect Socket
s (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
info)
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 -> HostName -> IO ()
setupPrivateKey SSLContext
ctx) (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 -> FilePath -> IO ()
setupPrivateKey :: SSLContext -> HostName -> IO ()
setupPrivateKey ctx :: SSLContext
ctx path :: HostName
path =
do HostName
str <- HostName -> IO HostName
readFile HostName
path
SomeKeyPair
key <- HostName -> PemPasswordSupply -> IO SomeKeyPair
PEM.readPrivateKey HostName
str PemPasswordSupply
PEM.PwNone
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