diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Joshua Koike + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/discord-haskell.cabal b/discord-haskell.cabal new file mode 100644 --- /dev/null +++ b/discord-haskell.cabal @@ -0,0 +1,62 @@ +name: discord-haskell +-- library version is also noted at src/Discord/Rest/Prelude.hs +version: 0.5.0 +synopsis: Discord bot library for Haskell +description: Functions and data types to write discord bots. + See docs: +homepage: https://github.com/aquarial/discord-haskell +license: MIT +license-file: LICENSE +author: Karl +maintainer: ksfish5@gmail.com +-- copyright: +category: Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + ghc-options: -Wall + -fno-warn-type-defaults + hs-source-dirs: src + default-language: Haskell2010 + -- extensions: + exposed-modules: Discord + , Discord.Gateway + , Discord.Gateway.Cache + , Discord.Gateway.EventLoop + , Discord.Rest + , Discord.Rest.Prelude + , Discord.Rest.HTTP + , Discord.Rest.Emoji + , Discord.Rest.User + , Discord.Rest.Guild + , Discord.Rest.Channel + , Discord.Types + , Discord.Types.Prelude + , Discord.Types.Channel + , Discord.Types.Events + , Discord.Types.Gateway + , Discord.Types.Guild + build-depends: + base >=4.10.1.0 && <4.11 + , aeson >=1.2.4.0 && <1.3 + , async >=2.1.1.1 && <2.2 + , bytestring >=0.10.8.2 && <0.11 + , 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 + , safe-exceptions >=0.1.7.0 && <0.2 + , text >=1.2.3.0 && <1.3 + , time >=1.8.0.2 && <1.9 + , unordered-containers >=0.2.9.0 && <0.3 + , vector >=0.12.0.1 && <0.13 + , websockets >=0.12.4.1 && <0.13 + , wuss >=1.1.9 && <1.2 + +source-repository head + type : git + location: https://github.com/aquarial/discord-haskell diff --git a/src/Discord.hs b/src/Discord.hs new file mode 100644 --- /dev/null +++ b/src/Discord.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE RankNTypes #-} + +module Discord + ( module Discord.Types + , module Discord.Rest.Channel + , module Discord.Rest.Guild + , module Discord.Rest.User + , module Discord.Rest.Emoji + , Cache(..) + , Gateway(..) + , RestChan(..) + , Request(..) + , restCall + , nextEvent + , sendCommand + , readCache + , stopDiscord + , loginRest + , loginRestGateway + ) where + +import Prelude hiding (log) +import Control.Monad (forever) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Data.Monoid ((<>)) +import Data.Aeson + +import Discord.Rest +import Discord.Rest.Channel +import Discord.Rest.Guild +import Discord.Rest.User +import Discord.Rest.Emoji +import Discord.Types +import Discord.Gateway +import Discord.Gateway.Cache + +-- | Thread Ids marked by what type they are +data ThreadIdType = ThreadRest ThreadId + | ThreadGateway ThreadId + | ThreadLogger ThreadId + +-- | As opposed to a Gateway object +data NotLoggedIntoGateway = NotLoggedIntoGateway + +-- | Start HTTP rest handler background threads +loginRest :: Auth -> IO (RestChan, NotLoggedIntoGateway, [ThreadIdType]) +loginRest auth = do + log <- newChan + logId <- forkIO (logger log True) + (restHandler, restId) <- createHandler auth log + pure (restHandler, NotLoggedIntoGateway, [ ThreadLogger logId + , ThreadRest restId + ]) + +-- | Start HTTP rest handler and gateway background threads +loginRestGateway :: Auth -> IO (RestChan, Gateway, [ThreadIdType]) +loginRestGateway auth = do + log <- newChan + logId <- forkIO (logger log True) + (restHandler, restId) <- createHandler auth log + (gate, gateId) <- startGatewayThread auth log + 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 (r,_,_) = writeRestCall r + +-- | Block until the gateway produces another event +nextEvent :: (x, Gateway, z) -> IO Event +nextEvent (_,g,_) = readChan (_events g) + +-- | Send a GatewaySendable, but not Heartbeat, Identify, or Resume +sendCommand :: (x, Gateway, z) -> GatewaySendable -> IO () +sendCommand (_,g,_) e = case e of + Heartbeat _ -> pure () + Identify _ _ _ _ -> pure () + Resume _ _ _ -> pure () + _ -> writeChan (_gatewayCommands g) e + +-- | Access the current state of the gateway cache +readCache :: (RestChan, Gateway, z) -> IO Cache +readCache (_,g,_) = readMVar (_cache g) + +-- | Stop all the background threads +stopDiscord :: (x, y, [ThreadIdType]) -> IO () +stopDiscord (_,_,is) = threadDelay (10^6 `div` 10) >> mapM_ (killThread . toId) is + where toId t = case t of + ThreadRest a -> a + ThreadGateway a -> a + ThreadLogger a -> a + +-- | Add anything from the Chan to the log file, forever +logger :: Chan String -> Bool -> IO () +logger log False = forever $ readChan log >>= \_ -> pure () +logger log True = forever $ do + x <- readChan log + let line = x <> "\n\n" + appendFile "the-log-of-discord-haskell.txt" line diff --git a/src/Discord/Gateway.hs b/src/Discord/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Gateway.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_HADDOCK prune, not-home #-} + +-- | Provides a rather raw interface to the websocket events +-- through a real-time Chan +module Discord.Gateway + ( Gateway(..) + , 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 Discord.Types (Auth, Event, GatewaySendable) +import Discord.Gateway.EventLoop (connectionLoop) +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 + , _gatewayCommands :: Chan GatewaySendable + } + +-- | Create a Chan for websockets. This creates a thread that +-- writes all the received Events to the Chan +startGatewayThread :: Auth -> Chan String -> IO (Gateway, ThreadId) +startGatewayThread auth log = do + 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) + pure (Gateway eventsWrite cache sends, tid) + + + diff --git a/src/Discord/Gateway/Cache.hs b/src/Discord/Gateway/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Gateway/Cache.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune, not-home #-} + +-- | Query info about connected Guilds and Channels +module Discord.Gateway.Cache where + +import Prelude hiding (log) +import Data.Monoid ((<>)) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import qualified Data.Map.Strict as M + +import Discord.Types + +data Cache = Cache + { _currentUser :: User + , _dmChannels :: M.Map Snowflake Channel + , _guilds :: M.Map Snowflake (Guild, GuildInfo) + , _channels :: M.Map Snowflake Channel + } deriving (Show) + +emptyCache :: IO (MVar Cache) +emptyCache = newEmptyMVar + +addEvent :: MVar Cache -> Chan Event -> Chan String -> IO () +addEvent cache eventChan log = do + ready <- readChan eventChan + case ready of + (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 + where + loop :: IO () + loop = do + event <- readChan eventChan + minfo <- takeMVar cache + putMVar cache (adjustCache minfo event) + loop + +adjustCache :: Cache -> Event -> Cache +adjustCache minfo event = case event of + --ChannelCreate Channel + --ChannelUpdate Channel + --ChannelDelete Channel + GuildCreate guild info -> + let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info + g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (_guilds minfo) + c = M.unionWith (\a _ -> a) + (M.fromList [ (channelId ch, ch) | ch <- newChans ]) + (_channels minfo) + in minfo { _guilds = g, _channels = c } + --GuildUpdate guild -> do + -- let g = M.insert (guildId guild) guild (_guilds minfo) + -- m2 = minfo { _guilds = g } + -- putMVar cache m2 + --GuildDelete guild -> do + -- let g = M.delete (guildId guild) (_guilds minfo) + -- c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (_channels minfo) + -- m2 = minfo { _guilds = g, _channels = c } + -- putMVar cache m2 + _ -> minfo + +setChanGuildID :: Snowflake -> Channel -> Channel +setChanGuildID s c = if isGuildChannel c + then c { channelGuild = s } + else c diff --git a/src/Discord/Gateway/EventLoop.hs b/src/Discord/Gateway/EventLoop.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Gateway/EventLoop.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune, not-home #-} + +-- | Provides logic code for interacting with the Discord websocket +-- gateway. Realistically, this is probably lower level than most +-- people will need +module Discord.Gateway.EventLoop where + +import Prelude hiding (log) + +import Control.Monad (forever, (<=<)) +import Control.Monad.Random (getRandomR) +import Control.Concurrent.Async (race) +import Control.Concurrent.Chan +import Control.Exception.Safe (try, finally, handle, SomeException) +import Control.Concurrent (threadDelay, killThread, forkIO) +import Data.Monoid ((<>)) +import Data.IORef +import Data.Aeson (eitherDecode, encode) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as QL + +import Wuss (runSecureClient) +import Network.WebSockets (ConnectionException(..), Connection, + sendClose, receiveData, sendTextData) + +import Discord.Types + +data ConnLoopState = ConnStart + | ConnClosed + | ConnReconnect T.Text 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 + } + +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) + +connectionLoop :: Auth -> Chan Event -> Chan GatewaySendable -> Chan String -> IO () +connectionLoop auth events sends log = loop ConnStart + where + loop :: ConnLoopState -> IO () + loop s = do + writeChan log ("conn loop: " <> show s) + case s of + (ConnClosed) -> writeChan log "Conn Closed" + (ConnStart) -> do + loop <=< connect sends log $ \conn send -> do + msg <- getPayload conn log + case msg of + Right (Hello interval) -> do + sendTextData conn (encode (Identify auth False 50 (0, 1))) + msg2 <- getPayload conn log + 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 + + (ConnReconnect tok seshID seqID) -> do + next <- try $ connect sends log $ \conn send -> 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 + 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) + pure ConnClosed + Left e -> + writeChan log ("message - error " <> show e) >> pure ConnClosed + case next :: Either SomeException ConnLoopState of + Left e -> do writeChan log ("exception - connecting: " <> show e) + t <- getRandomR (3,10) + threadDelay (t * 10^6) + loop (ConnReconnect tok seshID seqID) + Right n -> loop n + + +getPayloadTimeout :: Connection -> Int -> Chan String -> IO (Either ConnectionException GatewayReceivable) +getPayloadTimeout conn interval log = do + res <- race (threadDelay (interval * 1000 * 3 `div` 2)) + (getPayload conn log) + case res of + Left () -> pure (Right (InvalidSession True)) + 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') + case eitherDecode msg' of + Right msg -> return msg + Left err -> do writeChan log ("parse error Error - " <> err) + writeChan log ("parse error Message - " <> show msg') + return (ParseError err) + +heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> Chan String -> IO () +heartbeat send interval seqKey log = do + writeChan log "starting the heartbeat" + forever $ do + num <- readIORef seqKey + writeChan send (Heartbeat num) + threadDelay (interval * 1000) + +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 send 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) + ConnReconnect auth seshID <$> readIORef seqKey + handle err $ finally (eventStream (ConnData conn seshID auth events) seqKey interval send log) + (killThread heart) + +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 + loop = do + eitherPayload <- getPayloadTimeout conn interval log + case eitherPayload :: Either ConnectionException GatewayReceivable of + Left (CloseRequest code str) -> case code of + -- see discord documentation on gateway close event codes + 1000 -> ConnReconnect auth seshID <$> readIORef seqKey + 4000 -> ConnReconnect auth seshID <$> readIORef seqKey + 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) + pure ConnClosed + Left _ -> ConnReconnect auth seshID <$> readIORef seqKey + Right (Dispatch event sq) -> do setSequence seqKey sq + writeChan eventChan 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 (InvalidSession retry) -> if retry + then ConnReconnect auth seshID <$> readIORef seqKey + else pure ConnStart + Right (HeartbeatAck) -> loop + Right p -> writeChan log ("error - Invalid gateway payload: " <> show p) >> pure ConnClosed diff --git a/src/Discord/Rest.hs b/src/Discord/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune, not-home #-} + +-- | Provides a higher level interface to the rest functions. +-- Preperly writes to the rate-limit loop. Creates separate +-- MVars for each call +module Discord.Rest + ( module Discord.Types + , RestChan(..) + , Request(..) + , writeRestCall + , createHandler + ) where + +import Prelude hiding (log) +import Data.Aeson (FromJSON, eitherDecode) +import Data.Monoid ((<>)) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent (forkIO, ThreadId) +import qualified Data.ByteString.Lazy.Char8 as QL + +import Discord.Types +import Discord.Rest.HTTP + +newtype RestChan = RestChan (Chan (String, JsonRequest, MVar (Either String QL.ByteString))) + +-- | Starts the http request thread. Please only call this once +createHandler :: Auth -> Chan String -> IO (RestChan, ThreadId) +createHandler auth log = do + c <- newChan + tid <- forkIO $ restLoop auth c log + 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 (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 + + + diff --git a/src/Discord/Rest/Channel.hs b/src/Discord/Rest/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/Channel.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Rest.Channel + ( ChannelRequest(..) + , ReactionTiming(..) + , MessageTiming(..) + , ModifyChannelOptions(..) + ) where + + +import Data.Aeson +import qualified Data.ByteString.Lazy as BL +import Data.Monoid (mempty, (<>)) +import qualified Data.Text as T +import Network.HTTP.Client (RequestBody (RequestBodyLBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody) +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Rest.Prelude +import Discord.Types + +instance Request (ChannelRequest a) where + majorRoute = channelMajorRoute + jsonRequest = channelJsonRequest + +-- | Data constructor for requests. See +data ChannelRequest a where + -- | Gets a channel by its id. + GetChannel :: Snowflake -> ChannelRequest Channel + -- | Edits channels options. + ModifyChannel :: Snowflake -> ModifyChannelOptions -> 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. + GetChannelMessages :: Snowflake -> (Int, MessageTiming) -> ChannelRequest [Message] + -- | Gets a message in a channel by its id. + GetChannelMessage :: (Snowflake, Snowflake) -> ChannelRequest Message + -- | Sends a message to a channel. + CreateMessage :: Snowflake -> T.Text -> Maybe Embed -> ChannelRequest Message + -- | Sends a message with a file to a channel. + UploadFile :: Snowflake -> FilePath -> BL.ByteString -> ChannelRequest Message + -- | Add an emoji reaction to a message. ID must be present for custom emoji + CreateReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) + -> ChannelRequest () + -- | Remove a Reaction this bot added + DeleteOwnReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) + -> ChannelRequest () + -- | Remove a Reaction someone else added + DeleteUserReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) + -> Snowflake -> ChannelRequest () + -- | List of users that reacted with this emoji + GetReactions :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake) + -> (Int, ReactionTiming) -> ChannelRequest () + -- | Delete all reactions on a message + DeleteAllReactions :: (Snowflake, Snowflake) -> ChannelRequest () + -- | Edits a message content. + EditMessage :: (Snowflake, Snowflake) -> T.Text -> Maybe Embed + -> ChannelRequest Message + -- | Deletes a message. + 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 () + -- | 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 + -- | Deletes a permission override from a channel. + DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest () + -- | Sends a typing indicator a channel which lasts 10 seconds. + TriggerTypingIndicator :: Snowflake -> ChannelRequest () + -- | Gets all pinned messages of a channel. + GetPinnedMessages :: Snowflake -> ChannelRequest [Message] + -- | Pins a message. + 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 () + + +-- | Data constructor for GetReaction requests +data ReactionTiming = BeforeReaction Snowflake + | AfterReaction Snowflake + +reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https +reactionTimingToQuery t = case t of + (BeforeReaction snow) -> "before" R.=: show snow + (AfterReaction snow) -> "after" R.=: show snow + +-- | Data constructor for GetChannelMessages requests. See +data MessageTiming = AroundMessage Snowflake + | BeforeMessage Snowflake + | AfterMessage Snowflake + +messageTimingToQuery :: MessageTiming -> R.Option 'R.Https +messageTimingToQuery t = case t of + (AroundMessage snow) -> "around" R.=: show snow + (BeforeMessage snow) -> "before" R.=: show snow + (AfterMessage snow) -> "after" R.=: show snow + +data ModifyChannelOptions = ModifyChannelOptions + { modifyChannelName :: Maybe String + , modifyChannelPosition :: Maybe Integer + , modifyChannelTopic :: Maybe String + , modifyChannelNSFW :: Maybe Bool + , modifyChannelBitrate :: Maybe Integer + , modifyChannelUserRateLimit :: Maybe Integer + , modifyChannelPermissionOverwrites :: Maybe [Overwrite] + , modifyChannelParentId :: Maybe Snowflake + } + +instance ToJSON ModifyChannelOptions where + toJSON ModifyChannelOptions{..} = object [(name, val) | (name, Just val) <- + [("name", toJSON <$> modifyChannelName), + ("position", toJSON <$> modifyChannelPosition), + ("topic", toJSON <$> modifyChannelTopic), + ("nsfw", toJSON <$> modifyChannelNSFW), + ("bitrate", toJSON <$> modifyChannelBitrate), + ("user_limit", toJSON <$> modifyChannelUserRateLimit), + ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), + ("parent_id", toJSON <$> modifyChannelParentId) ] ] + +channelMajorRoute :: ChannelRequest a -> String +channelMajorRoute c = case c of + (GetChannel chan) -> "get_chan " <> show chan + (ModifyChannel chan _) -> "mod_chan " <> show chan + (DeleteChannel chan) -> "mod_chan " <> show chan + (GetChannelMessages chan _) -> "msg " <> show chan + (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 + (EditMessage (chan, _) _ _) -> "get_msg " <> show chan + (DeleteMessage (chan, _)) -> "get_msg " <> show chan + (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan + -- todo (EditChannelPermissions chan _ _) -> "perms " <> show chan + (GetChannelInvites chan) -> "invites " <> show chan + -- todo (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 + + +maybeEmbed :: Maybe Embed -> [(T.Text, Value)] +maybeEmbed = maybe [] $ \embed -> ["embed" .= embed] + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +channels :: R.Url 'R.Https +channels = baseUrl /: "channels" + +channelJsonRequest :: ChannelRequest r -> JsonRequest +channelJsonRequest c = case c of + (GetChannel chan) -> + Get (channels // chan) mempty + + (ModifyChannel chan patch) -> + Patch (channels // chan) (R.ReqBodyJson patch) mempty + + (DeleteChannel chan) -> + Delete (channels // chan) mempty + + (GetChannelMessages chan (n,timing)) -> + let n' = if n < 1 then 1 else (if n > 100 then 100 else n) + options = "limit" R.=: n' <> messageTimingToQuery timing + in Get (channels // chan /: "messages") options + + (GetChannelMessage (chan, msg)) -> + Get (channels // chan /: "messages" // msg) mempty + + (CreateMessage chan msg embed) -> + let content = ["content" .= msg] <> maybeEmbed embed + body = pure $ R.ReqBodyJson $ object content + in Post (channels // chan /: "messages") body mempty + + (UploadFile chan fileName file) -> + let part = partFileRequestBody "file" fileName $ RequestBodyLBS file + body = R.reqBodyMultipart [part] + in Post (channels // chan /: "messages") body mempty + + (CreateReaction (chan, msgid) (name, rID)) -> + let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID + in Put (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" ) + R.NoReqBody mempty + + (DeleteOwnReaction (chan, msgid) (name, rID)) -> + let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID + in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" ) mempty + + (DeleteUserReaction (chan, msgid) (name, rID) uID) -> + let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID + in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji // uID ) mempty + + (GetReactions (chan, msgid) (name, rID) (n, timing)) -> + let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID + n' = if n < 1 then 1 else (if n > 100 then 100 else n) + options = "limit" R.=: n' <> reactionTimingToQuery timing + in Get (channels // chan /: "messages" // msgid /: "reactions" /: emoji ) options + + (DeleteAllReactions (chan, msgid)) -> + Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty + + (EditMessage (chan, msg) new embed) -> + let content = ["content" .= new] <> maybeEmbed embed + body = R.ReqBodyJson $ object content + in Patch (channels // chan /: "messages" // msg) body mempty + + (DeleteMessage (chan, msg)) -> + Delete (channels // chan /: "messages" // msg) mempty + + (BulkDeleteMessage (chan, msgs)) -> + 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 + + (GetChannelInvites chan) -> + Get (channels // chan /: "invites") mempty + + -- todo (CreateChannelInvite chan patch) -> + -- Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannelPermission chan perm) -> + Delete (channels // chan /: "permissions" // perm) mempty + + (TriggerTypingIndicator chan) -> + Post (channels // chan /: "typing") (pure R.NoReqBody) mempty + + (GetPinnedMessages chan) -> + Get (channels // chan /: "pins") mempty + + (AddPinnedMessage (chan, msg)) -> + Put (channels // chan /: "pins" // msg) R.NoReqBody mempty + + (DeletePinnedMessage (chan, msg)) -> + Delete (channels // chan /: "pins" // msg) mempty + diff --git a/src/Discord/Rest/Emoji.hs b/src/Discord/Rest/Emoji.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/Emoji.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Rest.Emoji + ( EmojiRequest(..) + , ModifyGuildEmojiOpts(..) + ) where + +import Data.Aeson +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 + +instance Request (EmojiRequest a) where + majorRoute = userMajorRoute + jsonRequest = userJsonRequest + + +-- | Data constructor for requests. See +data EmojiRequest a where + -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. + 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 + -- | Requires MANAGE_EMOJIS permission + ModifyGuildEmoji :: Snowflake -> Snowflake -> ModifyGuildEmojiOpts -> EmojiRequest Emoji + -- | Requires MANAGE_EMOJIS permission + DeleteGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest () + +data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts + { modifyGuildEmojiName :: T.Text + , modifyGuildEmojiRoles :: [Snowflake] + } + +instance ToJSON ModifyGuildEmojiOpts where + toJSON (ModifyGuildEmojiOpts name roles) = + object [ "name" .= name, "roles" .= roles ] + +userMajorRoute :: EmojiRequest a -> String +userMajorRoute c = case c of + (ListGuildEmojis g) -> "emoji " <> show g + (GetGuildEmoji g _) -> "emoji " <> show g + -- todo (CreateGuildEmoji g) -> "emoji " <> show g + (ModifyGuildEmoji g _ _) -> "emoji " <> show g + (DeleteGuildEmoji g _) -> "emoji " <> show g + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +userJsonRequest :: EmojiRequest r -> JsonRequest +userJsonRequest c = case c of + (ListGuildEmojis g) -> Get (guilds // g) mempty + (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty + -- todo (CreateGuildEmoji g) -> Post () + (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e) + (R.ReqBodyJson o) + mempty + (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty + diff --git a/src/Discord/Rest/Guild.hs b/src/Discord/Rest/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/Guild.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Rest.Guild + ( GuildRequest(..) + , GuildMembersTiming(..) + ) where + + +import Data.Aeson +import Data.Monoid (mempty, (<>)) +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Rest.Prelude +import Discord.Types + +instance Request (GuildRequest a) where + majorRoute = guildMajorRoute + jsonRequest = guildJsonRequest + +-- | Data constructor for requests. See +data GuildRequest a where + -- todo CreateGuild :: So many parameters + -- | Returns the new 'Guild' object for the given id + 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 + -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. + DeleteGuild :: Snowflake -> GuildRequest Guild + -- | Returns a list of guild 'Channel' objects + GetGuildChannels :: Snowflake -> GuildRequest [Channel] + -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS' + -- permission. Returns the new 'Channel' object on success. Fires a Channel Create + -- 'Event' + -- todo CreateGuildChannel :: ToJSON o => Snowflake -> o -> GuildRequest Channel + -- | Modify the positions of a set of channel objects for the guild. Requires + -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel' + -- objects on success. Fires multiple Channel Update 'Event's. + -- todo ModifyChanPosition :: ToJSON o => Snowflake -> o -> GuildRequest [Channel] + -- | Returns a guild 'Member' object for the specified user + GetGuildMember :: Snowflake -> Snowflake -> GuildRequest GuildMember + -- | Returns a list of guild 'Member' objects that are members of the guild. + ListGuildMembers :: Snowflake -> GuildMembersTiming -> GuildRequest [GuildMember] + -- | Adds a user to the guild, provided you have a valid oauth2 access token + -- for the user with the guilds.join scope. Returns the guild 'Member' as the body. + -- Fires a Guild Member Add 'Event'. Requires the bot to have the + -- CREATE_INSTANT_INVITE permission. + -- todo AddGuildMember :: ToJSON o => Snowflake -> Snowflake -> o + -- -> GuildRequest GuildMember + -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. + -- todo ModifyGuildMember :: ToJSON o => Snowflake -> Snowflake -> o + -- -> GuildRequest () + -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a + -- Guild Member Remove 'Event'. + RemoveGuildMember :: Snowflake -> Snowflake -> GuildRequest () + -- | Returns a list of 'User' objects that are banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBans :: Snowflake -> GuildRequest [User] + -- | Create a guild ban, and optionally Delete previous messages sent by the banned + -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'. + CreateGuildBan :: Snowflake -> Snowflake -> Integer -> GuildRequest () + -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions. + -- Fires a Guild Ban Remove 'Event'. + RemoveGuildBan :: Snowflake -> Snowflake -> GuildRequest () + -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES' + -- permission + GetGuildRoles :: Snowflake -> GuildRequest [Role] + -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. + -- Returns the new role object on success. Fires a Guild Role Create 'Event'. + CreateGuildRole :: Snowflake -> GuildRequest Role + -- | Modify the positions of a set of role objects for the guild. Requires the + -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects + -- on success. Fires multiple Guild Role Update 'Event's. + -- todo ModifyGuildRolePositions :: ToJSON o => Snowflake -> [o] -> GuildRequest [Role] + -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the + -- updated 'Role' on success. Fires a Guild Role Update 'Event's. + -- todo ModifyGuildRole :: ToJSON o => Snowflake -> Snowflake -> o + -- -> GuildRequest Role + -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role + -- Delete 'Event'. + DeleteGuildRole :: Snowflake -> Snowflake -> GuildRequest Role + -- | Returns an object with one 'pruned' key indicating the number of members + -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS' + -- permission. + GetGuildPruneCount :: Snowflake -> Integer -> GuildRequest Object + -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an + -- object with one 'pruned' key indicating the number of members that were removed + -- in the prune operation. Fires multiple Guild Member Remove 'Events'. + BeginGuildPrune :: Snowflake -> Integer -> GuildRequest Object + -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice + -- route, this returns VIP servers when the guild is VIP-enabled. + GetGuildVoiceRegions :: Snowflake -> GuildRequest [VoiceRegion] + -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildInvites :: Snowflake -> GuildRequest [Invite] + -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildIntegrations :: Snowflake -> GuildRequest [Integration] + -- | Attach an 'Integration' object from the current user to the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + -- todo CreateGuildIntegration :: ToJSON o => Snowflake -> o -> GuildRequest () + -- | Modify the behavior and settings of a 'Integration' object for the guild. + -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + -- todo ModifyGuildIntegration :: ToJSON o => Snowflake -> Snowflake -> o -> GuildRequest () + -- | Delete the attached 'Integration' object for the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + DeleteGuildIntegration :: Snowflake -> Snowflake -> GuildRequest () + -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. + SyncGuildIntegration :: Snowflake -> Snowflake -> GuildRequest () + -- | Returns the 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission. + GetGuildEmbed :: Snowflake -> GuildRequest GuildEmbed + -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with + -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated + -- 'GuildEmbed' object. + ModifyGuildEmbed :: Snowflake -> GuildEmbed -> GuildRequest GuildEmbed + +data GuildMembersTiming = GuildMembersTiming + { _guildMembersTimingLimit :: Maybe Int + , _guildMembersTimingAfter :: Maybe Snowflake + } + +guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https +guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = + let limit = case mLimit of + Nothing -> mempty + Just lim -> "limit" R.=: lim + after = case mAfter of + Nothing -> mempty + Just aft -> "after" R.=: show aft + in limit <> after + +guildMajorRoute :: GuildRequest a -> String +guildMajorRoute c = case c of + (GetGuild 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 + -- (ModifyChanPosition g _) -> "guild_chan " <> show g + (GetGuildMember g _) -> "guild_memb " <> show g + (ListGuildMembers g _) -> "guild_membs " <> show g + -- (AddGuildMember g _ _) -> "guild_memb " <> show g + -- (ModifyGuildMember g _ _) -> "guild_memb " <> show g + (RemoveGuildMember g _) -> "guild_memb " <> show g + (GetGuildBans g) -> "guild_bans " <> show g + (CreateGuildBan g _ _) -> "guild_ban " <> show g + (RemoveGuildBan g _) -> "guild_ban " <> show g + (GetGuildRoles g) -> "guild_roles " <> show g + (CreateGuildRole g) -> "guild_roles " <> show g + -- (ModifyGuildRolePositions g _) -> "guild_roles " <> show g + -- (ModifyGuildRole g _ _) -> "guild_role " <> show g + (DeleteGuildRole g _ ) -> "guild_role " <> show g + (GetGuildPruneCount g _) -> "guild_prune " <> show g + (BeginGuildPrune g _) -> "guild_prune " <> show g + (GetGuildVoiceRegions g) -> "guild_voice " <> show g + (GetGuildInvites g) -> "guild_invit " <> show g + (GetGuildIntegrations g) -> "guild_integ " <> show g + -- (CreateGuildIntegration g _) -> "guild_integ " <> show g + -- (ModifyGuildIntegration g _ _) -> "guild_intgr " <> show g + (DeleteGuildIntegration g _) -> "guild_intgr " <> show g + (SyncGuildIntegration g _) -> "guild_sync " <> show g + (GetGuildEmbed g) -> "guild_embed " <> show g + (ModifyGuildEmbed g _) -> "guild_embed " <> show g + + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +guildJsonRequest :: GuildRequest r -> JsonRequest +guildJsonRequest c = case c of + (GetGuild guild) -> + Get (guilds // guild) mempty + + -- (ModifyGuild guild patch) -> + -- Patch (guilds // guild) (R.ReqBodyJson patch) mempty + + (DeleteGuild guild) -> + Delete (guilds // guild) mempty + + (GetGuildChannels guild) -> + Get (guilds // guild /: "channels") mempty + + -- (CreateGuildChannel guild patch) -> + -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + + -- (ModifyChanPosition guild patch) -> + -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + + (GetGuildMember guild member) -> + Get (guilds // guild /: "members" // member) mempty + + (ListGuildMembers guild range) -> + Get (guilds // guild /: "members") (guildMembersTimingToQuery range) + + -- (AddGuildMember guild user patch) -> + -- Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty + + -- (ModifyGuildMember guild member patch) -> + -- let body = R.ReqBodyJson patch + -- in Patch (guilds // guild /: "members" // member) body mempty + + (RemoveGuildMember guild user) -> + Delete (guilds // guild /: "members" // user) mempty + + (GetGuildBans guild) -> + Get (guilds // guild /: "bans") mempty + + (CreateGuildBan guild user msgs) -> + let body = R.ReqBodyJson (object ["delete-message-days" .= msgs]) + in Put (guilds // guild /: "bans" // user) body mempty + + (RemoveGuildBan guild ban) -> + Delete (guilds // guild /: "bans" // ban) mempty + + (GetGuildRoles guild) -> + Get (guilds // guild /: "roles") mempty + + (CreateGuildRole guild) -> + Post (guilds // guild /: "roles") (pure R.NoReqBody) mempty + + -- (ModifyGuildRolePositions guild patch) -> + -- Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) mempty + -- (ModifyGuildRole guild role patch) -> + -- Post (guilds // guild /: "roles" // role) (pure (R.ReqBodyJson patch)) mempty + + (DeleteGuildRole guild role) -> + Delete (guilds // guild /: "roles" // role) mempty + + (GetGuildPruneCount guild days) -> + Get (guilds // guild /: "prune") ("days" R.=: days) + + (BeginGuildPrune guild days) -> + Post (guilds // guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) + + (GetGuildVoiceRegions guild) -> + Get (guilds // guild /: "regions") mempty + + (GetGuildInvites guild) -> + Get (guilds // guild /: "invites") mempty + + (GetGuildIntegrations guild) -> + Get (guilds // guild /: "integrations") mempty + + -- (CreateGuildIntegration guild patch) -> + -- Post (guilds // guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty + + -- (ModifyGuildIntegration guild integ patch) -> + -- let body = R.ReqBodyJson patch + -- in Patch (guilds // guild /: "integrations" // integ) body mempty + + (DeleteGuildIntegration guild integ) -> + Delete (guilds // guild /: "integrations" // integ) mempty + + (SyncGuildIntegration guild integ) -> + Post (guilds // guild /: "integrations" // integ) (pure R.NoReqBody) mempty + + (GetGuildEmbed guild) -> + Get (guilds // guild /: "integrations") mempty + + (ModifyGuildEmbed guild patch) -> + Patch (guilds // guild /: "embed") (R.ReqBodyJson patch) mempty + diff --git a/src/Discord/Rest/HTTP.hs b/src/Discord/Rest/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/HTTP.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Provide HTTP primitives +module Discord.Rest.HTTP + ( restLoop + , Request(..) + , JsonRequest(..) + ) where + +import Prelude hiding (log) +import Data.Semigroup ((<>)) + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.Ix (inRange) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString.Char8 as Q +import qualified Data.ByteString.Lazy.Char8 as QL +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) +import qualified Network.HTTP.Req as R +import qualified Data.Map.Strict as M + +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 + +restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either String QL.ByteString)) -> Chan String -> IO () +restLoop auth urls log = loop M.empty + where + loop ratelocker = do + threadDelay (40 * 1000) + (route, request, thread) <- readChan urls + curtime <- getPOSIXTime + case compareRate ratelocker route curtime of + 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 - got 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 " <> show ((i - curtime) * 1000)) + threadDelay $ round ((i - curtime + 0.1) * 1000) + loop ratelocker + PathWait i -> loop $ M.insert route i ratelocker + NoLimit -> loop ratelocker + +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 Timeout = GlobalWait POSIXTime + | PathWait POSIXTime + | NoLimit + + +tryRequest :: RestIO R.LbsResponse -> Chan String -> RestIO (Either String QL.ByteString, Timeout) +tryRequest action log = do + resp <- action + next10 <- liftIO (round . (+10) <$> getPOSIXTime) + let code = R.responseStatusCode resp + 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" + 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 + else PathWait reset) + | code `elem` [500,502] -> pure (Left "Try Again", NoLimit) + | inRange (200,299) code -> pure ( Right (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)) + , if remain > 0 then NoLimit else PathWait reset ) + | otherwise -> let err = "Unexpected code: " ++ show code ++ " - " ++ Q.unpack status + in pure (Left err, NoLimit) + +readMaybeBS :: Read a => Q.ByteString -> Maybe a +readMaybeBS = readMaybe . Q.unpack + +compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse +compileRequest auth request = action + where + authopt = authHeader auth + action = case request of + (Delete url opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts) + (Get url opts) -> R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts) + (Patch url body opts) -> R.req R.PATCH url body R.lbsResponse (authopt <> opts) + (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) + diff --git a/src/Discord/Rest/Prelude.hs b/src/Discord/Rest/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/Prelude.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | Utility and base types and functions for the Discord Rest API +module Discord.Rest.Prelude where + +import Prelude hiding (log) +import Data.Default (def) +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Network.HTTP.Req as R + +import Discord.Types + +-- | Discord requires HTTP headers for authentication. +authHeader :: Auth -> R.Option 'R.Https +authHeader auth = + R.header "Authorization" (formatAuth auth) + <> R.header "User-Agent" agent + 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)" + +-- Append to an URL +infixl 5 // +(//) :: Show a => R.Url scheme -> a -> R.Url scheme +(//) url part = url R./: T.pack (show part) + + +-- | Represtents a HTTP request made to an API that supplies a Json response +data JsonRequest where + Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Patch :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Put :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Post :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + +class Request a where + majorRoute :: a -> String + jsonRequest :: a -> JsonRequest + +-- | Same Monad as IO. Overwrite Req settings +newtype RestIO a = RestIO { restIOtoIO :: IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance R.MonadHttp RestIO where + -- | Throw actual exceptions + handleHttpException = liftIO . throwIO + -- | Don't throw exceptions on http error codes like 404 + getHttpConfig = pure $ def { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/src/Discord/Rest/User.hs b/src/Discord/Rest/User.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Rest/User.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Rest.User + ( UserRequest(..) + ) where + + +import Data.Aeson +import Data.Monoid (mempty, (<>)) +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Rest.Prelude +import Discord.Types + +instance Request (UserRequest a) where + majorRoute = userMajorRoute + jsonRequest = userJsonRequest + + +-- | Data constructor for requests. See +data UserRequest a where + -- | Returns the 'User' object of the requester's account. For OAuth2, this requires + -- the identify scope, which will return the object without an email, and optionally + -- the email scope, which returns the object with an email. + 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 + -- | Returns a list of user 'Guild' objects the current user is a member of. + -- Requires the guilds OAuth2 scope. + GetCurrentUserGuilds :: UserRequest [PartialGuild] + -- | Leave a guild. + LeaveGuild :: Snowflake -> UserRequest () + -- | Returns a list of DM 'Channel' objects + GetUserDMs :: UserRequest [Channel] + -- | Create a new DM channel with a user. Returns a DM 'Channel' object. + CreateDM :: Snowflake -> UserRequest Channel + + +userMajorRoute :: UserRequest a -> String +userMajorRoute c = case c of + (GetCurrentUser) -> "me " + (GetUser _) -> "user " + -- (ModifyCurrentUser _) -> "modify_user " + (GetCurrentUserGuilds) -> "get_user_guilds " + (LeaveGuild g) -> "leave_guild " <> show g + (GetUserDMs) -> "get_dms " + (CreateDM _) -> "make_dm " + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +users :: R.Url 'R.Https +users = baseUrl /: "users" + +userJsonRequest :: UserRequest r -> JsonRequest +userJsonRequest c = case c of + (GetCurrentUser) -> Get (users /: "@me") mempty + + (GetUser user) -> Get (users // user ) mempty + + -- (ModifyCurrentUser patch) -> + -- Patch (users /: "@me") (R.ReqBodyJson patch) mempty + + (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty + + (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" // guild) mempty + + (GetUserDMs) -> Get (users /: "@me" /: "channels") mempty + + (CreateDM user) -> + let body = R.ReqBodyJson $ object ["recipient_id" .= user] + in Post (users /: "@me" /: "channels") (pure body) mempty diff --git a/src/Discord/Types.hs b/src/Discord/Types.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK prune, not-home #-} + +-- | Provides types and encoding/decoding code. Types should be identical to those provided +-- in the Discord API documentation. +module Discord.Types + ( module Discord.Types.Prelude + , module Discord.Types.Channel + , module Discord.Types.Events + , module Discord.Types.Gateway + , module Discord.Types.Guild + , module Data.Aeson + ) where + +import Discord.Types.Channel +import Discord.Types.Events +import Discord.Types.Gateway +import Discord.Types.Guild +import Discord.Types.Prelude + +import Data.Aeson (Object) diff --git a/src/Discord/Types/Channel.hs b/src/Discord/Types/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types/Channel.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord Channels +module Discord.Types.Channel where + +import qualified Data.Text as T + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Time.Clock +import Data.Monoid ((<>)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V + +import Discord.Types.Prelude + +-- | Represents information about a user. +data User = User + { userId :: Snowflake -- ^ The user's id. + , userName :: String -- ^ The user's username, not unique across + -- the platform. + , userDiscrim :: String -- ^ The user's 4-digit discord-tag. + , userAvatar :: Maybe String -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ Whether the user belongs to an OAuth2 + -- application. + , userMfa :: Maybe Bool -- ^ Whether the user has two factor + -- authentication enabled on the account. + , userVerified :: Maybe Bool -- ^ Whether the email on this account has + -- been verified. + , userEmail :: Maybe String -- ^ The user's email. + } + | Webhook deriving (Show, Eq) + +instance FromJSON User where + parseJSON = withObject "Useer" $ \o -> + User <$> o .: "id" + <*> o .: "username" + <*> o .: "discriminator" + <*> o .:? "avatar" + <*> o .:? "bot" .!= False + <*> o .:? "mfa_enabled" + <*> o .:? "verified" + <*> o .:? "email" + +-- | Guild channels represent an isolated set of users and messages in a Guild (Server) +data Channel + -- | A text channel in a guild. + = Text + { channelId :: Snowflake -- ^ The id of the channel (Will be equal to + -- the guild if it's the "general" channel). + , channelGuild :: Snowflake -- ^ The id of the guild. + , channelName :: String -- ^ The name of the guild (2 - 1000 characters). + , channelPosition :: Integer -- ^ The storing position of the channel. + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's + , channelTopic :: String -- ^ The topic of the channel. (0 - 1024 chars). + , channelLastMessage :: Maybe Snowflake -- ^ The id of the last message sent in the + -- channel + } + -- | A voice channel in a guild. + | Voice + { channelId :: Snowflake + , channelGuild :: Snowflake + , channelName :: String + , channelPosition :: Integer + , channelPermissions :: [Overwrite] + , channelBitRate :: Integer -- ^ The bitrate (in bits) of the channel. + , channelUserLimit :: Integer -- ^ The user limit of the voice channel. + } + -- | DM Channels represent a one-to-one conversation between two users, outside the scope + -- of guilds + | DirectMessage + { channelId :: Snowflake + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). + , channelLastMessage :: Maybe Snowflake + } + | GroupDM + { channelId :: Snowflake + , channelRecipients :: [User] + , channelLastMessage :: Maybe Snowflake + } + | GuildCategory + { channelId :: Snowflake + , channelGuild :: Snowflake + } deriving (Show, Eq) + +instance FromJSON Channel where + parseJSON = withObject "Channel" $ \o -> do + type' <- (o .: "type") :: Parser Int + case type' of + 0 -> + Text <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" + 1 -> + DirectMessage <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 2 -> + Voice <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .: "bitrate" + <*> o .: "user_limit" + 3 -> + GroupDM <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 4 -> + GuildCategory <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + _ -> fail ("Unknown channel type:" <> show type') + +-- | If the channel is part of a guild (has a guild id field) +isGuildChannel :: Channel -> Bool +isGuildChannel c = case c of + GuildCategory{..} -> True + Text{..} -> True + Voice{..} -> True + _ -> False + +-- | Permission overwrites for a channel. +data Overwrite = Overwrite + { overwriteId :: Snowflake -- ^ 'Role' or 'User' id + , overwriteType :: String -- ^ Either "role" or "member + , overwriteAllow :: Integer -- ^ Allowed permission bit set + , overwriteDeny :: Integer -- ^ Denied permission bit set + } deriving (Show, Eq) + +instance FromJSON Overwrite where + parseJSON = withObject "Overwrite" $ \o -> + Overwrite <$> o .: "id" + <*> o .: "type" + <*> o .: "allow" + <*> o .: "deny" + +instance ToJSON Overwrite where + toJSON Overwrite{..} = object + [ ("id", toJSON overwriteId) + , ("type", toJSON overwriteType) + , ("allow", toJSON overwriteAllow) + , ("deny", toJSON overwriteDeny) + ] + +-- | Represents information about a message in a Discord channel. +data Message = Message + { messageId :: Snowflake -- ^ The id of the message + , messageChannel :: Snowflake -- ^ Id of the channel the message + -- was sent in + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageText :: T.Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS + -- message + , messageEveryone :: Bool -- ^ Whether this message mentions + -- everyone + , messageMentions :: [User] -- ^ 'User's specifically mentioned in + -- the message + , messageMentionRoles :: [Snowflake] -- ^ 'Role's specifically mentioned in + -- the message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageNonce :: Maybe Snowflake -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + } deriving (Show, Eq) + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> + Message <$> o .: "id" + <*> o .: "channel_id" + <*> o .:? "author" .!= Webhook + <*> o .:? "content" .!= "" + <*> o .:? "timestamp" .!= epochTime + <*> o .:? "edited_timestamp" + <*> o .:? "tts" .!= False + <*> o .:? "mention_everyone" .!= False + <*> o .:? "mentions" .!= [] + <*> o .:? "mention_roles" .!= [] + <*> o .:? "attachments" .!= [] + <*> o .: "embeds" + <*> o .:? "nonce" + <*> o .:? "pinned" .!= False + +-- | Represents an attached to a message file. +data Attachment = Attachment + { attachmentId :: Snowflake -- ^ Attachment id + , attachmentFilename :: String -- ^ Name of attached file + , attachmentSize :: Integer -- ^ Size of file (in bytes) + , attachmentUrl :: String -- ^ Source of file + , attachmentProxy :: String -- ^ Proxied url of file + , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) + , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) + } deriving (Show, Eq) + +instance FromJSON Attachment where + parseJSON = withObject "Attachment" $ \o -> + Attachment <$> o .: "id" + <*> o .: "filename" + <*> o .: "size" + <*> o .: "url" + <*> o .: "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +-- | An embed attached to a message. +data Embed = Embed + { embedTitle :: String -- ^ Title of the embed + , embedType :: String -- ^ Type of embed (Always "rich" for webhooks) + , embedDesc :: String -- ^ Description of embed + , embedUrl :: String -- ^ URL of embed + , embedTime :: UTCTime -- ^ The time of the embed content + , embedColor :: Integer -- ^ The embed color + , embedFields :: [SubEmbed] -- ^ Fields of the embed + } deriving (Show, Read, Eq) + +instance FromJSON Embed where + parseJSON = withObject "Embed" $ \o -> + Embed <$> o .:? "title" .!= "Untitled" + <*> o .: "type" + <*> o .:? "description" .!= "" + <*> o .:? "url" .!= "" + <*> o .:? "timestamp" .!= epochTime + <*> o .:? "color" .!= 0 + <*> sequence (HM.foldrWithKey to_embed [] o) + where + to_embed k (Object v) a = case k of + "footer" -> (Footer <$> v .: "text" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + "image" -> (Image <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + "thumbnail" -> (Thumbnail <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + "video" -> (Video <$> v .: "url" + <*> v .: "height" + <*> v .: "width") : a + "provider" -> (Provider <$> v .: "name" + <*> v .:? "url" .!= "") : a + "author" -> (Author <$> v .: "name" + <*> v .:? "url" .!= "" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + _ -> a + to_embed k (Array v) a = case k of + "fields" -> [Field <$> i .: "name" + <*> i .: "value" + <*> i .: "inline" + | Object i <- V.toList v] ++ a + _ -> a + to_embed _ _ a = a + +instance ToJSON Embed where + toJSON (Embed {..}) = object + [ "title" .= embedTitle + , "type" .= embedType + , "description" .= embedDesc + , "url" .= embedUrl + , "timestamp" .= embedTime + , "color" .= embedColor + ] |> makeSubEmbeds embedFields + where + (|>) :: Value -> HM.HashMap T.Text Value -> Value + (|>) (Object o) hm = Object $ HM.union o hm + (|>) _ _ = error "Type mismatch" + + makeSubEmbeds :: [SubEmbed] -> HM.HashMap T.Text Value + makeSubEmbeds = foldr embed HM.empty + + embed :: SubEmbed -> HM.HashMap T.Text Value -> HM.HashMap T.Text Value + embed (Thumbnail url _ height width) = + HM.alter (\_ -> Just $ object + [ "url" .= url + , "height" .= height + , "width" .= width + ]) "thumbnail" + embed (Image url _ height width) = + HM.alter (\_ -> Just $ object + [ "url" .= url + , "height" .= height + , "width" .= width + ]) "image" + embed (Author name url icon _) = + HM.alter (\_ -> Just $ object + [ "name" .= name + , "url" .= url + , "icon_url" .= icon + ]) "author" + embed (Footer text icon _) = + HM.alter (\_ -> Just $ object + [ "text" .= text + , "icon_url" .= icon + ]) "footer" + embed (Field name value inline) = + HM.alter (\val -> case val of + Just (Array a) -> Just . Array $ V.cons (object + [ "name" .= name + , "value" .= value + , "inline" .= inline + ]) a + _ -> Just $ toJSON [ + object + [ "name" .= name + , "value" .= value + , "inline" .= inline + ] + ] + ) "fields" + embed _ = id + +-- | Represents a part of an embed. +data SubEmbed + = Thumbnail + String + String + Integer + Integer + | Video + String + Integer + Integer + | Image + String + String + Integer + Integer + | Provider + String + String + | Author + String + String + String + String + | Footer + String + String + String + | Field + String + String + Bool + deriving (Show, Read, Eq) diff --git a/src/Discord/Types/Events.hs b/src/Discord/Types/Events.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types/Events.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Data structures pertaining to gateway dispatch 'Event's +module Discord.Types.Events where + +import Prelude hiding (id) + +import Data.Time.ISO8601 (parseISO8601) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T + +import Discord.Types.Prelude (Snowflake) +import Discord.Types.Channel +import Discord.Types.Guild (Guild, Unavailable, GuildInfo, + GuildMember, Role, Emoji) + + +-- | Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway. +data Event = + Ready Int User [Channel] [Unavailable] String + | Resumed [T.Text] + | ChannelCreate Channel + | ChannelUpdate Channel + | ChannelDelete Channel + | ChannelPinsUpdate Snowflake (Maybe UTCTime) + | GuildCreate Guild GuildInfo + | GuildUpdate Guild + | GuildDelete Unavailable + | GuildBanAdd Snowflake User + | GuildBanRemove Snowflake User + | GuildEmojiUpdate Snowflake [Emoji] + | GuildIntegrationsUpdate Snowflake + | GuildMemberAdd Snowflake GuildMember + | GuildMemberRemove Snowflake User + | GuildMemberUpdate Snowflake [Snowflake] User String + | GuildMemberChunk Snowflake [GuildMember] + | GuildRoleCreate Snowflake Role + | GuildRoleUpdate Snowflake Role + | GuildRoleDelete Snowflake Snowflake + | MessageCreate Message + | MessageUpdate Message + | MessageDelete Snowflake Snowflake + | MessageDeleteBulk Snowflake [Snowflake] + | MessageReactionAdd ReactionInfo + | MessageReactionRemove ReactionInfo + | MessageReactionRemoveAll Snowflake Snowflake + | PresenceUpdate PresenceInfo + | TypingStart TypingInfo + | UserUpdate User + -- | VoiceStateUpdate + -- | VoiceServerUpdate + | UnknownEvent String Object + deriving Show + +data ReactionInfo = ReactionInfo + { reactionUserId :: Snowflake + , reactionChannelId :: Snowflake + , reactionMessageId :: Snowflake + , reactionEmoji :: Emoji + } deriving Show + +instance FromJSON ReactionInfo where + parseJSON = withObject "ReactionInfo" $ \o -> + ReactionInfo <$> o .: "user_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +data PresenceInfo = PresenceInfo + { presenceUserId :: Snowflake + , presenceRoles :: [Snowflake] + -- , presenceGame :: Maybe Activity + , presenceGuildId :: Snowflake + , presenceStatus :: String + } deriving Show + +instance FromJSON PresenceInfo where + parseJSON = withObject "PresenceInfo" $ \o -> + PresenceInfo <$> (o .: "user" >>= (.: "id")) + <*> o .: "roles" + -- <*> o .: "game" + <*> o .: "guild_id" + <*> o .: "status" + +data TypingInfo = TypingInfo + { typingUserId :: Snowflake + , typingChannelId :: Snowflake + , typingTimestamp :: UTCTime + } deriving Show + +instance FromJSON TypingInfo where + parseJSON = withObject "TypingInfo" $ \o -> + do cid <- o .: "channel_id" + uid <- o .: "user_id" + posix <- o .: "timestamp" + let utc = posixSecondsToUTCTime posix + pure (TypingInfo uid cid utc) + + + +-- | Convert ToJSON value to FromJSON value +reparse :: (ToJSON a, FromJSON b) => a -> Parser b +reparse val = case parseEither parseJSON $ toJSON val of + Left r -> fail r + Right b -> pure b + +eventParse :: T.Text -> Object -> Parser Event +eventParse t o = case t of + "READY" -> Ready <$> o .: "v" + <*> o .: "user" + <*> o .: "private_channels" + <*> o .: "guilds" + <*> o .: "session_id" + "RESUMED" -> Resumed <$> o .: "_trace" + "CHANNEL_CREATE" -> ChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> ChannelDelete <$> reparse o + "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" + stamp <- o .:? "last_pin_timestamp" + let utc = stamp >>= parseISO8601 + pure (ChannelPinsUpdate id utc) + "GUILD_CREATE" -> GuildCreate <$> reparse o <*> reparse o + "GUILD_UPDATE" -> GuildUpdate <$> reparse o + "GUILD_DELETE" -> GuildDelete <$> reparse o + "GUILD_BAN_ADD" -> GuildBanAdd <$> o .: "guild_id" <*> reparse o + "GUILD_BAN_REMOVE" -> GuildBanRemove <$> o .: "guild_id" <*> reparse o + "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" + "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> o .: "guild_id" + "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> o .: "guild_id" <*> reparse o + "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> o .: "guild_id" + <*> o .: "roles" + <*> o .: "user" + <*> o .: "nick" + "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> o .: "guild_id" <*> o .: "members" + "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> o .: "guild_id" <*> o .: "role" + "MESSAGE_CREATE" -> MessageCreate <$> reparse o + "MESSAGE_UPDATE" -> MessageUpdate <$> reparse o + "MESSAGE_DELETE" -> MessageDelete <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" + "MESSAGE_REACTION_ADD" -> MessageReactionAdd <$> reparse o + "MESSAGE_REACTION_REMOVE" -> MessageReactionRemove <$> reparse o + "MESSAGE_REACTION_REMOVE_ALL" -> MessageReactionRemoveAll <$> o .: "channel_id" + <*> o .: "message_id" + "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o + "TYPING_START" -> TypingStart <$> reparse o + "USER_UPDATE" -> UserUpdate <$> reparse o + -- "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o + -- "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o + _other_event -> UnknownEvent (T.unpack t) <$> reparse o diff --git a/src/Discord/Types/Gateway.hs b/src/Discord/Types/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types/Gateway.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +-- | Data structures needed for interfacing with the Websocket +-- Gateway +module Discord.Types.Gateway where + +import System.Info + +import qualified Data.Text as T +import Data.Monoid ((<>)) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Aeson +import Data.Aeson.Types +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) + +import Discord.Types.Prelude +import Discord.Types.Events + +-- | Represents data sent and received with Discord servers +data GatewayReceivable + = Dispatch Event Integer + | HeartbeatRequest Integer + | Reconnect + | InvalidSession Bool + | Hello Int + | HeartbeatAck + | ParseError String + deriving Show + +data GatewaySendable + = Heartbeat Integer + | Identify Auth Bool Integer (Int, Int) + | Resume T.Text String Integer + | RequestGuildMembers RequestGuildMembersOpts + | UpdateStatus UpdateStatusOpts + | UpdateStatusVoice UpdateStatusVoiceOpts + +data RequestGuildMembersOpts = RequestGuildMembersOpts + { requestGuildMemersGuildId :: Snowflake + , requestGuildMemersSearchQuery :: T.Text + , requestGuildMemersLimit :: Integer } + +data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts + { updateStatusVoiceGuildId :: Snowflake + , updateStatusVoiceChannelId :: Maybe Snowflake + , updateStatusVoiceIsMuted :: Snowflake + , updateStatusVoiceIsDeaf :: Snowflake + } + +data UpdateStatusOpts = UpdateStatusOpts + { updateStatusSince :: Maybe UTCTime + -- todo , updateStatusGame :: Activity + , updateStatusNewStatus :: UpdateStatusTypes + , updateStatusAFK :: Bool + } + +data UpdateStatusTypes = UpdateStatusOnline + | UpdateStatusDoNotDisturb + | UpdateStatusAwayFromKeyboard + | UpdateStatusInvisibleOffline + | UpdateStatusOffline + +statusString :: UpdateStatusTypes -> T.Text +statusString s = case s of + UpdateStatusOnline -> "online" + UpdateStatusDoNotDisturb -> "dnd" + UpdateStatusAwayFromKeyboard -> "idle" + UpdateStatusInvisibleOffline -> "invisible" + UpdateStatusOffline -> "offline" + +instance FromJSON GatewayReceivable where + parseJSON = withObject "payload" $ \o -> do + op <- o .: "op" :: Parser Int + case op of + 0 -> do etype <- o .: "t" + ejson <- o .: "d" + case ejson of + Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" + _other -> Dispatch (UnknownEvent ("Dispatch payload wasn't an object") o) + <$> o .: "s" + 1 -> HeartbeatRequest . fromMaybe 0 . readMaybe <$> o .: "d" + 7 -> pure Reconnect + 9 -> InvalidSession <$> o .: "d" + 10 -> do od <- o .: "d" + int <- od .: "heartbeat_interval" + pure (Hello int) + 11 -> pure HeartbeatAck + _ -> fail ("Unknown Receivable payload ID:" <> show op) + +-- instance FromJSON GatewaySendable where +-- parseJSON = withObject "payload" $ \o -> do +-- op <- o .: "op" :: Parser Int +-- case op of +-- 1 -> Heartbeat . fromMaybe 0 . readMaybe <$> o .: "d" +-- 2 -> do od <- o .: "d" +-- tok <- od .: "token" +-- compress <- od .:? "compress" .!= False +-- +-- _ -> fail ("Unknown Sendable payload ID:" <> show op) + +instance ToJSON GatewaySendable where + toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] + toJSON (Identify token compress large shard) = object [ + "op" .= (2 :: Int) + , "d" .= object [ + "token" .= authToken token + , "properties" .= object [ + "$os" .= os + , "$browser" .= ("discord-haskell" :: String) + , "$device" .= ("discord-haskell" :: String) + , "$referrer" .= ("" :: String) + , "$referring_domain" .= ("" :: String) + ] + , "compress" .= compress + , "large_threshold" .= large + , "shard" .= shard + ] + ] + toJSON (UpdateStatus (UpdateStatusOpts since status afk)) = object [ + "op" .= (3 :: Int) + , "d" .= object [ + "since" .= case since of Nothing -> Nothing + Just s -> Just ((10^6) * (utcTimeToPOSIXSeconds s)) + , "afk" .= afk + , "status" .= statusString status + , "game" .= (Nothing :: Maybe ()) + -- todo , "game" .= object [ + -- "name" .= game + -- ] + ] + ] + toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) = + object [ + "op" .= (4 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "channel_id" .= channel + , "self_mute" .= mute + , "self_deaf" .= deaf + ] + ] + toJSON (Resume token session seqId) = object [ + "op" .= (6 :: Int) + , "d" .= object [ + "token" .= token + , "session_id" .= session + , "seq" .= seqId + ] + ] + toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = + object [ + "op" .= (8 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "query" .= query + , "limit" .= limit + ] + ] diff --git a/src/Discord/Types/Guild.hs b/src/Discord/Types/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types/Guild.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Types relating to Discord Guilds (servers) +module Discord.Types.Guild where + +import Data.Time.Clock + +import Data.Aeson +import qualified Data.Text as T + +import Discord.Types.Channel +import Discord.Types.Prelude + +-- | Representation of a guild member. +data GuildMember = GuildMember + { memberUser :: User + , memberNick :: Maybe T.Text + , memberRoles :: [Snowflake] + , memberJoinedAt :: UTCTime + , memberDeaf :: Bool + , memberMute :: Bool + } deriving Show + +instance FromJSON GuildMember where + parseJSON = withObject "GuildMember" $ \o -> + GuildMember <$> o .: "user" + <*> o .:? "nick" + <*> o .: "roles" + <*> o .: "joined_at" + <*> o .: "deaf" + <*> o .: "mute" + + +-- https://discordapp.com/developers/docs/resources/guild#guild-object + +-- | Guilds in Discord represent a collection of users and channels into an isolated +-- "Server" +data Guild = Guild + { guildId :: !Snowflake -- ^ Gulid id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildOwnerId :: !Snowflake -- ^ Guild owner id + , guildPermissions :: Maybe Integer + , guildRegion :: T.Text -- ^ Guild voice region + , guildAfkId :: Maybe Snowflake -- ^ Id of afk channel + , guildAfkTimeout :: !Integer -- ^ Afk timeout in seconds + , guildEmbedEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildEmbedChannel :: Maybe Snowflake -- ^ Id of embedded channel + , guildVerificationLevel :: !Integer -- ^ Level of verification + , guildNotification :: !Integer -- ^ Level of default notifications + , guildExplicitFilterLevel :: !Integer + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] + , guildMultiFactAuth :: !Integer + , guildApplicationId :: Maybe Snowflake + } deriving Show + +instance FromJSON Guild where + parseJSON = withObject "Guild" $ \o -> + Guild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "splash" + <*> o .: "owner_id" + <*> o .:? "permissions" + <*> o .: "region" + <*> o .:? "afk_channel_id" + <*> o .: "afk_timeout" + <*> o .:? "embed_enabled" + <*> o .:? "embed_channel_id" + <*> o .: "verification_level" + <*> o .: "default_message_notifications" + <*> o .: "explicit_content_filter" + <*> o .: "roles" + <*> o .: "emojis" + <*> o .: "features" + <*> o .: "mfa_level" + <*> o .:? "application_id" + +data Unavailable = Unavailable + { idOnceAvailable :: !Snowflake + } deriving Show + +instance FromJSON Unavailable where + parseJSON = withObject "Unavailable" $ \o -> + Unavailable <$> o .: "id" + +data GuildInfo = GuildInfo + { guildJoinedAt :: UTCTime + , guildLarge :: Bool + , guildMemberCount :: Integer + -- , guildVoiceStates :: [VoiceState] -- (without guildid) todo have to add voice state data type + , guildMembers :: [GuildMember] + , guildChannels :: [Channel] -- ^ Channels in the guild (sent in GuildCreate) + -- , guildPresences :: [Presence] + } deriving Show + +instance FromJSON GuildInfo where + parseJSON = withObject "GuildInfo" $ \o -> + GuildInfo <$> o .: "joined_at" + <*> o .: "large" + <*> o .: "member_count" + -- <*> o .: "voice_states" + <*> o .: "members" + <*> o .: "channels" + +data PartialGuild = PartialGuild + { partialGuildId :: Snowflake + , partialGuildName :: T.Text + , partialGuildIcon :: Maybe T.Text + , partialGuildOwner :: Bool + , partialGuildPermissions :: Integer + } deriving Show + +instance FromJSON PartialGuild where + parseJSON = withObject "PartialGuild" $ \o -> + PartialGuild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .: "owner" + <*> o .: "permissions" + +-- | Represents an emoticon (emoji) +data Emoji = Emoji + { emojiId :: Maybe Snowflake -- ^ The emoji id + , emojiName :: T.Text -- ^ The emoji name + , emojiRoles :: Maybe [Snowflake] -- ^ Roles the emoji is active for + , emojiManaged :: Maybe Bool -- ^ Whether this emoji is managed + } deriving (Show) + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .: "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "managed" + +-- | Roles represent a set of permissions attached to a group of users. Roles have unique +-- names, colors, and can be "pinned" to the side bar, causing their members to be listed separately. +-- Roles are unique per guild, and can have separate permission profiles for the global context +-- (guild) and channel context. +data Role = + Role { + roleID :: !Snowflake -- ^ The role id + , roleName :: T.Text -- ^ The role name + , roleColor :: Integer -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: Integer -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } deriving (Show, Eq) + +instance FromJSON Role where + parseJSON = withObject "Role" $ \o -> + Role <$> o .: "id" + <*> o .: "name" + <*> o .: "color" + <*> o .: "hoist" + <*> o .: "position" + <*> o .: "permissions" + <*> o .: "managed" + <*> o .: "mentionable" + +-- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added +data VoiceRegion = + VoiceRegion + { regionId :: !Snowflake -- ^ Unique id of the region + , regionName :: T.Text -- ^ Name of the region + , regionHostname :: T.Text -- ^ Example hostname for the region + , regionPort :: Int -- ^ Example port for the region + , regionVip :: Bool -- ^ True if this is a VIP only server + , regionOptimal :: Bool -- ^ True for the closest server to a client + , regionDepreciated :: Bool -- ^ Whether this is a deprecated region + , regionCustom :: Bool -- ^ Whether this is a custom region + } deriving (Show) + +instance FromJSON VoiceRegion where + parseJSON = withObject "VoiceRegion" $ \o -> + VoiceRegion <$> o .: "id" + <*> o .: "name" + <*> o .: "sample_hostname" + <*> o .: "sample_port" + <*> o .: "vip" + <*> o .: "optimal" + <*> o .: "deprecated" + <*> o .: "custom" + +-- | Represents a code to add a user to a guild +data Invite = Invite + { inviteCode :: T.Text -- ^ The invite code + , inviteGuild :: !Snowflake -- ^ The guild the code will invite to + , inviteChan :: !Snowflake -- ^ The channel the code will invite to + } + +instance FromJSON Invite where + parseJSON = withObject "Invite" $ \o -> + Invite <$> o .: "code" + <*> ((o .: "guild") >>= (.: "id")) + <*> ((o .: "channel") >>= (.: "id")) + +-- | Invite code with additional metadata +data InviteWithMeta = InviteWithMeta Invite InviteMeta + +instance FromJSON InviteWithMeta where + parseJSON ob = InviteWithMeta <$> parseJSON ob <*> parseJSON ob + +-- | Additional metadata about an invite. +data InviteMeta = + InviteMeta { + inviteCreator :: User -- ^ The user that created the invite + , inviteUses :: Integer -- ^ Number of times the invite has been used + , inviteMax :: Integer -- ^ Max number of times the invite can be used + , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires + , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership + , inviteCreated :: UTCTime -- ^ When the invite was created + , inviteRevoked :: Bool -- ^ If the invite is revoked + } + +instance FromJSON InviteMeta where + parseJSON = withObject "InviteMeta" $ \o -> + InviteMeta <$> o .: "inviter" + <*> o .: "uses" + <*> o .: "max_uses" + <*> o .: "max_age" + <*> o .: "temporary" + <*> o .: "created_at" + <*> o .: "revoked" + +-- | Represents the behavior of a third party account link. +data Integration = + Integration + { integrationId :: !Snowflake -- ^ Integration id + , integrationName :: T.Text -- ^ Integration name + , integrationType :: T.Text -- ^ Integration type (Twitch, Youtube, ect.) + , integrationEnabled :: Bool -- ^ Is the integration enabled + , integrationSyncing :: Bool -- ^ Is the integration syncing + , integrationRole :: Snowflake -- ^ Id the integration uses for "subscribers" + , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers + , integrationGrace :: Integer -- ^ The grace period before expiring subscribers + , integrationOwner :: User -- ^ The user of the integration + , integrationAccount :: IntegrationAccount -- ^ The account the integration links to + , integrationSync :: UTCTime -- ^ When the integration was last synced + } deriving (Show) + +instance FromJSON Integration where + parseJSON = withObject "Integration" $ \o -> + Integration <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "enabled" + <*> o .: "syncing" + <*> o .: "role_id" + <*> o .: "expire_behavior" + <*> o .: "expire_grace_period" + <*> o .: "user" + <*> o .: "account" + <*> o .: "synced_at" + +-- | Represents a third party account link. +data IntegrationAccount = + Account + { accountId :: T.Text -- ^ The id of the account. + , accountName :: T.Text -- ^ The name of the account. + } deriving (Show) + +instance FromJSON IntegrationAccount where + parseJSON = withObject "Account" $ \o -> + Account <$> o .: "id" <*> o .: "name" + +-- | Represents an image to be used in third party sites to link to a discord channel +data GuildEmbed = + GuildEmbed + { embedEnabled :: !Bool -- ^ Whether the embed is enabled + , embedChannel :: !Snowflake -- ^ The embed channel id + } + +instance FromJSON GuildEmbed where + parseJSON = withObject "GuildEmbed" $ \o -> GuildEmbed <$> o .: "enabled" + <*> o .: "snowflake" + +instance ToJSON GuildEmbed where + toJSON (GuildEmbed enabled snowflake) = object + [ "enabled" .= enabled + , "snowflake" .= snowflake + ] diff --git a/src/Discord/Types/Prelude.hs b/src/Discord/Types/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Types/Prelude.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides base types and utility functions needed for modules in Discord.Types +module Discord.Types.Prelude where + +import Data.Bits +import Data.Word + +import Data.Aeson.Types +import Data.Time.Clock +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Char8 as Q +import Data.Time.Clock.POSIX +import Data.Monoid ((<>)) +import Control.Monad (mzero) + +-- | Authorization token for the Discord API +data Auth = Auth T.Text + deriving (Show, Eq, Ord) + + +-- | Formats the token for use with the REST API +formatAuth :: Auth -> Q.ByteString +formatAuth (Auth token) = "Bot " <> TE.encodeUtf8 token + +-- | Get the raw token formatted for use with the websocket gateway +authToken :: Auth -> T.Text +authToken (Auth token) = token + +-- | A unique integer identifier. Can be used to calculate the creation date of an entity. +newtype Snowflake = Snowflake Word64 + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show Snowflake where + show (Snowflake a) = show a + +instance ToJSON Snowflake where + toJSON (Snowflake snowflake) = String . T.pack $ show snowflake + +instance FromJSON Snowflake where + parseJSON (String snowflake) = Snowflake <$> (return . read $ T.unpack snowflake) + parseJSON _ = mzero + +-- | Gets a creation date from a snowflake. +creationDate :: Snowflake -> UTCTime +creationDate x = posixSecondsToUTCTime . realToFrac + $ 1420070400 + quot (shiftR x 22) 1000 + +-- | Default timestamp +epochTime :: UTCTime +epochTime = posixSecondsToUTCTime 0 +