discord-haskell 0.5.1 → 0.6.0
raw patch · 15 files changed
+366/−164 lines, 15 filesdep +JuicyPixelsdep +base64-bytestringdep ~base
Dependencies added: JuicyPixels, base64-bytestring
Dependency ranges changed: base
Files
- discord-haskell.cabal +4/−2
- src/Discord.hs +13/−7
- src/Discord/Gateway.hs +8/−10
- src/Discord/Gateway/Cache.hs +23/−12
- src/Discord/Gateway/EventLoop.hs +83/−48
- src/Discord/Rest.hs +7/−6
- src/Discord/Rest/Channel.hs +76/−24
- src/Discord/Rest/Emoji.hs +47/−11
- src/Discord/Rest/Guild.hs +27/−6
- src/Discord/Rest/HTTP.hs +44/−31
- src/Discord/Rest/Prelude.hs +1/−1
- src/Discord/Rest/User.hs +23/−5
- src/Discord/Types/Channel.hs +2/−0
- src/Discord/Types/Gateway.hs +5/−0
- src/Discord/Types/Prelude.hs +3/−1
discord-haskell.cabal view
@@ -1,6 +1,6 @@ name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs-version: 0.5.1+version: 0.6.0 synopsis: Write bots for Discord in Haskell description: Functions and data types to write discord bots. Official discord docs <https://discordapp.com/developers/docs/reference>.@@ -42,16 +42,18 @@ , Discord.Types.Gateway , Discord.Types.Guild build-depends:- base >=4.10.1.0 && <4.11+ base >=4 && <5 , aeson >=1.2.4.0 && <1.3 , async >=2.1.1.1 && <2.2 , bytestring >=0.10.8.2 && <0.11+ , base64-bytestring >= 1.0.0.1 && <1.1 , containers >=0.5.10.2 && <0.6 , data-default >=0.7.1.1 && <0.8 , http-client >=0.5.12.1 && <0.6 , iso8601-time >=0.1.4 && <0.2 , MonadRandom >=0.5.1 && <0.6 , req >=1.0.0 && <1.1+ , JuicyPixels >= 3.2.9.0 && < 3.3 , safe-exceptions >=0.1.7.0 && <0.2 , text >=1.2.3.0 && <1.3 , time >=1.8.0.2 && <1.9
src/Discord.hs view
@@ -9,7 +9,10 @@ , Cache(..) , Gateway(..) , RestChan(..)+ , RestCallException(..)+ , GatewayException(..) , Request(..)+ , ThreadIdType(..) , restCall , nextEvent , sendCommand@@ -48,7 +51,8 @@ loginRest :: Auth -> IO (RestChan, NotLoggedIntoGateway, [ThreadIdType]) loginRest auth = do log <- newChan- logId <- forkIO (logger log True)+ -- writeFile "the-log-of-discord-haskell.txt" ""+ logId <- forkIO (logger log False) (restHandler, restId) <- createHandler auth log pure (restHandler, NotLoggedIntoGateway, [ ThreadLogger logId , ThreadRest restId@@ -58,21 +62,23 @@ loginRestGateway :: Auth -> IO (RestChan, Gateway, [ThreadIdType]) loginRestGateway auth = do log <- newChan- logId <- forkIO (logger log True)+ -- writeFile "the-log-of-discord-haskell.txt" ""+ logId <- forkIO (logger log False) (restHandler, restId) <- createHandler auth log (gate, gateId) <- startGatewayThread auth log- _ <- readCache (restHandler, gate, ()) -- delay pure (restHandler, gate, [ ThreadLogger logId , ThreadRest restId , ThreadGateway gateId ]) -- | Execute one http request and get a response-restCall :: (FromJSON a, Request (r a)) => (RestChan, y, z) -> r a -> IO (Either String a)+restCall :: (FromJSON a, Request (r a)) =>+ (RestChan, y, z) -> r a -> IO (Either RestCallException a) restCall (r,_,_) = writeRestCall r --- | Block until the gateway produces another event-nextEvent :: (x, Gateway, z) -> IO Event+-- | Block until the gateway produces another event. Once an exception is returned,+-- only return that exception+nextEvent :: (x, Gateway, z) -> IO (Either GatewayException Event) nextEvent (_,g,_) = readChan (_events g) -- | Send a GatewaySendable, but not Heartbeat, Identify, or Resume@@ -84,7 +90,7 @@ _ -> writeChan (_gatewayCommands g) e -- | Access the current state of the gateway cache-readCache :: (RestChan, Gateway, z) -> IO Cache+readCache :: (RestChan, Gateway, z) -> IO (Either GatewayException Cache) readCache (_,g,_) = readMVar (_cache g) -- | Stop all the background threads
src/Discord/Gateway.hs view
@@ -4,24 +4,24 @@ -- through a real-time Chan module Discord.Gateway ( Gateway(..)+ , GatewayException(..) , startGatewayThread , module Discord.Types ) where import Prelude hiding (log)-import Control.Exception.Safe (finally) import Control.Concurrent.Chan (newChan, dupChan, Chan)-import Control.Concurrent (forkIO, killThread, ThreadId, MVar)+import Control.Concurrent (forkIO, ThreadId, MVar) import Discord.Types (Auth, Event, GatewaySendable)-import Discord.Gateway.EventLoop (connectionLoop)+import Discord.Gateway.EventLoop (connectionLoop, GatewayException(..)) import Discord.Gateway.Cache -- | Concurrency primitives that make up the gateway. Build a higher -- level interface over these data Gateway = Gateway- { _events :: Chan Event- , _cache :: MVar Cache+ { _events :: Chan (Either GatewayException Event)+ , _cache :: MVar (Either GatewayException Cache) , _gatewayCommands :: Chan GatewaySendable } @@ -32,11 +32,9 @@ eventsWrite <- newChan eventsCache <- dupChan eventsWrite sends <- newChan- writeFile "the-log-of-discord-haskell.txt" ""- cache <- emptyCache- cacheID <- forkIO $ addEvent cache eventsCache log- tid <- forkIO $ finally (connectionLoop auth eventsWrite sends log)- (killThread cacheID)+ cache <- emptyCache :: IO (MVar (Either GatewayException Cache))+ tid <- forkIO $ connectionLoop auth eventsWrite sends log+ cacheAddEventLoopFork cache eventsCache log pure (Gateway eventsWrite cache sends, tid)
src/Discord/Gateway/Cache.hs view
@@ -6,11 +6,13 @@ import Prelude hiding (log) import Data.Monoid ((<>))+import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.Chan import qualified Data.Map.Strict as M import Discord.Types+import Discord.Gateway.EventLoop data Cache = Cache { _currentUser :: User@@ -19,27 +21,36 @@ , _channels :: M.Map Snowflake Channel } deriving (Show) -emptyCache :: IO (MVar Cache)+emptyCache :: IO (MVar (Either GatewayException Cache)) emptyCache = newEmptyMVar -addEvent :: MVar Cache -> Chan Event -> Chan String -> IO ()-addEvent cache eventChan log = do+cacheAddEventLoopFork :: MVar (Either GatewayException Cache) -> Chan (Either GatewayException Event) -> Chan String -> IO ()+cacheAddEventLoopFork cache eventChan log = do ready <- readChan eventChan case ready of- (Ready _ user dmChannels _unavailableGuilds _) -> do+ Right (Ready _ user dmChannels _unavailableGuilds _) -> do let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels)- putMVar cache (Cache user dmChans M.empty M.empty)- loop- _ -> do- writeChan log ("Cache error - expected Ready, but got " <> show ready)- addEvent cache eventChan log+ putMVar cache (Right (Cache user dmChans M.empty M.empty))+ _ <- forkIO loop+ pure ()+ Right r -> do+ writeChan log ("cache - expected Ready event, but got " <> show r)+ cacheAddEventLoopFork cache eventChan log+ Left e -> do+ writeChan log "cache - gateway exception, stopping cache"+ putMVar cache (Left e) where loop :: IO () loop = do- event <- readChan eventChan+ eventOrExcept <- readChan eventChan minfo <- takeMVar cache- putMVar cache (adjustCache minfo event)- loop+ case (eventOrExcept, minfo) of+ (_, Left _) -> pure () -- never happen bc we stop loop once cache has an exception+ (Left exception, _) -> do putMVar cache (Left exception)+ -- stop cache loop+ (Right event, Right info) -> do+ putMVar cache (Right (adjustCache info event))+ loop adjustCache :: Cache -> Event -> Cache adjustCache minfo event = case event of
src/Discord/Gateway/EventLoop.hs view
@@ -8,7 +8,7 @@ import Prelude hiding (log) -import Control.Monad (forever, (<=<))+import Control.Monad (forever) import Control.Monad.Random (getRandomR) import Control.Concurrent.Async (race) import Control.Concurrent.Chan@@ -23,38 +23,37 @@ import Wuss (runSecureClient) import Network.WebSockets (ConnectionException(..), Connection, receiveData, sendTextData)+import GHC.IO.Exception (IOError) import Discord.Types +data GatewayException = GatewayExceptionCouldNotConnect T.Text+ | GatewayExceptionEventParseError String T.Text+ | GatewayExceptionUnexpected GatewayReceivable T.Text+ | GatewayExceptionConnection ConnectionException T.Text+ deriving (Show)+ data ConnLoopState = ConnStart | ConnClosed- | ConnReconnect T.Text String Integer+ | ConnReconnect Auth String Integer deriving Show -data ConnectionData = ConnData { connection :: Connection- , connSessionID :: String- , connAuth :: T.Text- , connChan :: Chan Event- }--data Sendables = Sendables { userSends :: Chan GatewaySendable- , gatewaySends :: Chan GatewaySendable- }- -- | Securely run a connection IO action. Send a close on exception 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 userSend log = loop ConnStart+connectionLoop :: Auth -> Chan (Either GatewayException Event) -> Chan GatewaySendable+ -> Chan String -> IO ()+connectionLoop auth events userSend log = loop ConnStart 0 where- loop :: ConnLoopState -> IO ()- loop s = do+ loop :: ConnLoopState -> Int -> IO ()+ loop s retries = do writeChan log ("gateway - connection loop state " <> show s) case s of (ConnClosed) -> pure () (ConnStart) -> do- loop <=< connect $ \conn -> do+ -- only try-catch an IO Error+ next <- try $ connect $ \conn -> do msg <- getPayload conn log case msg of Right (Hello interval) -> do@@ -62,35 +61,57 @@ msg2 <- getPayload conn log case msg2 of Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do- writeChan events r- 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+ writeChan events (Right r)+ startEventStream (ConnData conn seshID auth events) interval 0 userSend log+ Right m -> do writeChan events (Left (GatewayExceptionUnexpected m+ "Response to Identify must be Ready"))+ pure ConnClosed+ Left ce -> do writeChan events (Left (GatewayExceptionConnection ce+ "Response to Identify"))+ pure ConnClosed+ Right m -> do writeChan log ("gateway - first message must be hello: " <> show msg)+ writeChan events (Left (GatewayExceptionUnexpected m+ "Response to connecting must be hello"))+ pure ConnClosed+ Left ce -> do writeChan events (Left (GatewayExceptionConnection ce+ "Response to connecting"))+ pure ConnClosed+ case next :: Either IOError ConnLoopState of+ Left _ -> do writeChan events (Left (GatewayExceptionCouldNotConnect+ "IOError in gateway Connection"))+ loop ConnClosed 0+ Right n -> loop n 0 - (ConnReconnect tok seshID seqID) -> do+ (ConnReconnect (Auth tok) seshID seqID) -> do next <- try $ connect $ \conn -> do sendTextData conn (encode (Resume tok seshID seqID)) eitherPayload <- getPayload conn log case eitherPayload of Right (Hello interval) ->- startEventStream conn events auth seshID interval seqID userSend log+ startEventStream (ConnData conn seshID auth events) interval seqID userSend log Right (InvalidSession retry) -> do t <- getRandomR (1,5) threadDelay (t * 10^6) pure $ if retry- then ConnReconnect tok seshID seqID+ then ConnReconnect (Auth tok) seshID seqID else ConnStart Right payload -> do- writeChan log ("gateway - connreconnect invalid response: " <> show payload)+ writeChan events (Left (GatewayExceptionUnexpected payload+ "Response to Resume must be Hello/Invalid Session")) pure ConnClosed- Left e ->- writeChan log ("gateway - connreconnect error " <> show e) >> pure ConnClosed+ Left e -> do+ writeChan events (Left (GatewayExceptionConnection e+ "Could not ConnReconnect"))+ pure ConnClosed case next :: Either SomeException ConnLoopState of- 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)- Right n -> loop n+ Left _ -> if (retries < 5)+ then do t <- getRandomR (3,10)+ threadDelay (t * 10^6)+ loop (ConnReconnect (Auth tok) seshID seqID) (retries + 1)+ else do writeChan events (Left (GatewayExceptionCouldNotConnect+ "Too many retries failed"))+ loop ConnClosed 0+ Right n -> loop n 0 getPayloadTimeout :: Connection -> Int -> Chan String -> IO (Either ConnectionException GatewayReceivable)@@ -122,21 +143,28 @@ setSequence :: IORef Integer -> Integer -> IO () setSequence key i = writeIORef key i -startEventStream :: Connection -> Chan Event -> Auth -> String -> Int- -> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState-startEventStream conn events (Auth auth) seshID interval seqN userSend log = do+-- | What we need to start an event stream+data ConnectionData = ConnData { connection :: Connection+ , connSessionID :: String+ , connAuth :: Auth+ , connChan :: Chan (Either GatewayException Event)+ }++startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState+startEventStream conndata interval seqN userSend log = do seqKey <- newIORef seqN let err :: SomeException -> IO ConnLoopState err e = do writeChan log ("gateway - eventStream error: " <> show e)- ConnReconnect auth seshID <$> readIORef seqKey+ ConnReconnect (connAuth conndata) (connSessionID conndata) <$> readIORef seqKey handle err $ do gateSends <- newChan- sendsId <- forkIO $ sendableLoop conn (Sendables userSend gateSends) log+ sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends) heart <- forkIO $ heartbeat gateSends interval seqKey log - finally (eventStream (ConnData conn seshID auth events) seqKey interval gateSends log)+ finally (eventStream conndata 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@@ -152,32 +180,39 @@ 4006 -> pure ConnStart 4007 -> ConnReconnect auth seshID <$> readIORef seqKey 4014 -> ConnReconnect auth seshID <$> readIORef seqKey- e -> do writeChan log ("gateway - Closing connection because #"- <> show e <> " " <> show str)+ _ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str)+ "Normal event loop close request")) pure ConnClosed Left _ -> ConnReconnect auth seshID <$> readIORef seqKey Right (Dispatch event sq) -> do setSequence seqKey sq- writeChan eventChan event+ writeChan eventChan (Right event) loop Right (HeartbeatRequest sq) -> do setSequence seqKey sq writeChan send (Heartbeat sq) loop- Right (Reconnect) -> do writeChan log "Should reconnect"- ConnReconnect auth seshID <$> readIORef seqKey+ Right (Reconnect) -> ConnReconnect auth seshID <$> readIORef seqKey Right (InvalidSession retry) -> if retry then ConnReconnect auth seshID <$> readIORef seqKey else pure ConnStart Right (HeartbeatAck) -> loop- Right p -> do writeChan log ("gateway - Invalid gateway payload: " <> show p)- pure ConnClosed+ Right (Hello e) -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello e)+ "Normal event loop"))+ pure ConnClosed+ Right (ParseError e) -> do writeChan eventChan (Left (GatewayExceptionEventParseError e+ "Normal event loop"))+ pure ConnClosed +data Sendables = Sendables { -- | Things the user wants to send. Doesn't reset on reconnect+ userSends :: Chan GatewaySendable -- ^ Things the user wants to send+ -- | Things the library needs to send. Resets to empty on reconnect+ , gatewaySends :: Chan GatewaySendable+ } -sendableLoop :: Connection -> Sendables -> Chan [Char] -> IO ()-sendableLoop conn sends log = forever $ do+sendableLoop :: Connection -> Sendables -> IO ()+sendableLoop conn sends = 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.hs view
@@ -10,11 +10,12 @@ , Request(..) , writeRestCall , createHandler+ , RestCallException(..) ) where import Prelude hiding (log)+import Data.Either (fromRight) import Data.Aeson (FromJSON, eitherDecode)-import Data.Monoid ((<>)) import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Concurrent (forkIO, ThreadId)@@ -23,7 +24,8 @@ import Discord.Types import Discord.Rest.HTTP -newtype RestChan = RestChan (Chan (String, JsonRequest, MVar (Either String QL.ByteString)))+newtype RestChan = RestChan (Chan (String, JsonRequest,+ MVar (Either RestCallException QL.ByteString))) -- | Starts the http request thread. Please only call this once createHandler :: Auth -> Chan String -> IO (RestChan, ThreadId)@@ -33,15 +35,14 @@ pure (RestChan c, tid) -- | Execute a request blocking until a response is received-writeRestCall :: (Request (r a), FromJSON a) => RestChan -> r a -> IO (Either String a)+writeRestCall :: (Request (r a), FromJSON a) => RestChan -> r a -> IO (Either RestCallException a) writeRestCall (RestChan c) req = do m <- newEmptyMVar writeChan c (majorRoute req, jsonRequest req, m) r <- readMVar m pure $ case eitherDecode <$> r of Right (Right o) -> Right o- Right (Left er) -> Left ("parse error - " <> er)- Left err -> Left err-+ Right (Left er) -> Left (RestCallNoParse er (fromRight "" r))+ Left e -> Left e
src/Discord/Rest/Channel.hs view
@@ -9,7 +9,10 @@ ( ChannelRequest(..) , ReactionTiming(..) , MessageTiming(..)- , ModifyChannelOptions(..)+ , ModifyChannelOpts(..)+ , ChannelPermissionsOpts(..)+ , GroupDMAddRecipientOpts(..)+ , ChannelPermissionsOptsType(..) ) where @@ -34,7 +37,7 @@ -- | Gets a channel by its id. GetChannel :: Snowflake -> ChannelRequest Channel -- | Edits channels options.- ModifyChannel :: Snowflake -> ModifyChannelOptions -> ChannelRequest Channel+ ModifyChannel :: Snowflake -> ModifyChannelOpts -> ChannelRequest Channel -- | Deletes a channel if its id doesn't equal to the id of guild. DeleteChannel :: Snowflake -> ChannelRequest Channel -- | Gets a messages from a channel with limit of 100 per request.@@ -66,12 +69,12 @@ DeleteMessage :: (Snowflake, Snowflake) -> ChannelRequest () -- | Deletes a group of messages. BulkDeleteMessage :: (Snowflake, [Snowflake]) -> ChannelRequest ()- -- todo | Edits a permission overrides for a channel.- -- todo EditChannelPermissions :: ToJSON o => Snowflake -> Snowflake -> o -> ChannelRequest ()+ -- | Edits a permission overrides for a channel.+ EditChannelPermissions :: Snowflake -> Snowflake -> ChannelPermissionsOpts -> ChannelRequest () -- | Gets all instant invites to a channel. GetChannelInvites :: Snowflake -> ChannelRequest Object- -- todo | Creates an instant invite to a channel.- -- todo CreateChannelInvite :: ToJSON o => Snowflake -> o -> ChannelRequest Object+ -- | Creates an instant invite to a channel.+ CreateChannelInvite :: Snowflake -> ChannelInviteOpts -> ChannelRequest Invite -- | Deletes a permission override from a channel. DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest () -- | Sends a typing indicator a channel which lasts 10 seconds.@@ -82,10 +85,10 @@ AddPinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest () -- | Unpins a message. DeletePinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest ()- -- todo | Adds a recipient to a Group DM using their access token- -- todo GroupDMAddRecipient :: Snowflake -> Snowflake -> ChannelRequest ()- -- todo | Removes a recipient from a Group DM- -- todo GroupDMRemoveRecipient :: Snowflake -> Snowflake -> ChannelRequest ()+ -- | Adds a recipient to a Group DM using their access token+ GroupDMAddRecipient :: Snowflake -> GroupDMAddRecipientOpts -> ChannelRequest ()+ -- | Removes a recipient from a Group DM+ GroupDMRemoveRecipient :: Snowflake -> Snowflake -> ChannelRequest () -- | Data constructor for GetReaction requests@@ -108,7 +111,21 @@ (BeforeMessage snow) -> "before" R.=: show snow (AfterMessage snow) -> "after" R.=: show snow -data ModifyChannelOptions = ModifyChannelOptions+data ChannelInviteOpts = ChannelInviteOpts+ { channelInviteOptsMaxAgeSeconds :: Maybe Integer+ , channelInviteOptsMaxUsages :: Maybe Integer+ , channelInviteOptsIsTemporary :: Maybe Bool+ , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool+ }++instance ToJSON ChannelInviteOpts where+ toJSON ChannelInviteOpts{..} = object [(name, val) | (name, Just val) <-+ [("max_age", toJSON <$> channelInviteOptsMaxAgeSeconds),+ ("max_uses", toJSON <$> channelInviteOptsMaxUsages),+ ("temporary", toJSON <$> channelInviteOptsIsTemporary),+ ("unique", toJSON <$> channelInviteOptsDontReuseSimilarInvite) ] ]++data ModifyChannelOpts = ModifyChannelOpts { modifyChannelName :: Maybe String , modifyChannelPosition :: Maybe Integer , modifyChannelTopic :: Maybe String@@ -119,8 +136,8 @@ , modifyChannelParentId :: Maybe Snowflake } -instance ToJSON ModifyChannelOptions where- toJSON ModifyChannelOptions{..} = object [(name, val) | (name, Just val) <-+instance ToJSON ModifyChannelOpts where+ toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- [("name", toJSON <$> modifyChannelName), ("position", toJSON <$> modifyChannelPosition), ("topic", toJSON <$> modifyChannelTopic),@@ -130,6 +147,30 @@ ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), ("parent_id", toJSON <$> modifyChannelParentId) ] ] +data ChannelPermissionsOpts = ChannelPermissionsOpts+ { channelPermissionsOptsAllow :: Integer+ , channelPermissionsOptsDeny :: Integer+ , channelPermissionsOptsType :: ChannelPermissionsOptsType}++data ChannelPermissionsOptsType = ChannelPermissionsOptsUser+ | ChannelPermissionsOptsRole++instance ToJSON ChannelPermissionsOptsType where+ toJSON t = case t of ChannelPermissionsOptsUser -> String "member"+ ChannelPermissionsOptsRole -> String "role"++instance ToJSON ChannelPermissionsOpts where+ toJSON (ChannelPermissionsOpts a d t) = object [ ("allow", toJSON a )+ , ("deny", toJSON d)+ , ("type", toJSON t)]++-- | https://discordapp.com/developers/docs/resources/channel#group-dm-add-recipient+data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts+ { groupDMAddRecipientUserToAdd :: Snowflake+ , groupDMAddRecipientUserToAddNickName :: T.Text+ , groupDMAddRecipientGDMJoinAccessToken :: T.Text+ }+ channelMajorRoute :: ChannelRequest a -> String channelMajorRoute c = case c of (GetChannel chan) -> "get_chan " <> show chan@@ -139,22 +180,24 @@ (GetChannelMessage (chan, _)) -> "get_msg " <> show chan (CreateMessage chan _ _) -> "msg " <> show chan (UploadFile chan _ _) -> "msg " <> show chan- (CreateReaction (chan, _) _) -> "react" <> show chan- (DeleteOwnReaction (chan, _) _) -> "react" <> show chan- (DeleteUserReaction (chan, _) _ _) -> "react" <> show chan- (GetReactions (chan, _) _ _) -> "react" <> show chan- (DeleteAllReactions (chan, _)) -> "react" <> show chan+ (CreateReaction (chan, _) _) -> "react " <> show chan+ (DeleteOwnReaction (chan, _) _) -> "react " <> show chan+ (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan+ (GetReactions (chan, _) _ _) -> "react " <> show chan+ (DeleteAllReactions (chan, _)) -> "react " <> show chan (EditMessage (chan, _) _ _) -> "get_msg " <> show chan (DeleteMessage (chan, _)) -> "get_msg " <> show chan (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan- -- todo (EditChannelPermissions chan _ _) -> "perms " <> show chan+ (EditChannelPermissions chan _ _) -> "perms " <> show chan (GetChannelInvites chan) -> "invites " <> show chan- -- todo (CreateChannelInvite chan _) -> "invites " <> show chan+ (CreateChannelInvite chan _) -> "invites " <> show chan (DeleteChannelPermission chan _) -> "perms " <> show chan (TriggerTypingIndicator chan) -> "tti " <> show chan (GetPinnedMessages chan) -> "pins " <> show chan (AddPinnedMessage (chan, _)) -> "pin " <> show chan (DeletePinnedMessage (chan, _)) -> "pin " <> show chan+ (GroupDMAddRecipient chan _) -> "groupdm " <> show chan+ (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan maybeEmbed :: Maybe Embed -> [(T.Text, Value)]@@ -231,14 +274,14 @@ let body = pure . R.ReqBodyJson $ object ["messages" .= msgs] in Post (channels // chan /: "messages" /: "bulk-delete") body mempty - -- todo (EditChannelPermissions chan perm patch) ->- -- Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty+ (EditChannelPermissions chan perm patch) ->+ Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty (GetChannelInvites chan) -> Get (channels // chan /: "invites") mempty - -- todo (CreateChannelInvite chan patch) ->- -- Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty+ (CreateChannelInvite chan patch) ->+ Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty (DeleteChannelPermission chan perm) -> Delete (channels // chan /: "permissions" // perm) mempty@@ -254,4 +297,13 @@ (DeletePinnedMessage (chan, msg)) -> Delete (channels // chan /: "pins" // msg) mempty++ (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) ->+ Put (channels // chan // chan /: "recipients" // uid)+ (R.ReqBodyJson (object [ ("access_token", toJSON tok)+ , ("nick", toJSON nick)]))+ mempty++ (GroupDMRemoveRecipient chan userid) ->+ Delete (channels // chan // chan /: "recipients" // userid) mempty
src/Discord/Rest/Emoji.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}@@ -8,20 +9,25 @@ module Discord.Rest.Emoji ( EmojiRequest(..) , ModifyGuildEmojiOpts(..)+ , EmojiImage+ , parseEmojiImage ) where import Data.Aeson import Data.Monoid (mempty, (<>))+import Codec.Picture import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R import qualified Data.Text as T+import qualified Data.ByteString.Char8 as Q+import qualified Data.ByteString.Base64 as B64 import Discord.Rest.Prelude import Discord.Types instance Request (EmojiRequest a) where- majorRoute = userMajorRoute- jsonRequest = userJsonRequest+ majorRoute = emojiMajorRoute+ jsonRequest = emojiJsonRequest -- | Data constructor for requests. See <https://discordapp.com/developers/docs/resources/ API>@@ -30,8 +36,8 @@ ListGuildEmojis :: Snowflake -> EmojiRequest [Emoji] -- | Emoji object for the given guild and emoji ID GetGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest Emoji- -- | Create a new guild emoji. Requires MANAGE_EMOJIS permission.- -- todo CreateGuildEmoji :: Snowflake -> T.Text -> Image128x128 -> EmojiRequest Emoji+ -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission.+ CreateGuildEmoji :: Snowflake -> T.Text -> EmojiImage -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission ModifyGuildEmoji :: Snowflake -> Snowflake -> ModifyGuildEmojiOpts -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission@@ -46,11 +52,36 @@ toJSON (ModifyGuildEmojiOpts name roles) = object [ "name" .= name, "roles" .= roles ] -userMajorRoute :: EmojiRequest a -> String-userMajorRoute c = case c of++data EmojiImage = EmojiImage [Char]++parseEmojiImage :: Q.ByteString -> Either String EmojiImage+parseEmojiImage bs =+ if Q.length bs > 256000+ then Left "Cannot create emoji - File is larger than 256kb"+ else case (decodeGifImages bs, decodeImage bs) of+ (Left e1, Left e2) -> Left ("Could not parse image or gif: " <> e1+ <> " and " <> e2)+ (Right ims, _) -> if all is128 ims+ then Right (EmojiImage ("data:text/plain;"+ <> "base64,"+ <> Q.unpack (B64.encode bs)))+ else Left ("The frames are not all 128x128")+ (_, Right im) -> if is128 im+ then Right (EmojiImage ("data:text/plain;"+ <> "base64,"+ <> Q.unpack (B64.encode bs)))+ else Left ("Image is not 128x128")+ where+ is128 im = let i = convertRGB8 im+ in imageWidth i == 128 && imageHeight i == 128+++emojiMajorRoute :: EmojiRequest a -> String+emojiMajorRoute c = case c of (ListGuildEmojis g) -> "emoji " <> show g (GetGuildEmoji g _) -> "emoji " <> show g- -- todo (CreateGuildEmoji g) -> "emoji " <> show g+ (CreateGuildEmoji g _ _) -> "emoji " <> show g (ModifyGuildEmoji g _ _) -> "emoji " <> show g (DeleteGuildEmoji g _) -> "emoji " <> show g @@ -62,13 +93,18 @@ guilds :: R.Url 'R.Https guilds = baseUrl /: "guilds" -userJsonRequest :: EmojiRequest r -> JsonRequest-userJsonRequest c = case c of+emojiJsonRequest :: EmojiRequest r -> JsonRequest+emojiJsonRequest c = case c of (ListGuildEmojis g) -> Get (guilds // g) mempty (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty- -- todo (CreateGuildEmoji g) -> Post ()+ (CreateGuildEmoji g name (EmojiImage im)) ->+ Post (guilds // g /: "emojis")+ (pure (R.ReqBodyJson (object [ "name" .= name+ , "image" .= im+ -- todo , "roles" .= ...+ ])))+ mempty (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e) (R.ReqBodyJson o) mempty (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty-
src/Discord/Rest/Guild.hs view
@@ -7,6 +7,7 @@ -- | Provides actions for Channel API interactions module Discord.Rest.Guild ( GuildRequest(..)+ , ModifyGuildOpts(..) , GuildMembersTiming(..) ) where @@ -15,6 +16,7 @@ import Data.Monoid (mempty, (<>)) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R+import qualified Data.Text as T import Discord.Rest.Prelude import Discord.Types@@ -30,7 +32,7 @@ GetGuild :: Snowflake -> GuildRequest Guild -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a -- Guild Update 'Event'.- -- todo ModifyGuild :: ToJSON o => Snowflake -> o -> GuildRequest Guild+ ModifyGuild :: Snowflake -> ModifyGuildOpts -> GuildRequest Guild -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. DeleteGuild :: Snowflake -> GuildRequest Guild -- | Returns a list of guild 'Channel' objects@@ -120,9 +122,28 @@ -- 'GuildEmbed' object. ModifyGuildEmbed :: Snowflake -> GuildEmbed -> GuildRequest GuildEmbed +-- | https://discordapp.com/developers/docs/resources/guild#modify-guild+data ModifyGuildOpts = ModifyGuildOpts+ { modifyGuildOptsName :: Maybe T.Text+ , modifyGuildOptsAFKChannelId :: Maybe Snowflake+ , modifyGuildOptsIcon :: Maybe T.Text+ , modifyGuildOptsOwnerId :: Maybe Snowflake+ -- Region+ -- VerificationLevel+ -- DefaultMessageNotification+ -- ExplicitContentFilter+ }++instance ToJSON ModifyGuildOpts where+ toJSON ModifyGuildOpts{..} = object [(name, val) | (name, Just val) <-+ [("name", toJSON <$> modifyGuildOptsName ),+ ("afk_channel_id", toJSON <$> modifyGuildOptsAFKChannelId ),+ ("icon", toJSON <$> modifyGuildOptsIcon ),+ ("owner_id", toJSON <$> modifyGuildOptsOwnerId )] ]+ data GuildMembersTiming = GuildMembersTiming- { _guildMembersTimingLimit :: Maybe Int- , _guildMembersTimingAfter :: Maybe Snowflake+ { guildMembersTimingLimit :: Maybe Int+ , guildMembersTimingAfter :: Maybe Snowflake } guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https@@ -138,7 +159,7 @@ guildMajorRoute :: GuildRequest a -> String guildMajorRoute c = case c of (GetGuild g) -> "guild " <> show g- -- (ModifyGuild g _) -> "guild " <> show g+ (ModifyGuild g _) -> "guild " <> show g (DeleteGuild g) -> "guild " <> show g (GetGuildChannels g) -> "guild_chan " <> show g -- (CreateGuildChannel g _) -> "guild_chan " <> show g@@ -182,8 +203,8 @@ (GetGuild guild) -> Get (guilds // guild) mempty - -- (ModifyGuild guild patch) ->- -- Patch (guilds // guild) (R.ReqBodyJson patch) mempty+ (ModifyGuild guild patch) ->+ Patch (guilds // guild) (R.ReqBodyJson patch) mempty (DeleteGuild guild) -> Delete (guilds // guild) mempty
src/Discord/Rest/HTTP.hs view
@@ -7,6 +7,7 @@ ( restLoop , Request(..) , JsonRequest(..)+ , RestCallException(..) ) where import Prelude hiding (log)@@ -14,6 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Concurrent (threadDelay)+import Control.Exception.Safe (try) import Control.Concurrent.MVar import Control.Concurrent.Chan import Data.Ix (inRange)@@ -28,12 +30,13 @@ import Discord.Types import Discord.Rest.Prelude -unpackResp :: Either String QL.ByteString -> String-unpackResp r = case r of- Right a -> "Resp " <> QL.unpack a- Left s -> "BadResp " <> s+data RestCallException = RestCallErrorCode Int Q.ByteString+ | RestCallNoParse String QL.ByteString+ | RestCallHttpException R.HttpException+ deriving (Show) -restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either String QL.ByteString)) -> Chan String -> IO ()+restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallException QL.ByteString))+ -> Chan String -> IO () restLoop auth urls log = loop M.empty where loop ratelocker = do@@ -44,35 +47,48 @@ Locked -> do writeChan urls (route, request, thread) loop ratelocker Available -> do let action = compileRequest auth request- (resp, retry) <- restIOtoIO (tryRequest action log)- writeChan log ("rest - response " <> unpackResp resp)- case resp of- Right "" -> putMVar thread (Right "[]") -- empty should be ()- Right bs -> putMVar thread (Right bs)- Left "Try Again" -> writeChan urls (route, request, thread)- Left r -> putMVar thread (Left r)- case retry of- GlobalWait i -> do- 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- NoLimit -> loop ratelocker+ reqIO <- try $ restIOtoIO (tryRequest action log)+ case reqIO :: Either R.HttpException (RequestResponse, Timeout) of+ Left e -> do+ writeChan log ("rest - http exception " <> show e)+ putMVar thread (Left (RestCallHttpException e))+ loop ratelocker+ Right (resp, retry) -> do+ writeChan log ("rest - response " <> show resp)+ case resp of+ -- decode "[]" == () for expected empty calls+ ResponseByteString "" -> putMVar thread (Right "[]")+ ResponseByteString bs -> putMVar thread (Right bs)+ ResponseErrorCode e s -> putMVar thread (Left (RestCallErrorCode e s))+ ResponseTryAgain -> writeChan urls (route, request, thread)+ case retry of+ GlobalWait i -> do+ 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+ NoLimit -> loop ratelocker +data RateLimited = Available | Locked+ compareRate :: (Ord k, Ord v) => M.Map k v -> k -> v -> RateLimited compareRate ratelocker route curtime = case M.lookup route ratelocker of Just unlockTime -> if curtime < unlockTime then Locked else Available Nothing -> Available -data RateLimited = Available | Locked +data RequestResponse = ResponseTryAgain+ | ResponseByteString QL.ByteString+ | ResponseErrorCode Int Q.ByteString+ deriving (Show)+ data Timeout = GlobalWait POSIXTime | PathWait POSIXTime | NoLimit --tryRequest :: RestIO R.LbsResponse -> Chan String -> RestIO (Either String QL.ByteString, Timeout)+tryRequest :: RestIO R.LbsResponse -> Chan String -> RestIO (RequestResponse, Timeout) tryRequest action log = do resp <- action next10 <- liftIO (round . (+10) <$> getPOSIXTime)@@ -80,20 +96,18 @@ status = R.responseStatusMessage resp remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-Ratelimit-Remaining" global = fromMaybe False $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global"- resetInt = fromMaybe next10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset"+ resetInt = fromMaybe next10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset" reset = fromIntegral resetInt if | code == 429 -> do liftIO $ writeChan log ("rest - 429 RATE LIMITED global:" <> show global <> " reset:" <> show reset)- pure (Left "Try Again", if global then GlobalWait reset+ pure (ResponseTryAgain, if global then GlobalWait reset else PathWait reset)- | code `elem` [500,502] -> pure (Left "Try Again", NoLimit)- | inRange (200,299) code -> pure ( Right (R.responseBody resp)+ | code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit)+ | inRange (200,299) code -> pure ( ResponseByteString (R.responseBody resp) , if remain > 0 then NoLimit else PathWait reset )- | inRange (400,499) code -> pure ( Left (show code <> " - " <> Q.unpack status- <> QL.unpack (R.responseBody resp))+ | inRange (400,499) code -> pure (ResponseErrorCode code status , if remain > 0 then NoLimit else PathWait reset )- | otherwise -> let err = "Unexpected code: " ++ show code ++ " - " ++ Q.unpack status- in pure (Left err, NoLimit)+ | otherwise -> pure (ResponseErrorCode code status, NoLimit) readMaybeBS :: Read a => Q.ByteString -> Maybe a readMaybeBS = readMaybe . Q.unpack@@ -109,4 +123,3 @@ (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) (Post url body opts) -> do b <- body R.req R.POST url b R.lbsResponse (authopt <> opts)-
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.1)"+ agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.6.0)" -- Append to an URL infixl 5 //
src/Discord/Rest/User.hs view
@@ -7,13 +7,20 @@ -- | Provides actions for Channel API interactions module Discord.Rest.User ( UserRequest(..)+ , parseCurrentUserAvatar+ , CurrentUserAvatar ) where import Data.Aeson+import Codec.Picture import Data.Monoid (mempty, (<>)) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as Q+import qualified Data.ByteString.Lazy.Char8 as QL+import qualified Data.ByteString.Base64 as B64 import Discord.Rest.Prelude import Discord.Types@@ -31,8 +38,8 @@ GetCurrentUser :: UserRequest User -- | Returns a 'User' for a given user ID GetUser :: Snowflake -> UserRequest User- -- | Modify the requestors user account settings. Returns a 'User' object on success.- -- todo ModifyCurrentUser :: ToJSON o => o -> UserRequest User+ -- | Modify user's username & avatar pic+ ModifyCurrentUser :: T.Text -> CurrentUserAvatar -> UserRequest User -- | Returns a list of user 'Guild' objects the current user is a member of. -- Requires the guilds OAuth2 scope. GetCurrentUserGuilds :: UserRequest [PartialGuild]@@ -43,12 +50,22 @@ -- | Create a new DM channel with a user. Returns a DM 'Channel' object. CreateDM :: Snowflake -> UserRequest Channel +-- | Formatted avatar data https://discordapp.com/developers/docs/resources/user#avatar-data+data CurrentUserAvatar = CurrentUserAvatar String +parseCurrentUserAvatar :: Q.ByteString -> Either String CurrentUserAvatar+parseCurrentUserAvatar bs =+ case decodeImage bs of+ Left e -> Left e+ Right im -> Right $ CurrentUserAvatar $ "data:image/png;base64,"+ <> Q.unpack (B64.encode (QL.toStrict (encodePng (convertRGBA8 im))))++ userMajorRoute :: UserRequest a -> String userMajorRoute c = case c of (GetCurrentUser) -> "me " (GetUser _) -> "user "- -- (ModifyCurrentUser _) -> "modify_user "+ (ModifyCurrentUser _ _) -> "modify_user " (GetCurrentUserGuilds) -> "get_user_guilds " (LeaveGuild g) -> "leave_guild " <> show g (GetUserDMs) -> "get_dms "@@ -68,8 +85,9 @@ (GetUser user) -> Get (users // user ) mempty - -- (ModifyCurrentUser patch) ->- -- Patch (users /: "@me") (R.ReqBodyJson patch) mempty+ (ModifyCurrentUser name (CurrentUserAvatar im)) ->+ Patch (users /: "@me") (R.ReqBodyJson (object [ "username" .= name+ , "avatar" .= im ])) mempty (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty
src/Discord/Types/Channel.hs view
@@ -171,6 +171,7 @@ , messageNonce :: Maybe Snowflake -- ^ Used for validating if a message -- was sent , messagePinned :: Bool -- ^ Whether this message is pinned+ , messageGuild :: Maybe Snowflake -- ^ The guild the message went to } deriving (Show, Eq) instance FromJSON Message where@@ -189,6 +190,7 @@ <*> o .: "embeds" <*> o .:? "nonce" <*> o .:? "pinned" .!= False+ <*> o .:? "guild_id" .!= Nothing -- | Represents an attached to a message file. data Attachment = Attachment
src/Discord/Types/Gateway.hs view
@@ -37,11 +37,13 @@ | RequestGuildMembers RequestGuildMembersOpts | UpdateStatus UpdateStatusOpts | UpdateStatusVoice UpdateStatusVoiceOpts+ deriving (Show) data RequestGuildMembersOpts = RequestGuildMembersOpts { requestGuildMemersGuildId :: Snowflake , requestGuildMemersSearchQuery :: T.Text , requestGuildMemersLimit :: Integer }+ deriving (Show) data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts { updateStatusVoiceGuildId :: Snowflake@@ -49,6 +51,7 @@ , updateStatusVoiceIsMuted :: Snowflake , updateStatusVoiceIsDeaf :: Snowflake }+ deriving (Show) data UpdateStatusOpts = UpdateStatusOpts { updateStatusSince :: Maybe UTCTime@@ -56,12 +59,14 @@ , updateStatusNewStatus :: UpdateStatusTypes , updateStatusAFK :: Bool }+ deriving (Show) data UpdateStatusTypes = UpdateStatusOnline | UpdateStatusDoNotDisturb | UpdateStatusAwayFromKeyboard | UpdateStatusInvisibleOffline | UpdateStatusOffline+ deriving (Show) statusString :: UpdateStatusTypes -> T.Text statusString s = case s of
src/Discord/Types/Prelude.hs view
@@ -23,7 +23,9 @@ -- | Formats the token for use with the REST API formatAuth :: Auth -> Q.ByteString-formatAuth (Auth token) = "Bot " <> TE.encodeUtf8 token+formatAuth (Auth token) = TE.encodeUtf8 $ bot <> token+ where+ bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " -- | Get the raw token formatted for use with the websocket gateway authToken :: Auth -> T.Text