discord-haskell 0.5.0 → 0.5.1
raw patch · 5 files changed
+57/−53 lines, 5 files
Files
- discord-haskell.cabal +6/−3
- src/Discord.hs +1/−0
- src/Discord/Gateway/EventLoop.hs +47/−47
- src/Discord/Rest/HTTP.hs +2/−2
- src/Discord/Rest/Prelude.hs +1/−1
discord-haskell.cabal view
@@ -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: <https://discordapp.com/developers/docs/reference>+ Official discord docs <https://discordapp.com/developers/docs/reference>.+ .+ See the project readme for quickstart notes+ <https://github.com/aquarial/discord-haskell#discord-haskell> homepage: https://github.com/aquarial/discord-haskell license: MIT license-file: LICENSE
src/Discord.hs view
@@ -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
src/Discord/Gateway/EventLoop.hs view
@@ -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)
src/Discord/Rest/HTTP.hs view
@@ -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
src/Discord/Rest/Prelude.hs view
@@ -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 //