{-# 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
  , 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 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a. MVar a -> a -> IO a
swapMVar (NetworkConnection -> MVar (IO ())
connUpgrade NetworkConnection
c) (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 forall a. Ord a => a -> a -> Bool
> Int
10)
                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]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TerminationReason] -> ShowS
$cshowList :: [TerminationReason] -> ShowS
show :: TerminationReason -> [Char]
$cshow :: TerminationReason -> [Char]
showsPrec :: Int -> TerminationReason -> ShowS
$cshowsPrec :: Int -> 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: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
formatDigest ByteString
expect forall a. [a] -> [a] -> [a]
++
       [Char]
"; got: "    forall a. [a] -> [a] -> [a]
++ 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: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
formatDigest ByteString
expect forall a. [a] -> [a] -> [a]
++
       [Char]
"; got: "    forall a. [a] -> [a] -> [a]
++ 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 = forall a. STM a -> IO a
atomically (forall a. TQueue a -> a -> STM ()
writeTQueue (NetworkConnection -> TQueue ByteString
connOutQueue NetworkConnection
c) ByteString
msg)

recv :: NetworkConnection -> STM [NetworkEvent]
recv :: NetworkConnection -> STM [NetworkEvent]
recv = forall a. TQueue a -> STM [a]
flushTQueue 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 = 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 <- forall a. IO (TQueue a)
newTQueueIO
      TQueue NetworkEvent
inQueue  <- forall a. IO (TQueue a)
newTQueueIO

      MVar (IO ())
upgradeMVar <- forall a. IO (MVar a)
newEmptyMVar

      Async ()
supervisor <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$
                      Int -> IO ()
threadDelay (Int
delay forall a. Num a => a -> a -> a
* Int
1000000) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      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
                 forall a. STM a -> IO a
atomically (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
               forall a. STM a -> IO a
atomically (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 forall a b. (a -> b) -> a -> b
$ do Either SomeException ()
outcome <- 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

      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
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ready forall a b. (a -> b) -> a -> b
$
       do IO ()
checkFingerprints
          forall a b. IO a -> IO b -> IO ()
race_ IO ()
receiveMain 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 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings Rational
ssFloodPenalty   ServerSettings
settings)
                              (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings Rational
ssFloodThreshold ServerSettings
settings)
         forall a. Connection -> TQueue ByteString -> RateLimit -> IO a
sendLoop Connection
h TQueue ByteString
outQueue RateLimit
rate

    presend :: IO Bool
presend =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings TlsMode
ssTls ServerSettings
settings of
        TlsMode
TlsNo  -> Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        TlsMode
TlsYes ->
          do [Text]
txts <- Connection -> IO [Text]
describeCertificates Connection
h
             forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
             forall a. STM a -> IO a
atomically (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue ([Text] -> NetworkEvent
NetworkTLS [Text]
txts))
             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 <- forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
receiveMain forall a b. (a -> b) -> a -> b
$ \Async ()
t ->
                    do forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
upgradeMVar (forall a. Async a -> IO ()
cancel Async ()
t)
                       forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
t
             case Either SomeException ()
r of
               -- network connection closed
               Right () -> 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 <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
                  do TlsParams -> [Char] -> Connection -> IO ()
Hookup.upgradeTls (ServerSettings -> TlsParams
tlsParams ServerSettings
settings) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings [Char]
ssHostName ServerSettings
settings) Connection
h
                     [Text]
txts <- Connection -> IO [Text]
describeCertificates Connection
h
                     forall a. STM a -> IO a
atomically (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue ([Text] -> NetworkEvent
NetworkTLS [Text]
txts))
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

               -- something else went wrong with network IO
               Left SomeException
e -> forall e a. Exception e => e -> IO a
throwIO SomeException
e

    checkFingerprints :: IO ()
checkFingerprints =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings TlsMode
ssTls ServerSettings
settings of
        TlsMode
TlsNo -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TlsMode
_ ->
          do forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe Fingerprint)
ssTlsCertFingerprint   ServerSettings
settings) (Connection -> Fingerprint -> IO ()
checkCertFingerprint   Connection
h)
             forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha1   Connection
h
         FingerprintSha256 ByteString
expect -> (,) ByteString
expect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha256 Connection
h
         FingerprintSha512 ByteString
expect -> (,) ByteString
expect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerCertFingerprintSha512 Connection
h
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. a -> Maybe a
Just ByteString
expect forall a. Eq a => a -> a -> Bool
== Maybe ByteString
got)
       (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha1   Connection
h
         FingerprintSha256 ByteString
expect -> (,) ByteString
expect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha256 Connection
h
         FingerprintSha512 ByteString
expect -> (,) ByteString
expect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
getPeerPubkeyFingerprintSha512 Connection
h
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. a -> Maybe a
Just ByteString
expect forall a. Eq a => a -> a -> Bool
== Maybe ByteString
got)
       (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
     forall a. STM a -> IO a
atomically (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
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse ([Text]
cTxts 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 -> 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
         forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack
              forall a b. (a -> b) -> a -> b
$ (Char
'\^B' forall a. a -> [a] -> [a]
: [Char]
label)
              forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ShowS
colorize ([Char] -> [[Char]]
lines [Char]
str forall a. [a] -> [a] -> [a]
++ [[Char]]
fps)
  where
    colorize :: ShowS
colorize x :: [Char]
x@(Char
' ':[Char]
_) = [Char]
x
    colorize [Char]
xs = [Char]
"\^C07" 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]
"sha1", [Char]
"sha256", [Char]
"sha512"] forall a b. (a -> b) -> a -> b
$ \[Char]
alg ->
              do Maybe Digest
mb <- [Char] -> IO (Maybe Digest)
Digest.getDigestByName [Char]
alg
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe Digest
mb of
                   Maybe Digest
Nothing -> []
                   Just Digest
d ->
                       ([Char]
"Certificate " forall a. [a] -> [a] -> [a]
++ [Char]
alg forall a. [a] -> [a] -> [a]
++ [Char]
" fingerprint:")
                     forall a. a -> [a] -> [a]
: ByteString -> [[Char]]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestLBS Digest
d ByteString
certDer)
                    forall a. [a] -> [a] -> [a]
++ ([Char]
"SPKI " forall a. [a] -> [a] -> [a]
++ [Char]
alg forall a. [a] -> [a] -> [a]
++ [Char]
" fingerprint:")
                     forall a. a -> [a] -> [a]
: ByteString -> [[Char]]
fingerprintLines (Digest -> ByteString -> ByteString
Digest.digestBS Digest
d ByteString
spkiDer)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
xss)

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

formatDigest :: ByteString -> String
formatDigest :: ByteString -> [Char]
formatDigest
  = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
":"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Word8 -> [Char]
showByte
  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 forall a. Ord a => a -> a -> Bool
< Word8
0x10  = Char
'0' forall a. a -> [a] -> [a]
: forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
x [Char]
""
  | Bool
otherwise = forall a. (Integral a, Show 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 =
  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$
  do ByteString
msg <- forall a. STM a -> IO a
atomically (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
4forall a. Num a => a -> a -> a
*Int
ircMaxMessageLength)
     forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ByteString
mb forall a b. (a -> b) -> a -> b
$ \ByteString
msg ->
       do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
msg) forall a b. (a -> b) -> a -> b
$ -- RFC says to ignore empty messages
            do ZonedTime
now <- IO ZonedTime
getZonedTime
               forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue NetworkEvent
inQueue
                          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