{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
type DiscordHandler = ReaderT DiscordHandle IO
data RunDiscordOpts = RunDiscordOpts
{
RunDiscordOpts -> Text
discordToken :: T.Text
,
RunDiscordOpts -> DiscordHandler ()
discordOnStart :: DiscordHandler ()
,
RunDiscordOpts -> IO ()
discordOnEnd :: IO ()
,
RunDiscordOpts -> Event -> DiscordHandler ()
discordOnEvent :: Event -> DiscordHandler ()
,
RunDiscordOpts -> Text -> IO ()
discordOnLog :: T.Text -> IO ()
,
RunDiscordOpts -> Bool
discordForkThreadForEvents :: Bool
,
RunDiscordOpts -> GatewayIntent
discordGatewayIntent :: GatewayIntent
,
RunDiscordOpts -> Bool
discordEnableCache :: Bool
}
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
}
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)
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
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
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))
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 ()
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))
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
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) ->
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
then UTCTime
send1
else UTCTime
send2
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