{-# 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
    RunDiscordOpts -> Text
discordToken :: T.Text
  , -- | Actions executed right after a connexion to discord's API is
    -- established
    RunDiscordOpts -> DiscordHandler ()
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.
    RunDiscordOpts -> IO ()
discordOnEnd :: IO ()
  , -- | Actions run upon the reception of an `Event`. This is here most of the
    -- code of the bot may get dispatched from.
    RunDiscordOpts -> Event -> DiscordHandler ()
discordOnEvent :: Event -> DiscordHandler ()
  , -- | Dispatching on internal logs
    RunDiscordOpts -> Text -> IO ()
discordOnLog :: T.Text -> IO ()
  , -- | Fork a thread for every `Event` recived
    RunDiscordOpts -> Bool
discordForkThreadForEvents :: Bool
  , -- | The gateway intents the bot is asking for
    RunDiscordOpts -> GatewayIntent
discordGatewayIntent :: GatewayIntent
  , -- | Whether to use the cache (may use a lot of memory, only enable if it will be used!)
    RunDiscordOpts -> Bool
discordEnableCache :: Bool
  }

-- | Default values for `RunDiscordOpts`
instance Default RunDiscordOpts where
  def :: RunDiscordOpts
def = RunDiscordOpts { discordToken :: Text
discordToken = Text
""
                       , discordOnStart :: DiscordHandler ()
discordOnStart = () -> DiscordHandler ()
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                       , discordOnEnd :: IO ()
discordOnEnd = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                       , discordOnEvent :: Event -> DiscordHandler ()
discordOnEvent = \Event
_ -> () -> DiscordHandler ()
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                       , discordOnLog :: Text -> IO ()
discordOnLog = \Text
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                       , discordForkThreadForEvents :: Bool
discordForkThreadForEvents = Bool
True
                       , discordGatewayIntent :: GatewayIntent
discordGatewayIntent = GatewayIntent
forall a. Default a => a
def
                       , discordEnableCache :: Bool
discordEnableCache = Bool
False
                       }

-- | Entrypoint to the library 
runDiscord :: RunDiscordOpts -> IO T.Text
runDiscord :: RunDiscordOpts -> IO Text
runDiscord RunDiscordOpts
opts = do
  Chan Text
log <- IO (Chan Text)
forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan
  ThreadId
logId <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (Text -> IO ()) -> Chan Text -> IO ThreadId
startLogger (RunDiscordOpts -> Text -> IO ()
discordOnLog RunDiscordOpts
opts) Chan Text
log
  (CacheHandle
cache, ThreadId
cacheId) <- IO (CacheHandle, ThreadId) -> IO (CacheHandle, ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CacheHandle, ThreadId) -> IO (CacheHandle, ThreadId))
-> IO (CacheHandle, ThreadId) -> IO (CacheHandle, ThreadId)
forall a b. (a -> b) -> a -> b
$ Bool -> Chan Text -> IO (CacheHandle, ThreadId)
startCacheThread (RunDiscordOpts -> Bool
discordEnableCache RunDiscordOpts
opts) Chan Text
log
  (RestChanHandle
rest, ThreadId
restId) <- IO (RestChanHandle, ThreadId) -> IO (RestChanHandle, ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RestChanHandle, ThreadId) -> IO (RestChanHandle, ThreadId))
-> IO (RestChanHandle, ThreadId) -> IO (RestChanHandle, ThreadId)
forall a b. (a -> b) -> a -> b
$ Auth -> Chan Text -> IO (RestChanHandle, ThreadId)
startRestThread (Text -> Auth
Auth (RunDiscordOpts -> Text
discordToken RunDiscordOpts
opts)) Chan Text
log
  (GatewayHandle
gate, ThreadId
gateId) <- IO (GatewayHandle, ThreadId) -> IO (GatewayHandle, ThreadId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GatewayHandle, ThreadId) -> IO (GatewayHandle, ThreadId))
-> IO (GatewayHandle, ThreadId) -> IO (GatewayHandle, ThreadId)
forall a b. (a -> b) -> a -> b
$ Auth
-> GatewayIntent
-> CacheHandle
-> Chan Text
-> IO (GatewayHandle, ThreadId)
startGatewayThread (Text -> Auth
Auth (RunDiscordOpts -> Text
discordToken RunDiscordOpts
opts)) (RunDiscordOpts -> GatewayIntent
discordGatewayIntent RunDiscordOpts
opts) CacheHandle
cache Chan Text
log

  MVar Text
libE <- IO (MVar Text)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar

  let handle :: DiscordHandle
handle = DiscordHandle { discordHandleRestChan :: RestChanHandle
discordHandleRestChan = RestChanHandle
rest
                             , discordHandleGateway :: GatewayHandle
discordHandleGateway = GatewayHandle
gate
                             , discordHandleCache :: CacheHandle
discordHandleCache = CacheHandle
cache
                             , discordHandleLog :: Chan Text
discordHandleLog = Chan Text
log
                             , discordHandleLibraryError :: MVar Text
discordHandleLibraryError = MVar Text
libE
                             , discordHandleThreads :: [HandleThreadId]
discordHandleThreads =
                                 [ ThreadId -> HandleThreadId
HandleThreadIdLogger ThreadId
logId
                                 , ThreadId -> HandleThreadId
HandleThreadIdRest ThreadId
restId
                                 , ThreadId -> HandleThreadId
HandleThreadIdCache ThreadId
cacheId
                                 , ThreadId -> HandleThreadId
HandleThreadIdGateway ThreadId
gateId
                                 ]
                             }

  IO Text -> IO () -> IO Text
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (DiscordHandle -> RunDiscordOpts -> IO Text
runDiscordLoop DiscordHandle
handle RunDiscordOpts
opts)
          (RunDiscordOpts -> IO ()
discordOnEnd RunDiscordOpts
opts IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DiscordHandler () -> DiscordHandle -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DiscordHandler ()
stopDiscord DiscordHandle
handle)

-- | Runs the main loop 
runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text
runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO Text
runDiscordLoop DiscordHandle
handle RunDiscordOpts
opts = do
  Either RestCallInternalException (User, FullApplication)
resp <- IO (Either RestCallInternalException (User, FullApplication))
startupRestCalls
  case Either RestCallInternalException (User, FullApplication)
resp of
    Left (RestCallInternalErrorCode Int
c ByteString
e1 ByteString
e2) -> Text -> IO Text
libError (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$
             Text
"HTTP Error Code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 ByteString
e1
                                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 ByteString
e2
    Left (RestCallInternalHttpException HttpException
e) -> Text -> IO Text
libError (Text
"HTTP Exception -  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (HttpException -> String
forall a. Show a => a -> String
show HttpException
e))
    Left (RestCallInternalNoParse String
e ByteString
_) -> Text -> IO Text
libError (Text
"Couldn't parse initial bot info - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e)
    Right (User
user, FullApplication
app) -> do User -> FullApplication -> CacheHandle -> IO ()
initializeCache User
user FullApplication
app (DiscordHandle -> CacheHandle
discordHandleCache DiscordHandle
handle)
                            Either SomeException ()
me <- IO (Either SomeException ()) -> IO (Either SomeException ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ()) -> IO (Either SomeException ()))
-> (DiscordHandle -> IO (Either SomeException ()))
-> DiscordHandle
-> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT DiscordHandle IO (Either SomeException ())
-> DiscordHandle -> IO (Either SomeException ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DiscordHandler ()
-> ReaderT DiscordHandle IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (DiscordHandler ()
 -> ReaderT DiscordHandle IO (Either SomeException ()))
-> DiscordHandler ()
-> ReaderT DiscordHandle IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ RunDiscordOpts -> DiscordHandler ()
discordOnStart RunDiscordOpts
opts) (DiscordHandle -> IO (Either SomeException ()))
-> DiscordHandle -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ DiscordHandle
handle
                            case Either SomeException ()
me of
                              Left (SomeException
e :: SomeException) -> Text -> IO Text
libError (Text
"discordOnStart handler stopped on an exception:\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
                              Right ()
_ -> IO Text
loop
 where
   startupRestCalls :: IO (Either RestCallInternalException (User, FullApplication))
   startupRestCalls :: IO (Either RestCallInternalException (User, FullApplication))
startupRestCalls = do Either RestCallInternalException User
eUser <- RestChanHandle
-> UserRequest User -> IO (Either RestCallInternalException User)
forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
RestChanHandle -> r a -> IO (Either RestCallInternalException a)
writeRestCall (DiscordHandle -> RestChanHandle
discordHandleRestChan DiscordHandle
handle) UserRequest User
R.GetCurrentUser
                         Either RestCallInternalException FullApplication
eApp <- RestChanHandle
-> FullApplicationRequest FullApplication
-> IO (Either RestCallInternalException FullApplication)
forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
RestChanHandle -> r a -> IO (Either RestCallInternalException a)
writeRestCall (DiscordHandle -> RestChanHandle
discordHandleRestChan DiscordHandle
handle) FullApplicationRequest FullApplication
R.GetCurrentApplication
                         Either RestCallInternalException (User, FullApplication)
-> IO (Either RestCallInternalException (User, FullApplication))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RestCallInternalException (User, FullApplication)
 -> IO (Either RestCallInternalException (User, FullApplication)))
-> Either RestCallInternalException (User, FullApplication)
-> IO (Either RestCallInternalException (User, FullApplication))
forall a b. (a -> b) -> a -> b
$ (,) (User -> FullApplication -> (User, FullApplication))
-> Either RestCallInternalException User
-> Either
     RestCallInternalException
     (FullApplication -> (User, FullApplication))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either RestCallInternalException User
eUser Either
  RestCallInternalException
  (FullApplication -> (User, FullApplication))
-> Either RestCallInternalException FullApplication
-> Either RestCallInternalException (User, FullApplication)
forall a b.
Either RestCallInternalException (a -> b)
-> Either RestCallInternalException a
-> Either RestCallInternalException b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either RestCallInternalException FullApplication
eApp

   libError :: T.Text -> IO T.Text
   libError :: Text -> IO Text
libError Text
msg = MVar Text -> Text -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar (DiscordHandle -> MVar Text
discordHandleLibraryError DiscordHandle
handle) Text
msg IO Bool -> IO Text -> IO Text
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
msg

   loop :: IO T.Text
   loop :: IO Text
loop = do Either Text (Either GatewayException EventInternalParse)
next <- IO Text
-> IO (Either GatewayException EventInternalParse)
-> IO (Either Text (Either GatewayException EventInternalParse))
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (MVar Text -> IO Text
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar (DiscordHandle -> MVar Text
discordHandleLibraryError DiscordHandle
handle))
                          (Chan (Either GatewayException EventInternalParse)
-> IO (Either GatewayException EventInternalParse)
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan (GatewayHandle -> Chan (Either GatewayException EventInternalParse)
gatewayHandleEvents (DiscordHandle -> GatewayHandle
discordHandleGateway DiscordHandle
handle)))
             case Either Text (Either GatewayException EventInternalParse)
next of
               Left Text
err -> Text -> IO Text
libError Text
err
               Right (Left GatewayException
err) -> Text -> IO Text
libError (String -> Text
T.pack (GatewayException -> String
forall a. Show a => a -> String
show GatewayException
err))
               Right (Right EventInternalParse
event) -> do
                 let userEvent :: Event
userEvent = EventInternalParse -> Event
userFacingEvent EventInternalParse
event
                 let action :: IO () -> IO ()
action = if RunDiscordOpts -> Bool
discordForkThreadForEvents RunDiscordOpts
opts then IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO
                                                                 else IO () -> IO ()
forall a. a -> a
id
                 IO () -> IO ()
action (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Either SomeException ()
me <- IO (Either SomeException ()) -> IO (Either SomeException ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ()) -> IO (Either SomeException ()))
-> (DiscordHandle -> IO (Either SomeException ()))
-> DiscordHandle
-> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT DiscordHandle IO (Either SomeException ())
-> DiscordHandle -> IO (Either SomeException ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DiscordHandler ()
-> ReaderT DiscordHandle IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (DiscordHandler ()
 -> ReaderT DiscordHandle IO (Either SomeException ()))
-> DiscordHandler ()
-> ReaderT DiscordHandle IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ RunDiscordOpts -> Event -> DiscordHandler ()
discordOnEvent RunDiscordOpts
opts Event
userEvent) (DiscordHandle -> IO (Either SomeException ()))
-> DiscordHandle -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ DiscordHandle
handle
                             case Either SomeException ()
me of
                               Left (SomeException
e :: SomeException) -> Chan Text -> Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan (DiscordHandle -> Chan Text
discordHandleLog DiscordHandle
handle)
                                         (Text
"eventhandler - crashed on [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Event -> String
forall a. Show a => a -> String
show Event
userEvent) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] "
                                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"          with error: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
                               Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                 IO Text
loop

-- | A Error code following a rest call
data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text
  deriving (Int -> RestCallErrorCode -> ShowS
[RestCallErrorCode] -> ShowS
RestCallErrorCode -> String
(Int -> RestCallErrorCode -> ShowS)
-> (RestCallErrorCode -> String)
-> ([RestCallErrorCode] -> ShowS)
-> Show RestCallErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RestCallErrorCode -> ShowS
showsPrec :: Int -> RestCallErrorCode -> ShowS
$cshow :: RestCallErrorCode -> String
show :: RestCallErrorCode -> String
$cshowList :: [RestCallErrorCode] -> ShowS
showList :: [RestCallErrorCode] -> ShowS
Show, ReadPrec [RestCallErrorCode]
ReadPrec RestCallErrorCode
Int -> ReadS RestCallErrorCode
ReadS [RestCallErrorCode]
(Int -> ReadS RestCallErrorCode)
-> ReadS [RestCallErrorCode]
-> ReadPrec RestCallErrorCode
-> ReadPrec [RestCallErrorCode]
-> Read RestCallErrorCode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RestCallErrorCode
readsPrec :: Int -> ReadS RestCallErrorCode
$creadList :: ReadS [RestCallErrorCode]
readList :: ReadS [RestCallErrorCode]
$creadPrec :: ReadPrec RestCallErrorCode
readPrec :: ReadPrec RestCallErrorCode
$creadListPrec :: ReadPrec [RestCallErrorCode]
readListPrec :: ReadPrec [RestCallErrorCode]
Read, RestCallErrorCode -> RestCallErrorCode -> Bool
(RestCallErrorCode -> RestCallErrorCode -> Bool)
-> (RestCallErrorCode -> RestCallErrorCode -> Bool)
-> Eq RestCallErrorCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RestCallErrorCode -> RestCallErrorCode -> Bool
== :: RestCallErrorCode -> RestCallErrorCode -> Bool
$c/= :: RestCallErrorCode -> RestCallErrorCode -> Bool
/= :: RestCallErrorCode -> RestCallErrorCode -> Bool
Eq, Eq RestCallErrorCode
Eq RestCallErrorCode =>
(RestCallErrorCode -> RestCallErrorCode -> Ordering)
-> (RestCallErrorCode -> RestCallErrorCode -> Bool)
-> (RestCallErrorCode -> RestCallErrorCode -> Bool)
-> (RestCallErrorCode -> RestCallErrorCode -> Bool)
-> (RestCallErrorCode -> RestCallErrorCode -> Bool)
-> (RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode)
-> (RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode)
-> Ord RestCallErrorCode
RestCallErrorCode -> RestCallErrorCode -> Bool
RestCallErrorCode -> RestCallErrorCode -> Ordering
RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RestCallErrorCode -> RestCallErrorCode -> Ordering
compare :: RestCallErrorCode -> RestCallErrorCode -> Ordering
$c< :: RestCallErrorCode -> RestCallErrorCode -> Bool
< :: RestCallErrorCode -> RestCallErrorCode -> Bool
$c<= :: RestCallErrorCode -> RestCallErrorCode -> Bool
<= :: RestCallErrorCode -> RestCallErrorCode -> Bool
$c> :: RestCallErrorCode -> RestCallErrorCode -> Bool
> :: RestCallErrorCode -> RestCallErrorCode -> Bool
$c>= :: RestCallErrorCode -> RestCallErrorCode -> Bool
>= :: RestCallErrorCode -> RestCallErrorCode -> Bool
$cmax :: RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode
max :: RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode
$cmin :: RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode
min :: RestCallErrorCode -> RestCallErrorCode -> RestCallErrorCode
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 :: forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
r a -> DiscordHandler (Either RestCallErrorCode a)
restCall r a
r = do DiscordHandle
h <- ReaderT DiscordHandle IO DiscordHandle
forall r (m :: * -> *). MonadReader r m => m r
ask
                Bool
empty <- MVar Text -> ReaderT DiscordHandle IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> m Bool
isEmptyMVar (DiscordHandle -> MVar Text
discordHandleLibraryError DiscordHandle
h)
                if Bool -> Bool
not Bool
empty
                then Either RestCallErrorCode a
-> DiscordHandler (Either RestCallErrorCode a)
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RestCallErrorCode -> Either RestCallErrorCode a
forall a b. a -> Either a b
Left (Int -> Text -> Text -> RestCallErrorCode
RestCallErrorCode Int
400 Text
"Library Stopped Working" Text
""))
                else do
                    Either RestCallInternalException a
resp <- IO (Either RestCallInternalException a)
-> ReaderT DiscordHandle IO (Either RestCallInternalException a)
forall a. IO a -> ReaderT DiscordHandle IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either RestCallInternalException a)
 -> ReaderT DiscordHandle IO (Either RestCallInternalException a))
-> IO (Either RestCallInternalException a)
-> ReaderT DiscordHandle IO (Either RestCallInternalException a)
forall a b. (a -> b) -> a -> b
$ RestChanHandle -> r a -> IO (Either RestCallInternalException a)
forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
RestChanHandle -> r a -> IO (Either RestCallInternalException a)
writeRestCall (DiscordHandle -> RestChanHandle
discordHandleRestChan DiscordHandle
h) r a
r
                    case Either RestCallInternalException a
resp of
                      Right a
x -> Either RestCallErrorCode a
-> DiscordHandler (Either RestCallErrorCode a)
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either RestCallErrorCode a
forall a b. b -> Either a b
Right a
x)
                      Left (RestCallInternalErrorCode Int
c ByteString
e1 ByteString
e2) -> do
                        Either RestCallErrorCode a
-> DiscordHandler (Either RestCallErrorCode a)
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RestCallErrorCode -> Either RestCallErrorCode a
forall a b. a -> Either a b
Left (Int -> Text -> Text -> RestCallErrorCode
RestCallErrorCode Int
c (ByteString -> Text
TE.decodeUtf8 ByteString
e1) (ByteString -> Text
TE.decodeUtf8 ByteString
e2)))
                      Left (RestCallInternalHttpException HttpException
_) ->
                        Int -> DiscordHandler ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)) DiscordHandler ()
-> DiscordHandler (Either RestCallErrorCode a)
-> DiscordHandler (Either RestCallErrorCode a)
forall a b.
ReaderT DiscordHandle IO a
-> ReaderT DiscordHandle IO b -> ReaderT DiscordHandle IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> r a -> DiscordHandler (Either RestCallErrorCode a)
forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
r a -> DiscordHandler (Either RestCallErrorCode a)
restCall r a
r
                      Left (RestCallInternalNoParse String
err ByteString
dat) -> do
                        let formaterr :: Text
formaterr = String -> Text
T.pack (String
"restcall - parse exception [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
                                              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" while handling" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
dat)
                        Chan Text -> Text -> DiscordHandler ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan (DiscordHandle -> Chan Text
discordHandleLog DiscordHandle
h) Text
formaterr
                        Either RestCallErrorCode a
-> DiscordHandler (Either RestCallErrorCode a)
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RestCallErrorCode -> Either RestCallErrorCode a
forall a b. a -> Either a b
Left (Int -> Text -> Text -> RestCallErrorCode
RestCallErrorCode Int
400 Text
"Library Parse Exception" Text
formaterr))

-- | Send a user GatewaySendable
sendCommand :: GatewaySendable -> DiscordHandler ()
sendCommand :: GatewaySendable -> DiscordHandler ()
sendCommand GatewaySendable
e = do
  DiscordHandle
h <- ReaderT DiscordHandle IO DiscordHandle
forall r (m :: * -> *). MonadReader r m => m r
ask
  Chan GatewaySendable -> GatewaySendable -> DiscordHandler ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan (GatewayHandle -> Chan GatewaySendable
gatewayHandleUserSendables (DiscordHandle -> GatewayHandle
discordHandleGateway DiscordHandle
h)) GatewaySendable
e
  case GatewaySendable
e of
    UpdateStatus UpdateStatusOpts
opts -> IO () -> DiscordHandler ()
forall a. IO a -> ReaderT DiscordHandle IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DiscordHandler ()) -> IO () -> DiscordHandler ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe UpdateStatusOpts) -> Maybe UpdateStatusOpts -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GatewayHandle -> IORef (Maybe UpdateStatusOpts)
gatewayHandleLastStatus (DiscordHandle -> GatewayHandle
discordHandleGateway DiscordHandle
h)) (UpdateStatusOpts -> Maybe UpdateStatusOpts
forall a. a -> Maybe a
Just UpdateStatusOpts
opts)
    GatewaySendable
_ -> () -> DiscordHandler ()
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Access the current state of the gateway cache
readCache :: DiscordHandler Cache
readCache :: DiscordHandler Cache
readCache = do
  DiscordHandle
h <- ReaderT DiscordHandle IO DiscordHandle
forall r (m :: * -> *). MonadReader r m => m r
ask
  MVar Cache -> DiscordHandler Cache
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar (CacheHandle -> MVar Cache
cacheHandleCache (DiscordHandle -> CacheHandle
discordHandleCache DiscordHandle
h))

-- | Stop all the background threads
stopDiscord :: DiscordHandler ()
stopDiscord :: DiscordHandler ()
stopDiscord = do DiscordHandle
h <- ReaderT DiscordHandle IO DiscordHandle
forall r (m :: * -> *). MonadReader r m => m r
ask
                 Bool
_ <- MVar Text -> Text -> ReaderT DiscordHandle IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar (DiscordHandle -> MVar Text
discordHandleLibraryError DiscordHandle
h) Text
"Library has closed"
                 Int -> DiscordHandler ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10)
                 (HandleThreadId -> DiscordHandler ())
-> [HandleThreadId] -> DiscordHandler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> DiscordHandler ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread (ThreadId -> DiscordHandler ())
-> (HandleThreadId -> ThreadId)
-> HandleThreadId
-> DiscordHandler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleThreadId -> ThreadId
toId) (DiscordHandle -> [HandleThreadId]
discordHandleThreads DiscordHandle
h)
  where toId :: HandleThreadId -> ThreadId
toId HandleThreadId
t = case HandleThreadId
t of
                   HandleThreadIdRest ThreadId
a -> ThreadId
a
                   HandleThreadIdGateway ThreadId
a -> ThreadId
a
                   HandleThreadIdCache ThreadId
a -> ThreadId
a
                   HandleThreadIdLogger ThreadId
a -> ThreadId
a

-- | Starts the internal logger
startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId
startLogger :: (Text -> IO ()) -> Chan Text -> IO ThreadId
startLogger Text -> IO ()
handle Chan Text
logC = IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  do Either IOException ()
me <- IO () -> IO (Either IOException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Chan Text -> IO Text
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan Text
logC IO Text -> (Text -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO ()
handle
     case Either IOException ()
me of
       Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       Left (IOException
_ :: IOException) ->
         -- writeChan logC "Log handler failed"
         () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: DiscordHandler NominalDiffTime
getGatewayLatency = do
  GatewayHandle
gw <- (DiscordHandle -> GatewayHandle)
-> ReaderT DiscordHandle IO GatewayHandle
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DiscordHandle -> GatewayHandle
discordHandleGateway
  (UTCTime
send1, UTCTime
send2) <- IORef (UTCTime, UTCTime)
-> ReaderT DiscordHandle IO (UTCTime, UTCTime)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (GatewayHandle -> IORef (UTCTime, UTCTime)
gatewayHandleHeartbeatTimes GatewayHandle
gw)

  UTCTime
ack <- IORef UTCTime -> ReaderT DiscordHandle IO UTCTime
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (GatewayHandle -> IORef UTCTime
gatewayHandleHeartbeatAckTimes GatewayHandle
gw)

  NominalDiffTime -> DiscordHandler NominalDiffTime
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> DiscordHandler NominalDiffTime)
-> (UTCTime -> NominalDiffTime)
-> UTCTime
-> DiscordHandler NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
ack (UTCTime -> DiscordHandler NominalDiffTime)
-> UTCTime -> DiscordHandler NominalDiffTime
forall a b. (a -> b) -> a -> b
$ 
    if UTCTime
ack UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
send1 -- if the ack is before the send just gone, use the previous send
      then UTCTime
send1
      else UTCTime
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 :: DiscordHandler NominalDiffTime
measureLatency = do
  UTCTime
startTime <- IO UTCTime -> ReaderT DiscordHandle IO UTCTime
forall a. IO a -> ReaderT DiscordHandle IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Either RestCallErrorCode User
_ <- UserRequest User -> DiscordHandler (Either RestCallErrorCode User)
forall (r :: * -> *) a.
(Request (r a), FromJSON a) =>
r a -> DiscordHandler (Either RestCallErrorCode a)
restCall UserRequest User
GetCurrentUser
  UTCTime
endTime <- IO UTCTime -> ReaderT DiscordHandle IO UTCTime
forall a. IO a -> ReaderT DiscordHandle IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  NominalDiffTime -> DiscordHandler NominalDiffTime
forall a. a -> ReaderT DiscordHandle IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> DiscordHandler NominalDiffTime)
-> NominalDiffTime -> DiscordHandler NominalDiffTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
endTime UTCTime
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.