{-# Options_GHC -Wno-unused-do-bind #-}
{-# Language OverloadedStrings #-}
module Client.Network.Async
( NetworkConnection
, NetworkEvent(..)
, createConnection
, Client.Network.Async.send
, Client.Network.Async.recv
, upgrade
, abortConnection
, TerminationReason(..)
) where
import Client.Configuration.ServerSettings
import Client.Network.Connect
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Foldable
import Data.List
import Data.List.Split (chunksOf)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Data.Traversable
import Data.Word (Word8)
import Hookup
import Hookup.OpenSSL (getPubKeyDer)
import Irc.RateLimit
import Numeric (showHex)
import qualified OpenSSL.EVP.Digest as Digest
import OpenSSL.X509 (X509, printX509, writeDerX509)
data NetworkConnection = NetworkConnection
{ NetworkConnection -> TQueue ByteString
connOutQueue :: TQueue ByteString
, NetworkConnection -> TQueue NetworkEvent
connInQueue :: TQueue NetworkEvent
, NetworkConnection -> Async ()
connAsync :: Async ()
, NetworkConnection -> MVar (IO ())
connUpgrade :: MVar (IO ())
}
upgrade :: NetworkConnection -> IO ()
upgrade :: NetworkConnection -> IO ()
upgrade NetworkConnection
c = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (MVar (IO ()) -> IO () -> IO (IO ())
forall a. MVar a -> a -> IO a
swapMVar (NetworkConnection -> MVar (IO ())
connUpgrade NetworkConnection
c) (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
data NetworkEvent
= NetworkOpen !ZonedTime
| NetworkTLS [Text]
| NetworkLine !ZonedTime !ByteString
| NetworkError !ZonedTime !SomeException
| NetworkClose !ZonedTime
instance Show NetworkConnection where
showsPrec :: Int -> NetworkConnection -> ShowS
showsPrec Int
p NetworkConnection
_ = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
(ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"NetworkConnection _"
data TerminationReason
= PingTimeout
| ForcedDisconnect
| StsUpgrade
| StartTLSFailed
| BadCertFingerprint ByteString (Maybe ByteString)
| BadPubkeyFingerprint ByteString (Maybe ByteString)
deriving Int -> TerminationReason -> ShowS
[TerminationReason] -> ShowS
TerminationReason -> String
(Int -> TerminationReason -> ShowS)
-> (TerminationReason -> String)
-> ([TerminationReason] -> ShowS)
-> Show TerminationReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerminationReason] -> ShowS
$cshowList :: [TerminationReason] -> ShowS
show :: TerminationReason -> String
$cshow :: TerminationReason -> String
showsPrec :: Int -> TerminationReason -> ShowS
$cshowsPrec :: Int -> TerminationReason -> ShowS
Show
instance Exception TerminationReason where
displayException :: TerminationReason -> String
displayException TerminationReason
PingTimeout = String
"connection killed due to ping timeout"
displayException TerminationReason
ForcedDisconnect = String
"connection killed by client command"
displayException TerminationReason
StsUpgrade = String
"connection killed by sts policy"
displayException TerminationReason
StartTLSFailed = String
"connection killed due to failed STARTTLS"
displayException (BadCertFingerprint ByteString
expect Maybe ByteString
got) =
String
"Expected certificate fingerprint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
formatDigest ByteString
expect String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"; got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"none" ByteString -> String
formatDigest Maybe ByteString
got
displayException (BadPubkeyFingerprint ByteString
expect Maybe ByteString
got) =
String
"Expected public key fingerprint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
formatDigest ByteString
expect String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"; got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"none" ByteString -> String
formatDigest Maybe ByteString
got
send :: NetworkConnection -> ByteString -> IO ()
send :: NetworkConnection -> ByteString -> IO ()
send NetworkConnection
c ByteString
msg = STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (NetworkConnection -> TQueue ByteString
connOutQueue NetworkConnection
c) ByteString
msg)
recv :: NetworkConnection -> STM [NetworkEvent]
recv :: NetworkConnection -> STM [NetworkEvent]
recv = TQueue NetworkEvent -> STM [NetworkEvent]
forall a. TQueue a -> STM [a]
flushTQueue (TQueue NetworkEvent -> STM [NetworkEvent])
-> (NetworkConnection -> TQueue NetworkEvent)
-> NetworkConnection
-> STM [NetworkEvent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkConnection -> TQueue NetworkEvent
connInQueue
abortConnection :: TerminationReason -> NetworkConnection -> IO ()
abortConnection :: TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
reason NetworkConnection
c = Async () -> TerminationReason -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith (NetworkConnection -> Async ()
connAsync NetworkConnection
c) TerminationReason
reason
createConnection ::
Int ->
ServerSettings ->
IO NetworkConnection
createConnection :: Int -> ServerSettings -> IO NetworkConnection
createConnection Int
delay ServerSettings
settings =
do TQueue ByteString
outQueue <- IO (TQueue ByteString)
forall a. IO (TQueue a)
newTQueueIO
TQueue NetworkEvent
inQueue <- IO (TQueue NetworkEvent)
forall a. IO (TQueue a)
newTQueueIO
MVar (IO ())
upgradeMVar <- IO (MVar (IO ()))
forall a. IO (MVar a)
newEmptyMVar
Async ()
supervisor <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
Int -> IO ()
threadDelay (Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
ServerSettings -> (Connection -> IO ()) -> IO ()
forall a. ServerSettings -> (Connection -> IO a) -> IO a
withConnection ServerSettings
settings
(ServerSettings
-> TQueue NetworkEvent
-> TQueue ByteString
-> MVar (IO ())
-> Connection
-> IO ()
startConnection ServerSettings
settings TQueue NetworkEvent
inQueue TQueue ByteString
outQueue MVar (IO ())
upgradeMVar)
let recordFailure :: SomeException -> IO ()
recordFailure :: SomeException -> IO ()
recordFailure SomeException
ex =
do ZonedTime
now <- IO ZonedTime
getZonedTime
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue (ZonedTime -> SomeException -> NetworkEvent
NetworkError ZonedTime
now SomeException
ex))
recordNormalExit :: IO ()
recordNormalExit :: IO ()
recordNormalExit =
do ZonedTime
now <- IO ZonedTime
getZonedTime
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue (ZonedTime -> NetworkEvent
NetworkClose ZonedTime
now))
IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do Either SomeException ()
outcome <- Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
supervisor
case Either SomeException ()
outcome of
Right{} -> IO ()
recordNormalExit
Left SomeException
e -> SomeException -> IO ()
recordFailure SomeException
e
NetworkConnection -> IO NetworkConnection
forall (m :: * -> *) a. Monad m => a -> m a
return NetworkConnection :: TQueue ByteString
-> TQueue NetworkEvent
-> Async ()
-> MVar (IO ())
-> NetworkConnection
NetworkConnection
{ connOutQueue :: TQueue ByteString
connOutQueue = TQueue ByteString
outQueue
, connInQueue :: TQueue NetworkEvent
connInQueue = TQueue NetworkEvent
inQueue
, connAsync :: Async ()
connAsync = Async ()
supervisor
, connUpgrade :: MVar (IO ())
connUpgrade = MVar (IO ())
upgradeMVar
}
startConnection ::
ServerSettings ->
TQueue NetworkEvent ->
TQueue ByteString ->
MVar (IO ()) ->
Connection ->
IO ()
startConnection :: ServerSettings
-> TQueue NetworkEvent
-> TQueue ByteString
-> MVar (IO ())
-> Connection
-> IO ()
startConnection ServerSettings
settings TQueue NetworkEvent
inQueue TQueue ByteString
outQueue MVar (IO ())
upgradeMVar Connection
h =
do TQueue NetworkEvent -> IO ()
reportNetworkOpen TQueue NetworkEvent
inQueue
Bool
ready <- IO Bool
presend
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do IO ()
checkFingerprints
IO () -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ IO ()
receiveMain IO Any
forall b. IO b
sendMain
where
receiveMain :: IO ()
receiveMain = Connection -> TQueue NetworkEvent -> IO ()
receiveLoop Connection
h TQueue NetworkEvent
inQueue
sendMain :: IO b
sendMain =
do RateLimit
rate <- Rational -> Rational -> IO RateLimit
newRateLimit (Getting Rational ServerSettings Rational
-> ServerSettings -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational ServerSettings Rational
Lens' ServerSettings Rational
ssFloodPenalty ServerSettings
settings)
(Getting Rational ServerSettings Rational
-> ServerSettings -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational ServerSettings Rational
Lens' ServerSettings Rational
ssFloodThreshold ServerSettings
settings)
Connection -> TQueue ByteString -> RateLimit -> IO b
forall a. Connection -> TQueue ByteString -> RateLimit -> IO a
sendLoop Connection
h TQueue ByteString
outQueue RateLimit
rate
presend :: IO Bool
presend =
case Getting TlsMode ServerSettings TlsMode -> ServerSettings -> TlsMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TlsMode ServerSettings TlsMode
Lens' ServerSettings TlsMode
ssTls ServerSettings
settings of
TlsMode
TlsNo -> Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
TlsMode
TlsYes ->
do [Text]
txts <- Connection -> IO [Text]
describeCertificates Connection
h
MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue ([Text] -> NetworkEvent
NetworkTLS [Text]
txts))
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
TlsMode
TlsStart ->
do Connection -> ByteString -> IO ()
Hookup.send Connection
h ByteString
"STARTTLS\n"
Either SomeException ()
r <- IO ()
-> (Async () -> IO (Either SomeException ()))
-> IO (Either SomeException ())
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
receiveMain ((Async () -> IO (Either SomeException ()))
-> IO (Either SomeException ()))
-> (Async () -> IO (Either SomeException ()))
-> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ \Async ()
t ->
do MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
t)
Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
t
case Either SomeException ()
r of
Right () -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Left SomeException
e | Just AsyncCancelled
AsyncCancelled <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
do TlsParams -> String -> Connection -> IO ()
Hookup.upgradeTls (ServerSettings -> TlsParams
tlsParams ServerSettings
settings) (Getting String ServerSettings String -> ServerSettings -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String ServerSettings String
Lens' ServerSettings String
ssHostName ServerSettings
settings) Connection
h
[Text]
txts <- Connection -> IO [Text]
describeCertificates Connection
h
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue ([Text] -> NetworkEvent
NetworkTLS [Text]
txts))
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Left SomeException
e -> SomeException -> IO Bool
forall e a. Exception e => e -> IO a
throwIO SomeException
e
checkFingerprints :: IO ()
checkFingerprints =
case Getting TlsMode ServerSettings TlsMode -> ServerSettings -> TlsMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TlsMode ServerSettings TlsMode
Lens' ServerSettings TlsMode
ssTls ServerSettings
settings of
TlsMode
TlsNo -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TlsMode
_ ->
do Maybe Fingerprint -> (Fingerprint -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Getting (Maybe Fingerprint) ServerSettings (Maybe Fingerprint)
-> ServerSettings -> Maybe Fingerprint
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Fingerprint) ServerSettings (Maybe Fingerprint)
Lens' ServerSettings (Maybe Fingerprint)
ssTlsCertFingerprint ServerSettings
settings) (Connection -> Fingerprint -> IO ()
checkCertFingerprint Connection
h)
Maybe Fingerprint -> (Fingerprint -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Getting (Maybe Fingerprint) ServerSettings (Maybe Fingerprint)
-> ServerSettings -> Maybe Fingerprint
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Fingerprint) ServerSettings (Maybe Fingerprint)
Lens' ServerSettings (Maybe Fingerprint)
ssTlsPubkeyFingerprint ServerSettings
settings) (Connection -> Fingerprint -> IO ()
checkPubkeyFingerprint Connection
h)
checkCertFingerprint :: Connection -> Fingerprint -> IO ()
checkCertFingerprint :: Connection -> Fingerprint -> IO ()
checkCertFingerprint Connection
h Fingerprint
fp =
do (ByteString
expect, Maybe ByteString
got) <-
case Fingerprint
fp of
FingerprintSha1 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1 Connection
h
FingerprintSha256 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 Connection
h
FingerprintSha512 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 Connection
h
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
expect Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
got)
(TerminationReason -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ByteString -> Maybe ByteString -> TerminationReason
BadCertFingerprint ByteString
expect Maybe ByteString
got))
checkPubkeyFingerprint :: Connection -> Fingerprint -> IO ()
checkPubkeyFingerprint :: Connection -> Fingerprint -> IO ()
checkPubkeyFingerprint Connection
h Fingerprint
fp =
do (ByteString
expect, Maybe ByteString
got) <-
case Fingerprint
fp of
FingerprintSha1 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha1 Connection
h
FingerprintSha256 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 Connection
h
FingerprintSha512 ByteString
expect -> (,) ByteString
expect (Maybe ByteString -> (ByteString, Maybe ByteString))
-> IO (Maybe ByteString) -> IO (ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 Connection
h
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
expect Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
got)
(TerminationReason -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ByteString -> Maybe ByteString -> TerminationReason
BadPubkeyFingerprint ByteString
expect Maybe ByteString
got))
reportNetworkOpen :: TQueue NetworkEvent -> IO ()
reportNetworkOpen :: TQueue NetworkEvent -> IO ()
reportNetworkOpen TQueue NetworkEvent
inQueue =
do ZonedTime
now <- IO ZonedTime
getZonedTime
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue (ZonedTime -> NetworkEvent
NetworkOpen ZonedTime
now))
describeCertificates :: Connection -> IO [Text]
describeCertificates :: Connection -> IO [Text]
describeCertificates Connection
h =
do Maybe X509
mbServer <- Connection -> IO (Maybe X509)
getPeerCertificate Connection
h
Maybe X509
mbClient <- Connection -> IO (Maybe X509)
getClientCertificate Connection
h
[Text]
cTxts <- String -> Maybe X509 -> IO [Text]
certText String
"Server" Maybe X509
mbServer
[Text]
sTxts <- String -> Maybe X509 -> IO [Text]
certText String
"Client" Maybe X509
mbClient
[Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text]
cTxts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
sTxts))
certText :: String -> Maybe X509 -> IO [Text]
certText :: String -> Maybe X509 -> IO [Text]
certText String
label Maybe X509
mbX509 =
case Maybe X509
mbX509 of
Maybe X509
Nothing -> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just X509
x509 ->
do String
str <- X509 -> IO String
printX509 X509
x509
[String]
fps <- X509 -> IO [String]
getFingerprints X509
x509
[Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack
([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char
'\^B' Char -> ShowS
forall a. a -> [a] -> [a]
: String
label)
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
colorize (String -> [String]
lines String
str [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
fps)
where
colorize :: ShowS
colorize x :: String
x@(Char
' ':String
_) = String
x
colorize String
xs = String
"\^C07" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
getFingerprints :: X509 -> IO [String]
getFingerprints :: X509 -> IO [String]
getFingerprints X509
x509 =
do ByteString
certDer <- X509 -> IO ByteString
writeDerX509 X509
x509
ByteString
spkiDer <- X509 -> IO ByteString
getPubKeyDer X509
x509
[[String]]
xss <- [String] -> (String -> IO [String]) -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String
"sha1", String
"sha256", String
"sha512"] ((String -> IO [String]) -> IO [[String]])
-> (String -> IO [String]) -> IO [[String]]
forall a b. (a -> b) -> a -> b
$ \String
alg ->
do Maybe Digest
mb <- String -> IO (Maybe Digest)
Digest.getDigestByName String
alg
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case Maybe Digest
mb of
Maybe Digest
Nothing -> []
Just Digest
d ->
(String
"Certificate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
alg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" fingerprint:")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ByteString -> [String]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestLBS Digest
d ByteString
certDer)
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String
"SPKI " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
alg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" fingerprint:")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ByteString -> [String]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestBS Digest
d ByteString
spkiDer)
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
xss)
fingerprintLines :: ByteString -> [String]
fingerprintLines :: ByteString -> [String]
fingerprintLines
= ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++)
([String] -> [String])
-> (ByteString -> [String]) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf (Int
16Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
3)
(String -> [String])
-> (ByteString -> String) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
formatDigest
formatDigest :: ByteString -> String
formatDigest :: ByteString -> String
formatDigest
= String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":"
([String] -> String)
-> (ByteString -> [String]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> String) -> [Word8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> String
showByte
([Word8] -> [String])
-> (ByteString -> [Word8]) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack
showByte :: Word8 -> String
showByte :: Word8 -> String
showByte Word8
x
| Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x10 = Char
'0' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
x String
""
| Bool
otherwise = Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
x String
""
sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO a
sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO a
sendLoop Connection
h TQueue ByteString
outQueue RateLimit
rate =
IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$
do ByteString
msg <- STM ByteString -> IO ByteString
forall a. STM a -> IO a
atomically (TQueue ByteString -> STM ByteString
forall a. TQueue a -> STM a
readTQueue TQueue ByteString
outQueue)
RateLimit -> IO ()
tickRateLimit RateLimit
rate
Connection -> ByteString -> IO ()
Hookup.send Connection
h ByteString
msg
ircMaxMessageLength :: Int
ircMaxMessageLength :: Int
ircMaxMessageLength = Int
512
receiveLoop :: Connection -> TQueue NetworkEvent -> IO ()
receiveLoop :: Connection -> TQueue NetworkEvent -> IO ()
receiveLoop Connection
h TQueue NetworkEvent
inQueue =
do Maybe ByteString
mb <- Connection -> Int -> IO (Maybe ByteString)
recvLine Connection
h (Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
ircMaxMessageLength)
Maybe ByteString -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ByteString
mb ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
msg ->
do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
msg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do ZonedTime
now <- IO ZonedTime
getZonedTime
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue NetworkEvent -> NetworkEvent -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue
(NetworkEvent -> STM ()) -> NetworkEvent -> STM ()
forall a b. (a -> b) -> a -> b
$ ZonedTime -> ByteString -> NetworkEvent
NetworkLine ZonedTime
now ByteString
msg
Connection -> TQueue NetworkEvent -> IO ()
receiveLoop Connection
h TQueue NetworkEvent
inQueue