{-# Options_GHC -Wno-unused-do-bind #-}
{-# Language OverloadedStrings #-}
{-|
Module      : Client.Network.Async
Description : Event-based network IO
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module creates network connections and thread to manage those connections.
Events on these connections will be written to a given event queue, and
outgoing messages are recieved on an incoming event queue.

These network connections are rate limited for outgoing messages per the
rate limiting algorithm given in the IRC RFC.

Incoming network event messages are assumed to be framed by newlines.

When a network connection terminates normally its final messages will be
'NetworkClose'. When it terminates abnormally its final message will be
'NetworkError'.

-}

module Client.Network.Async
  ( NetworkConnection
  , NetworkEvent(..)
  , createConnection
  , Client.Network.Async.send
  , sendNext
  , Client.Network.Async.recv
  , upgrade

  -- * Abort connections
  , abortConnection
  , TerminationReason(..)
  ) where

import Client.Configuration.ServerSettings
import Client.Network.Connect (withConnection, tlsParams)
import Control.Concurrent (MVar, swapMVar, threadDelay, forkIO, newEmptyMVar, putMVar)
import Control.Concurrent.Async (Async, async, cancel, cancelWith, race_, waitCatch, withAsync, AsyncCancelled(AsyncCancelled))
import Control.Concurrent.STM
import Control.Exception (SomeException, Exception(fromException, displayException), throwIO)
import Control.Lens (view)
import Control.Monad (join, when, forever, unless)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Foldable (for_)
import Data.List (intercalate)
import Data.List.Split (chunksOf)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (ZonedTime, getZonedTime)
import Data.Traversable (for)
import Data.Word (Word8)
import Hookup
import Hookup.OpenSSL (getPubKeyDer)
import Irc.RateLimit (RateLimit, newRateLimit, tickRateLimit)
import Numeric (showHex)
import OpenSSL.EVP.Digest qualified as Digest
import OpenSSL.X509 (X509, printX509, writeDerX509)


-- | Handle for a network connection
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 ())
  }

-- | Signals that the server is ready to initiate the TLS handshake.
-- This is a no-op when not in a starttls state.
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

-- | The sum of incoming events from a network connection. All events
-- are annotated with a network ID matching that given when the connection
-- was created as well as the time at which the message was recieved.
data NetworkEvent
  -- | Event for successful connection to host (certificate lines)
  = NetworkOpen  !ZonedTime
  -- | Event indicating TLS is in effect
  | NetworkTLS  [Text]
  -- | Event for a new recieved line (newline removed)
  | NetworkLine  !ZonedTime !ByteString
  -- | Report an error on network connection network connection failed
  | NetworkError !ZonedTime !SomeException
  -- | Final message indicating the network connection finished
  | 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
$ [Char] -> ShowS
showString [Char]
"NetworkConnection _"

-- | Exceptions used to kill connections manually.
data TerminationReason
  = PingTimeout      -- ^ sent when ping timer expires
  | ForcedDisconnect -- ^ sent when client commands force disconnect
  | StsUpgrade       -- ^ sent when the client disconnects due to sts policy
  | StartTLSFailed   -- ^ STARTTLS was expected by server had an error
  | BadCertFingerprint ByteString (Maybe ByteString)
  | BadPubkeyFingerprint ByteString (Maybe ByteString)
  deriving Int -> TerminationReason -> ShowS
[TerminationReason] -> ShowS
TerminationReason -> [Char]
(Int -> TerminationReason -> ShowS)
-> (TerminationReason -> [Char])
-> ([TerminationReason] -> ShowS)
-> Show TerminationReason
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TerminationReason -> ShowS
showsPrec :: Int -> TerminationReason -> ShowS
$cshow :: TerminationReason -> [Char]
show :: TerminationReason -> [Char]
$cshowList :: [TerminationReason] -> ShowS
showList :: [TerminationReason] -> ShowS
Show

instance Exception TerminationReason where
  displayException :: TerminationReason -> [Char]
displayException TerminationReason
PingTimeout      = [Char]
"connection killed due to ping timeout"
  displayException TerminationReason
ForcedDisconnect = [Char]
"connection killed by client command"
  displayException TerminationReason
StsUpgrade       = [Char]
"connection killed by sts policy"
  displayException TerminationReason
StartTLSFailed   = [Char]
"connection killed due to failed STARTTLS"
  displayException (BadCertFingerprint ByteString
expect Maybe ByteString
got) =
       [Char]
"Expected certificate fingerprint: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
formatDigest ByteString
expect [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
       [Char]
"; got: "    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> (ByteString -> [Char]) -> Maybe ByteString -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" ByteString -> [Char]
formatDigest Maybe ByteString
got
  displayException (BadPubkeyFingerprint ByteString
expect Maybe ByteString
got) =
       [Char]
"Expected public key fingerprint: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
formatDigest ByteString
expect [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
       [Char]
"; got: "    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> (ByteString -> [Char]) -> Maybe ByteString -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none" ByteString -> [Char]
formatDigest Maybe ByteString
got

-- | Schedule a message to be transmitted on the network connection.
-- These messages are sent unmodified. The message should contain a
-- newline terminator.
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)

-- | Insert a message to be transmitted on the network connection immediately.
-- These messages are sent unmodified. The message should contain a
-- newline terminator. This should be used for very high priority messages
-- that must not get stuck in the queue.
sendNext :: NetworkConnection -> ByteString -> IO ()
sendNext :: NetworkConnection -> ByteString -> IO ()
sendNext NetworkConnection
c ByteString
msg = STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue (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

-- | Force the given connection to terminate.
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

-- | Initiate a new network connection according to the given 'ServerSettings'.
-- All events on this connection will be added to the given queue. The resulting
-- 'NetworkConnection' value can be used for sending outgoing messages and for
-- early termination of the connection.
createConnection ::
  Int {- ^ delay in seconds -} ->
  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 a b. IO a -> IO b -> IO b
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))

      -- Having this reporting thread separate from the supervisor ensures
      -- that canceling the supervisor with abortConnection doesn't interfere
      -- with carefully reporting the outcome
      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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 a b. a -> IO b -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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
               -- network connection closed
               Right () -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

               -- pre-receiver was killed by a call to 'upgrade'
               Left SomeException
e | Just AsyncCancelled
AsyncCancelled <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
                  do TlsParams -> [Char] -> Connection -> IO ()
Hookup.upgradeTls (ServerSettings -> TlsParams
tlsParams ServerSettings
settings) (Getting [Char] ServerSettings [Char] -> ServerSettings -> [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Char] ServerSettings [Char]
Lens' ServerSettings [Char]
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

               -- something else went wrong with network IO
               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 a. a -> IO a
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 <- [Char] -> Maybe X509 -> IO [Text]
certText [Char]
"Server" Maybe X509
mbServer
     [Text]
sTxts <- [Char] -> Maybe X509 -> IO [Text]
certText [Char]
"Client" Maybe X509
mbClient
     [Text] -> IO [Text]
forall a. a -> IO a
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 :: [Char] -> Maybe X509 -> IO [Text]
certText [Char]
label Maybe X509
mbX509 =
  case Maybe X509
mbX509 of
    Maybe X509
Nothing -> [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just X509
x509 ->
      do [Char]
str <- X509 -> IO [Char]
printX509 X509
x509
         [[Char]]
fps <- X509 -> IO [[Char]]
getFingerprints X509
x509
         [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack
              ([[Char]] -> [Text]) -> [[Char]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char
'\^B' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
label)
              [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
colorize ([Char] -> [[Char]]
lines [Char]
str [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
fps)
  where
    colorize :: ShowS
colorize x :: [Char]
x@(Char
' ':[Char]
_) = [Char]
x
    colorize [Char]
xs = [Char]
"\^C07" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
xs

getFingerprints :: X509 -> IO [String]
getFingerprints :: X509 -> IO [[Char]]
getFingerprints X509
x509 =
  do ByteString
certDer <- X509 -> IO ByteString
writeDerX509 X509
x509
     ByteString
spkiDer <- X509 -> IO ByteString
getPubKeyDer X509
x509
     [[[Char]]]
xss <- [[Char]] -> ([Char] -> IO [[Char]]) -> IO [[[Char]]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]
"sha1", [Char]
"sha256", [Char]
"sha512"] (([Char] -> IO [[Char]]) -> IO [[[Char]]])
-> ([Char] -> IO [[Char]]) -> IO [[[Char]]]
forall a b. (a -> b) -> a -> b
$ \[Char]
alg ->
              do Maybe Digest
mb <- [Char] -> IO (Maybe Digest)
Digest.getDigestByName [Char]
alg
                 [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ case Maybe Digest
mb of
                   Maybe Digest
Nothing -> []
                   Just Digest
d ->
                       ([Char]
"Certificate " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
alg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" fingerprint:")
                     [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ByteString -> [[Char]]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestLBS Digest
d ByteString
certDer)
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char]
"SPKI " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
alg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" fingerprint:")
                     [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ByteString -> [[Char]]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestBS Digest
d ByteString
spkiDer)
     [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
xss)

fingerprintLines :: ByteString -> [String]
fingerprintLines :: ByteString -> [[Char]]
fingerprintLines
  = ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)
  ([[Char]] -> [[Char]])
-> (ByteString -> [[Char]]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [[Char]]
forall e. Int -> [e] -> [[e]]
chunksOf (Int
16Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
3)
  ([Char] -> [[Char]])
-> (ByteString -> [Char]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
formatDigest

formatDigest :: ByteString -> String
formatDigest :: ByteString -> [Char]
formatDigest
  = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
":"
  ([[Char]] -> [Char])
-> (ByteString -> [[Char]]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char]) -> [Word8] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> [Char]
showByte
  ([Word8] -> [[Char]])
-> (ByteString -> [Word8]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack

showByte :: Word8 -> String
showByte :: Word8 -> [Char]
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 => a -> ShowS
showHex Word8
x [Char]
""
  | Bool
otherwise = Word8 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word8
x [Char]
""

sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO a
sendLoop :: forall a. 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
$ -- RFC says to ignore empty messages
            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