diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,9 +1,12 @@ name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 0.5.0 -synopsis: Discord bot library for Haskell +version: 0.5.1 +synopsis: Write bots for Discord in Haskell description: Functions and data types to write discord bots. - See docs: + Official discord docs . + . + See the project readme for quickstart notes + homepage: https://github.com/aquarial/discord-haskell license: MIT license-file: LICENSE diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -61,6 +61,7 @@ logId <- forkIO (logger log True) (restHandler, restId) <- createHandler auth log (gate, gateId) <- startGatewayThread auth log + _ <- readCache (restHandler, gate, ()) -- delay pure (restHandler, gate, [ ThreadLogger logId , ThreadRest restId , ThreadGateway gateId diff --git a/src/Discord/Gateway/EventLoop.hs b/src/Discord/Gateway/EventLoop.hs --- a/src/Discord/Gateway/EventLoop.hs +++ b/src/Discord/Gateway/EventLoop.hs @@ -22,7 +22,7 @@ import Wuss (runSecureClient) import Network.WebSockets (ConnectionException(..), Connection, - sendClose, receiveData, sendTextData) + receiveData, sendTextData) import Discord.Types @@ -41,35 +41,20 @@ , gatewaySends :: Chan GatewaySendable } -sendableLoop :: Connection -> Sendables -> Chan [Char] -> IO () -sendableLoop conn sends log = forever $ do - -- send a ~120 events a min by delaying - threadDelay (round (10^6 * (62 / 120))) - let e :: Either GatewaySendable GatewaySendable -> GatewaySendable - e = either id id - payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) - writeChan log ("gateway - sending " <> QL.unpack (encode payload)) - sendTextData conn (encode payload) - -- | Securely run a connection IO action. Send a close on exception -connect :: Chan GatewaySendable -> Chan String - -> (Connection -> Chan GatewaySendable -> IO a) -> IO a -connect sends log app = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" $ \conn -> do - gateSends <- newChan - sendsId <- forkIO (sendableLoop conn (Sendables sends gateSends) log) - finally (app conn gateSends) - (sendClose conn ("" :: T.Text) >> killThread sendsId) +connect :: (Connection -> IO a) -> IO a +connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" connectionLoop :: Auth -> Chan Event -> Chan GatewaySendable -> Chan String -> IO () -connectionLoop auth events sends log = loop ConnStart +connectionLoop auth events userSend log = loop ConnStart where loop :: ConnLoopState -> IO () loop s = do - writeChan log ("conn loop: " <> show s) + writeChan log ("gateway - connection loop state " <> show s) case s of - (ConnClosed) -> writeChan log "Conn Closed" + (ConnClosed) -> pure () (ConnStart) -> do - loop <=< connect sends log $ \conn send -> do + loop <=< connect $ \conn -> do msg <- getPayload conn log case msg of Right (Hello interval) -> do @@ -78,32 +63,30 @@ case msg2 of Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do writeChan events r - startEventStream conn events auth seshID interval 0 send log - _ -> writeChan log ("received2: " <> show msg2) >> pure ConnClosed - _ -> writeChan log ("received1: " <> show msg) >> pure ConnClosed + startEventStream conn events auth seshID interval 0 userSend log + _ -> writeChan log ("gateway - connstart must be ready: " <> show msg2) >> pure ConnClosed + _ -> writeChan log ("gateway - connstart must be hello: " <> show msg) >> pure ConnClosed (ConnReconnect tok seshID seqID) -> do - next <- try $ connect sends log $ \conn send -> do + next <- try $ connect $ \conn -> do sendTextData conn (encode (Resume tok seshID seqID)) - writeChan log "Resuming???" eitherPayload <- getPayload conn log case eitherPayload of Right (Hello interval) -> - startEventStream conn events auth seshID interval seqID send log + startEventStream conn events auth seshID interval seqID userSend log Right (InvalidSession retry) -> do t <- getRandomR (1,5) - writeChan log ("Invalid sesh, sleep:" <> show t) threadDelay (t * 10^6) pure $ if retry then ConnReconnect tok seshID seqID else ConnStart Right payload -> do - writeChan log ("Why did they send a: " <> show payload) + writeChan log ("gateway - connreconnect invalid response: " <> show payload) pure ConnClosed Left e -> - writeChan log ("message - error " <> show e) >> pure ConnClosed + writeChan log ("gateway - connreconnect error " <> show e) >> pure ConnClosed case next :: Either SomeException ConnLoopState of - Left e -> do writeChan log ("exception - connecting: " <> show e) + Left e -> do writeChan log ("gateway - connreconnect after eventStream error: " <> show e) t <- getRandomR (3,10) threadDelay (t * 10^6) loop (ConnReconnect tok seshID seqID) @@ -112,25 +95,25 @@ getPayloadTimeout :: Connection -> Int -> Chan String -> IO (Either ConnectionException GatewayReceivable) getPayloadTimeout conn interval log = do - res <- race (threadDelay (interval * 1000 * 3 `div` 2)) + res <- race (threadDelay ((interval * 1000 * 3) `div` 2)) (getPayload conn log) case res of - Left () -> pure (Right (InvalidSession True)) + Left () -> pure (Right Reconnect) Right other -> pure other getPayload :: Connection -> Chan String -> IO (Either ConnectionException GatewayReceivable) getPayload conn log = try $ do msg' <- receiveData conn - writeChan log ("message - received " <> QL.unpack msg') + writeChan log ("gateway - received " <> QL.unpack msg') case eitherDecode msg' of Right msg -> return msg - Left err -> do writeChan log ("parse error Error - " <> err) - writeChan log ("parse error Message - " <> show msg') + Left err -> do writeChan log ("gateway - received parse Error - " <> err) return (ParseError err) heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> Chan String -> IO () heartbeat send interval seqKey log = do - writeChan log "starting the heartbeat" + threadDelay (1 * 10^6) + writeChan log "gateway - starting heartbeat" forever $ do num <- readIORef seqKey writeChan send (Heartbeat num) @@ -141,17 +124,21 @@ startEventStream :: Connection -> Chan Event -> Auth -> String -> Int -> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState -startEventStream conn events (Auth auth) seshID interval seqN send log = do +startEventStream conn events (Auth auth) seshID interval seqN userSend log = do seqKey <- newIORef seqN - heart <- forkIO $ heartbeat send interval seqKey log - let err :: SomeException -> IO ConnLoopState - err e = do writeChan log ("error - " <> show e) + err e = do writeChan log ("gateway - eventStream error: " <> show e) ConnReconnect auth seshID <$> readIORef seqKey - handle err $ finally (eventStream (ConnData conn seshID auth events) seqKey interval send log) - (killThread heart) + handle err $ do + gateSends <- newChan + sendsId <- forkIO $ sendableLoop conn (Sendables userSend gateSends) log + heart <- forkIO $ heartbeat gateSends interval seqKey log -eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable -> Chan String -> IO ConnLoopState + finally (eventStream (ConnData conn seshID auth events) seqKey interval gateSends log) + (killThread heart >> killThread sendsId) + +eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable + -> Chan String -> IO ConnLoopState eventStream (ConnData conn seshID auth eventChan) seqKey interval send log = loop where loop :: IO ConnLoopState @@ -165,7 +152,8 @@ 4006 -> pure ConnStart 4007 -> ConnReconnect auth seshID <$> readIORef seqKey 4014 -> ConnReconnect auth seshID <$> readIORef seqKey - e -> do writeChan log ("Closing connection because #" <> show e <> " " <> show str) + e -> do writeChan log ("gateway - Closing connection because #" + <> show e <> " " <> show str) pure ConnClosed Left _ -> ConnReconnect auth seshID <$> readIORef seqKey Right (Dispatch event sq) -> do setSequence seqKey sq @@ -180,4 +168,16 @@ then ConnReconnect auth seshID <$> readIORef seqKey else pure ConnStart Right (HeartbeatAck) -> loop - Right p -> writeChan log ("error - Invalid gateway payload: " <> show p) >> pure ConnClosed + Right p -> do writeChan log ("gateway - Invalid gateway payload: " <> show p) + pure ConnClosed + + +sendableLoop :: Connection -> Sendables -> Chan [Char] -> IO () +sendableLoop conn sends log = forever $ do + -- send a ~120 events a min by delaying + threadDelay (round (10^6 * (62 / 120))) + let e :: Either GatewaySendable GatewaySendable -> GatewaySendable + e = either id id + payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) + writeChan log ("gateway - sending " <> QL.unpack (encode payload)) + sendTextData conn (encode payload) diff --git a/src/Discord/Rest/HTTP.hs b/src/Discord/Rest/HTTP.hs --- a/src/Discord/Rest/HTTP.hs +++ b/src/Discord/Rest/HTTP.hs @@ -45,7 +45,7 @@ loop ratelocker Available -> do let action = compileRequest auth request (resp, retry) <- restIOtoIO (tryRequest action log) - writeChan log ("rest - got response " <> unpackResp resp) + writeChan log ("rest - response " <> unpackResp resp) case resp of Right "" -> putMVar thread (Right "[]") -- empty should be () Right bs -> putMVar thread (Right bs) @@ -53,7 +53,7 @@ Left r -> putMVar thread (Left r) case retry of GlobalWait i -> do - writeChan log ("rest - GLOBAL WAIT " <> show ((i - curtime) * 1000)) + writeChan log ("rest - GLOBAL WAIT LIMIT: " <> show ((i - curtime) * 1000)) threadDelay $ round ((i - curtime + 0.1) * 1000) loop ratelocker PathWait i -> loop $ M.insert route i ratelocker diff --git a/src/Discord/Rest/Prelude.hs b/src/Discord/Rest/Prelude.hs --- a/src/Discord/Rest/Prelude.hs +++ b/src/Discord/Rest/Prelude.hs @@ -24,7 +24,7 @@ where -- | https://discordapp.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.5.0)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.5.1)" -- Append to an URL infixl 5 //