{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Main module of the library
-- Contains all the entrypoints
module Discord
( runDiscord
, restCall
, sendCommand
, readCache
, stopDiscord
, getGatewayLatency
, measureLatency
, DiscordHandler
, DiscordHandle
, Cache(..)
, RestCallErrorCode(..)
, RunDiscordOpts(..)
, FromJSON
, Request
, def
) where
import Prelude hiding (log)
import Control.Exception (Exception)
import Control.Monad (void, forever)
import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO, asks)
import Data.Aeson (FromJSON)
import Data.Default (Default, def)
import Data.IORef (writeIORef)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
import UnliftIO (race, try, finally, SomeException, IOException, readIORef)
import UnliftIO.Concurrent
import Discord.Handle
import Discord.Internal.Rest
import Discord.Internal.Rest.User (UserRequest(GetCurrentUser))
import Discord.Internal.Gateway
import qualified Discord.Requests as R
-- | A `ReaderT` wrapper around `DiscordHandle` and `IO`. Most functions act in
-- this monad
type DiscordHandler = ReaderT DiscordHandle IO
-- | Options for the connection.
data RunDiscordOpts = RunDiscordOpts
{ -- | Token for the discord API
discordToken :: T.Text
, -- | Actions executed right after a connexion to discord's API is
-- established
discordOnStart :: DiscordHandler ()
, -- | Actions executed at termination.
--
-- Note that this runs in plain `IO` and not in `DiscordHandler` as the
-- connexion has been closed before this runs.
--
-- Useful for cleaning up.
discordOnEnd :: IO ()
, -- | Actions run upon the reception of an `Event`. This is here most of the
-- code of the bot may get dispatched from.
discordOnEvent :: Event -> DiscordHandler ()
, -- | Dispatching on internal logs
discordOnLog :: T.Text -> IO ()
, -- | Fork a thread for every `Event` recived
discordForkThreadForEvents :: Bool
, -- | The gateway intents the bot is asking for
discordGatewayIntent :: GatewayIntent
, -- | Whether to use the cache (may use a lot of memory, only enable if it will be used!)
discordEnableCache :: Bool
}
-- | Default values for `RunDiscordOpts`
instance Default RunDiscordOpts where
def = RunDiscordOpts { discordToken = ""
, discordOnStart = pure ()
, discordOnEnd = pure ()
, discordOnEvent = \_ -> pure ()
, discordOnLog = \_ -> pure ()
, discordForkThreadForEvents = True
, discordGatewayIntent = def
, discordEnableCache = False
}
-- | Entrypoint to the library
runDiscord :: RunDiscordOpts -> IO T.Text
runDiscord opts = do
log <- newChan
logId <- liftIO $ startLogger (discordOnLog opts) log
(cache, cacheId) <- liftIO $ startCacheThread (discordEnableCache opts) log
(rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log
(gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log
libE <- newEmptyMVar
let handle = DiscordHandle { discordHandleRestChan = rest
, discordHandleGateway = gate
, discordHandleCache = cache
, discordHandleLog = log
, discordHandleLibraryError = libE
, discordHandleThreads =
[ HandleThreadIdLogger logId
, HandleThreadIdRest restId
, HandleThreadIdCache cacheId
, HandleThreadIdGateway gateId
]
}
finally (runDiscordLoop handle opts)
(discordOnEnd opts >> runReaderT stopDiscord handle)
-- | Runs the main loop
runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text
runDiscordLoop handle opts = do
resp <- startupRestCalls
case resp of
Left (RestCallInternalErrorCode c e1 e2) -> libError $
"HTTP Error Code " <> T.pack (show c) <> " " <> TE.decodeUtf8 e1
<> " " <> TE.decodeUtf8 e2
Left (RestCallInternalHttpException e) -> libError ("HTTP Exception - " <> T.pack (show e))
Left (RestCallInternalNoParse e _) -> libError ("Couldn't parse initial bot info - " <> T.pack e)
Right (user, app) -> do initializeCache user app (discordHandleCache handle)
me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle
case me of
Left (e :: SomeException) -> libError ("discordOnStart handler stopped on an exception:\n\n" <> T.pack (show e))
Right _ -> loop
where
startupRestCalls :: IO (Either RestCallInternalException (User, FullApplication))
startupRestCalls = do eUser <- writeRestCall (discordHandleRestChan handle) R.GetCurrentUser
eApp <- writeRestCall (discordHandleRestChan handle) R.GetCurrentApplication
pure $ (,) <$> eUser <*> eApp
libError :: T.Text -> IO T.Text
libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg
loop :: IO T.Text
loop = do next <- race (readMVar (discordHandleLibraryError handle))
(readChan (gatewayHandleEvents (discordHandleGateway handle)))
case next of
Left err -> libError err
Right (Left err) -> libError (T.pack (show err))
Right (Right event) -> do
let userEvent = userFacingEvent event
let action = if discordForkThreadForEvents opts then void . forkIO
else id
action $ do me <- liftIO . runReaderT (try $ discordOnEvent opts userEvent) $ handle
case me of
Left (e :: SomeException) -> writeChan (discordHandleLog handle)
("eventhandler - crashed on [" <> T.pack (show userEvent) <> "] "
<> " with error: " <> T.pack (show e))
Right _ -> pure ()
loop
-- | A Error code following a rest call
data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text
deriving (Show, Read, Eq, Ord)
instance Exception RestCallErrorCode
-- | Execute one http request and get a response
restCall :: (Request (r a), FromJSON a) => r a -> DiscordHandler (Either RestCallErrorCode a)
restCall r = do h <- ask
empty <- isEmptyMVar (discordHandleLibraryError h)
if not empty
then pure (Left (RestCallErrorCode 400 "Library Stopped Working" ""))
else do
resp <- liftIO $ writeRestCall (discordHandleRestChan h) r
case resp of
Right x -> pure (Right x)
Left (RestCallInternalErrorCode c e1 e2) -> do
pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2)))
Left (RestCallInternalHttpException _) ->
threadDelay (10 * 10^(6 :: Int)) >> restCall r
Left (RestCallInternalNoParse err dat) -> do
let formaterr = T.pack ("restcall - parse exception [" <> err <> "]"
<> " while handling" <> show dat)
writeChan (discordHandleLog h) formaterr
pure (Left (RestCallErrorCode 400 "Library Parse Exception" formaterr))
-- | Send a user GatewaySendable
sendCommand :: GatewaySendable -> DiscordHandler ()
sendCommand e = do
h <- ask
writeChan (gatewayHandleUserSendables (discordHandleGateway h)) e
case e of
UpdateStatus opts -> liftIO $ writeIORef (gatewayHandleLastStatus (discordHandleGateway h)) (Just opts)
_ -> pure ()
-- | Access the current state of the gateway cache
readCache :: DiscordHandler Cache
readCache = do
h <- ask
readMVar (cacheHandleCache (discordHandleCache h))
-- | Stop all the background threads
stopDiscord :: DiscordHandler ()
stopDiscord = do h <- ask
_ <- tryPutMVar (discordHandleLibraryError h) "Library has closed"
threadDelay (10^(6 :: Int) `div` 10)
mapM_ (killThread . toId) (discordHandleThreads h)
where toId t = case t of
HandleThreadIdRest a -> a
HandleThreadIdGateway a -> a
HandleThreadIdCache a -> a
HandleThreadIdLogger a -> a
-- | Starts the internal logger
startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId
startLogger handle logC = forkIO $ forever $
do me <- try $ readChan logC >>= handle
case me of
Right _ -> pure ()
Left (_ :: IOException) ->
-- writeChan logC "Log handler failed"
pure ()
-- | Read the gateway latency from the last time we sent and received a
-- Heartbeat. From Europe tends to give ~110ms
getGatewayLatency :: DiscordHandler NominalDiffTime
getGatewayLatency = do
gw <- asks discordHandleGateway
(send1, send2) <- readIORef (gatewayHandleHeartbeatTimes gw)
ack <- readIORef (gatewayHandleHeartbeatAckTimes gw)
pure . diffUTCTime ack $
if ack > send1 -- if the ack is before the send just gone, use the previous send
then send1
else send2
-- | Measure the current latency by making a request and measuring the time
-- taken. From Europe tends to give 200ms-800ms.
--
-- The request is getting the bot's user, which requires the `identify` scope.
measureLatency :: DiscordHandler NominalDiffTime
measureLatency = do
startTime <- liftIO getCurrentTime
_ <- restCall GetCurrentUser
endTime <- liftIO getCurrentTime
pure $ diffUTCTime endTime startTime
-- internal note: it seems bad that it's taking 2x-8x as much time to perform
-- this specific request, considering that the latency we expect is much less.
-- might be worth looking into efficiencies or a better event to use.