discord-hs 0.3.2 → 0.4.2
raw patch · 17 files changed
+429/−1981 lines, 17 filesdep +discord-gatewaydep +discord-restdep +discord-typesdep −aesondep −bytestringdep −case-insensitivedep ~hashabledep ~mtldep ~url
Dependencies added: discord-gateway, discord-rest, discord-types
Dependencies removed: aeson, bytestring, case-insensitive, comonad, containers, data-default, hakyll, hslogger, http-client, mmorph, pipes, req, split, stm, stm-conduit, text, time, transformers, unordered-containers, vector, wuss
Dependency ranges changed: hashable, mtl, url, websockets
Files
- discord-hs.cabal +8/−54
- docs/Site.hs +0/−33
- src/Network/Discord.hs +302/−12
- src/Network/Discord/Framework.hs +119/−158
- src/Network/Discord/Gateway.hs +0/−97
- src/Network/Discord/Rest.hs +0/−64
- src/Network/Discord/Rest/Channel.hs +0/−140
- src/Network/Discord/Rest/Guild.hs +0/−229
- src/Network/Discord/Rest/HTTP.hs +0/−76
- src/Network/Discord/Rest/Prelude.hs +0/−97
- src/Network/Discord/Rest/User.hs +0/−76
- src/Network/Discord/Types.hs +0/−94
- src/Network/Discord/Types/Channel.hs +0/−328
- src/Network/Discord/Types/Events.hs +0/−93
- src/Network/Discord/Types/Gateway.hs +0/−120
- src/Network/Discord/Types/Guild.hs +0/−238
- src/Network/Discord/Types/Prelude.hs +0/−72
discord-hs.cabal view
@@ -1,5 +1,5 @@ name: discord-hs-version: 0.3.2+version: 0.4.2 synopsis: An API wrapper for Discord in Haskell description: Provides an api wrapper and framework for writing bots against the Discord <https://discordapp.com/> API.@@ -16,67 +16,21 @@ -- extra-source-files: cabal-version: >=1.10 -Flag disable-docs- Description: Disable documentation generation- Manual: True- Default: False- library exposed-modules: Network.Discord- , Network.Discord.Rest- , Network.Discord.Rest.Channel- , Network.Discord.Rest.Guild- , Network.Discord.Rest.User , Network.Discord.Framework- , Network.Discord.Gateway- , Network.Discord.Types- , Network.Discord.Types.Channel- , Network.Discord.Types.Guild- , Network.Discord.Types.Events- , Network.Discord.Types.Gateway other-modules: Paths_discord_hs- , Network.Discord.Rest.Prelude- , Network.Discord.Types.Prelude- , Network.Discord.Rest.HTTP -- other-extensions: build-depends: base==4.*- , aeson>=1.0 && <1.2- , bytestring==0.10.*- , case-insensitive==1.2.*- , comonad==5.*- , containers==0.5.*- , data-default==0.7.*- , hashable==1.2.*- , hslogger==1.2.*- , http-client==0.5.*- , mmorph==1.0.*- , mtl==2.2.*- , pipes==4.3.*- , stm-conduit==3.0.*- , stm==2.4.*- , text==1.2.*- , time>=1.6 && <1.9 - , transformers==0.5.*- , unordered-containers==0.2.*- , url==2.1.*- , vector>=0.10 && <0.13- , websockets==0.10.*- , req==0.2.*- , wuss==1.1.*+ , discord-types+ , discord-rest+ , discord-gateway+ , hashable+ , mtl+ , url+ , websockets ghc-options: -Wall hs-source-dirs: src- default-language: Haskell2010--executable docs- main-is: Site.hs- hs-source-dirs: docs- If !flag(disable-docs)- build-depends: base==4.*- , hakyll- , split- Else- Buildable: False- ghc-options: -Wall default-language: Haskell2010 source-repository head
− docs/Site.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Hakyll-import Data.List-import Data.List.Split--config :: Configuration-config = defaultConfiguration { providerDirectory = "docs/build" }--hackage :: String -> String-hackage xs = fixUrl $ splitWhen (=='/') xs- where- fixUrl ("..":package:ys) = "https://hackage.haskell.org/package/" ++ package ++ "/docs/" ++ intercalate "/" ys- fixUrl zs = intercalate "/" zs--main :: IO ()-main = do- hakyllWith config $ do- match "Network-*.html" $ do- route idRoute- compile $ fmap (withUrls hackage) <$> (relativizeUrls =<< getResourceString)-- match "index.html" $ do- route idRoute- compile $ relativizeUrls =<< getResourceString-- match "*.css" $ do- route idRoute- compile $ relativizeUrls =<< getResourceString-- match "*.js" $ do- route idRoute- compile $ relativizeUrls =<< getResourceString
src/Network/Discord.hs view
@@ -1,17 +1,307 @@ -- | Provides core Discord functionallity. +{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, RankNTypes, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, GADTs, TypeFamilies, FlexibleContexts #-} module Network.Discord- ( module Network.Discord.Framework+ ( module Network.Discord+ , module Network.Discord.Framework+ , module Network.Discord.Gateway , module Network.Discord.Rest , module Network.Discord.Types- , module Network.Discord.Gateway- , module Control.Monad.State- , module Pipes- , module Pipes.Core ) where- import Network.Discord.Framework- import Network.Discord.Rest- import Network.Discord.Types- import Network.Discord.Gateway- import Pipes ((~>), (>->), yield, await)- import Pipes.Core ((+>>))- import Control.Monad.State (get, put, liftIO, void, when, unless)+ import Network.Discord.Framework+ import Network.Discord.Rest+ import Network.Discord.Types+ import Network.Discord.Gateway++ import Control.Monad (mzero)+ import Control.Applicative ((<|>))+ import Data.Proxy+ import GHC.TypeLits hiding ((:<>:))++ class (DiscordAuth m, Event ~ Domain f, () ~ Codomain f, EventMap f (DiscordApp m))+ => EventHandler f m++ runBot :: (DiscordAuth m, EventHandler f m) => Proxy (m f) -> IO ()+ runBot p = runGateway gatewayUrl $ (DiscordApp (\_ e -> return e) >>= go p) <|> return ()+ where+ split :: Proxy (a b) -> (Proxy a, Proxy b)+ split _ = (Proxy, Proxy)+ go :: EventHandler f m => Proxy (m f) -> Event -> DiscordApp m ()+ go p' = let (_, b) = split p' in mapEvent b++ data ReadyEvent+ + instance (DiscordGate m, DiscordRest m) => EventMap ReadyEvent m where+ type Domain ReadyEvent = Event+ type Codomain ReadyEvent = Init++ mapEvent _ (Ready e) = return e+ mapEvent _ _ = mzero++ data ResumedEvent++ instance (DiscordGate m, DiscordRest m) => EventMap ResumedEvent m where+ type Domain ResumedEvent = Event+ type Codomain ResumedEvent = Object++ mapEvent _ (Resumed e) = return e+ mapEvent _ _ = mzero++ data ChannelCreateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap ChannelCreateEvent m where+ type Domain ChannelCreateEvent = Event+ type Codomain ChannelCreateEvent = Channel++ mapEvent _ (ChannelCreate e) = return e+ mapEvent _ _ = mzero+ + data ChannelUpdateEvent+ + instance (DiscordGate m, DiscordRest m) => EventMap ChannelUpdateEvent m where+ type Domain ChannelUpdateEvent = Event+ type Codomain ChannelUpdateEvent = Channel++ mapEvent _ (ChannelUpdate e) = return e+ mapEvent _ _ = mzero++ data ChannelDeleteEvent++ instance (DiscordGate m, DiscordRest m) => EventMap ChannelDeleteEvent m where+ type Domain ChannelDeleteEvent = Event+ type Codomain ChannelDeleteEvent = Channel++ mapEvent _ (ChannelDelete e) = return e+ mapEvent _ _ = mzero++ data GuildCreateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildCreateEvent m where+ type Domain GuildCreateEvent = Event+ type Codomain GuildCreateEvent = Guild++ mapEvent _ (GuildCreate e) = return e+ mapEvent _ _ = mzero++ data GuildUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildUpdateEvent m where+ type Domain GuildUpdateEvent = Event+ type Codomain GuildUpdateEvent = Guild++ mapEvent _ (GuildUpdate e) = return e+ mapEvent _ _ = mzero++ data GuildDeleteEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildDeleteEvent m where+ type Domain GuildDeleteEvent = Event+ type Codomain GuildDeleteEvent = Guild++ mapEvent _ (GuildDelete e) = return e+ mapEvent _ _ = mzero++ data GuildBanAddEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildBanAddEvent m where+ type Domain GuildBanAddEvent = Event+ type Codomain GuildBanAddEvent = Member++ mapEvent _ (GuildBanAdd e) = return e+ mapEvent _ _ = mzero++ data GuildBanRemoveEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildBanRemoveEvent m where+ type Domain GuildBanRemoveEvent = Event+ type Codomain GuildBanRemoveEvent = Member++ mapEvent _ (GuildBanRemove e) = return e+ mapEvent _ _ = mzero++ data GuildEmojiUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildEmojiUpdateEvent m where+ type Domain GuildEmojiUpdateEvent = Event+ type Codomain GuildEmojiUpdateEvent = Object++ mapEvent _ (GuildEmojiUpdate e) = return e+ mapEvent _ _ = mzero++ data GuildIntegrationsUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildIntegrationsUpdateEvent m where+ type Domain GuildIntegrationsUpdateEvent = Event+ type Codomain GuildIntegrationsUpdateEvent = Object++ mapEvent _ (GuildIntegrationsUpdate e) = return e+ mapEvent _ _ = mzero++ data GuildMemberAddEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildMemberAddEvent m where+ type Domain GuildMemberAddEvent = Event+ type Codomain GuildMemberAddEvent = Member++ mapEvent _ (GuildMemberAdd e) = return e+ mapEvent _ _ = mzero++ data GuildMemberRemoveEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildMemberRemoveEvent m where+ type Domain GuildMemberRemoveEvent = Event+ type Codomain GuildMemberRemoveEvent = Member++ mapEvent _ (GuildMemberRemove e) = return e+ mapEvent _ _ = mzero++ data GuildMemberUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildMemberUpdateEvent m where+ type Domain GuildMemberUpdateEvent = Event+ type Codomain GuildMemberUpdateEvent = Member++ mapEvent _ (GuildMemberUpdate e) = return e+ mapEvent _ _ = mzero++ data GuildMemberChunkEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildMemberChunkEvent m where+ type Domain GuildMemberChunkEvent = Event+ type Codomain GuildMemberChunkEvent = Object++ mapEvent _ (GuildMemberChunk e) = return e+ mapEvent _ _ = mzero++ data GuildRoleCreateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildRoleCreateEvent m where+ type Domain GuildRoleCreateEvent = Event+ type Codomain GuildRoleCreateEvent = Object++ mapEvent _ (GuildRoleCreate e) = return e+ mapEvent _ _ = mzero++ data GuildRoleUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildRoleUpdateEvent m where+ type Domain GuildRoleUpdateEvent = Event+ type Codomain GuildRoleUpdateEvent = Object++ mapEvent _ (GuildRoleUpdate e) = return e+ mapEvent _ _ = mzero++ data GuildRoleDeleteEvent++ instance (DiscordGate m, DiscordRest m) => EventMap GuildRoleDeleteEvent m where+ type Domain GuildRoleDeleteEvent = Event+ type Codomain GuildRoleDeleteEvent = Object++ mapEvent _ (GuildRoleDelete e) = return e+ mapEvent _ _ = mzero++ data MessageCreateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap MessageCreateEvent m where+ type Domain MessageCreateEvent = Event+ type Codomain MessageCreateEvent = Message++ mapEvent _ (MessageCreate e) = return e+ mapEvent _ _ = mzero+ + data MessageUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap MessageUpdateEvent m where+ type Domain MessageUpdateEvent = Event+ type Codomain MessageUpdateEvent = Message++ mapEvent _ (MessageUpdate e) = return e+ mapEvent _ _ = mzero++ data MessageDeleteEvent++ instance (DiscordGate m, DiscordRest m) => EventMap MessageDeleteEvent m where+ type Domain MessageDeleteEvent = Event+ type Codomain MessageDeleteEvent = Object++ mapEvent _ (MessageDelete e) = return e+ mapEvent _ _ = mzero++ data MessageDeleteBulkEvent++ instance (DiscordGate m, DiscordRest m) => EventMap MessageDeleteBulkEvent m where+ type Domain MessageDeleteBulkEvent = Event+ type Codomain MessageDeleteBulkEvent = Object++ mapEvent _ (MessageDeleteBulk e) = return e+ mapEvent _ _ = mzero++ data PresenceUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap PresenceUpdateEvent m where+ type Domain PresenceUpdateEvent = Event+ type Codomain PresenceUpdateEvent = Object++ mapEvent _ (PresenceUpdate e) = return e+ mapEvent _ _ = mzero++ data TypingStartEvent++ instance (DiscordGate m, DiscordRest m) => EventMap TypingStartEvent m where+ type Domain TypingStartEvent = Event+ type Codomain TypingStartEvent = Object++ mapEvent _ (TypingStart e) = return e+ mapEvent _ _ = mzero++ data UserSettingsUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap UserSettingsUpdateEvent m where+ type Domain UserSettingsUpdateEvent = Event+ type Codomain UserSettingsUpdateEvent = Object++ mapEvent _ (UserSettingsUpdate e) = return e+ mapEvent _ _ = mzero++ data UserUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap UserUpdateEvent m where+ type Domain UserUpdateEvent = Event+ type Codomain UserUpdateEvent = Object++ mapEvent _ (UserUpdate e) = return e+ mapEvent _ _ = mzero++ data VoiceStateUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap VoiceStateUpdateEvent m where+ type Domain VoiceStateUpdateEvent = Event+ type Codomain VoiceStateUpdateEvent = Object++ mapEvent _ (VoiceStateUpdate e) = return e+ mapEvent _ _ = mzero++ data VoiceServerUpdateEvent++ instance (DiscordGate m, DiscordRest m) => EventMap VoiceServerUpdateEvent m where+ type Domain VoiceServerUpdateEvent = Event+ type Codomain VoiceServerUpdateEvent = Object++ mapEvent _ (VoiceServerUpdate e) = return e+ mapEvent _ _ = mzero++ data OtherEvent (a :: Symbol)++ instance (DiscordGate m, DiscordRest m, KnownSymbol e) => EventMap (OtherEvent e) m where+ type Domain (OtherEvent e) = Event+ type Codomain (OtherEvent e) = Object++ mapEvent p (UnknownEvent s e)+ | s == event p = return e+ | otherwise = mzero+ where+ event :: KnownSymbol a => Proxy (OtherEvent a) -> String+ event op = symbolVal $ eventName op+ eventName :: Proxy (OtherEvent a) -> Proxy a+ eventName _ = Proxy+ mapEvent _ _ = mzero
src/Network/Discord/Framework.hs view
@@ -1,173 +1,134 @@ -- | Provides a convenience framework for writing Discord bots without dealing with Pipes+{-# LANGUAGE TypeOperators, RankNTypes, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module Network.Discord.Framework where- import Control.Concurrent- import Control.Monad.Writer import Data.Proxy+ import Control.Applicative+ import Control.Concurrent+ import System.IO.Unsafe (unsafePerformIO) - import Control.Concurrent.STM- import Control.Monad.State (get)- import Data.Aeson (Object)- import Pipes ((~>))- import Pipes.Core hiding (Proxy)- import System.Log.Logger+ import Network.Discord.Rest+ import Network.Discord.Gateway+ import Network.Discord.Types - import Network.Discord.Gateway as D- import Network.Discord.Rest as D- import Network.Discord.Types as D+ import Control.Monad.Reader+ import Data.Hashable+ import Network.WebSockets (Connection) - -- | Isolated state representation for use with async event handling- asyncState :: D.Client a => a -> Effect DiscordM DiscordState- asyncState client = do- DiscordState { getRateLimits = limits } <- get- return $ DiscordState- Running- client- undefined- undefined- limits+ + newtype DiscordApp m a = DiscordApp + { runEvent :: DiscordAuth m => Connection -> Event -> m a } - -- | Basic client implementation. Most likely suitable for most bots.- data BotClient = BotClient Auth- instance D.Client BotClient where- getAuth (BotClient auth) = auth+ instance Alternative (DiscordApp m) where+ empty = DiscordApp $ \_ _ -> empty+ DiscordApp f <|> DiscordApp g = DiscordApp (\c e -> f c e <|> g c e) - -- | This should be the entrypoint for most Discord bots.- runBot :: Auth -> DiscordBot BotClient () -> IO ()- runBot auth bot = runBotWith (BotClient auth) bot+ instance Applicative (DiscordApp m) where+ pure a = DiscordApp (\_ _ -> return a)+ DiscordApp f <*> DiscordApp a =+ DiscordApp (\c e -> f c e <*> a c e) - -- | A variant of 'runBot' which allows the user to specify a custom client implementation.- runBotWith :: D.Client a => a -> DiscordBot a () -> IO ()- runBotWith client bot = do- gateway <- getGateway- atomically $ writeTVar getTMClient client- runWebsocket gateway client $ do- DiscordState {getWebSocket=ws} <- get- (eventCore ~> (handle $ execWriter bot)) ws+ instance DiscordAuth (DiscordApp m) where+ auth = DiscordApp $ \_ _ -> auth+ version = DiscordApp $ \_ _ -> version+ runIO = fail "DiscordApp cannot be lifted to IO" - -- | Utility function to split event handlers into a seperate thread- runAsync :: D.Client client => Proxy client -> Effect DiscordM () -> Effect DiscordM ()- runAsync c effect = do- client <- liftIO . atomically $ getSTMClient c- st <- asyncState client- liftIO . void $ forkFinally- (execDiscordM (runEffect effect) st)- finish- where- finish (Right DiscordState{getClient = st}) = atomically $ mergeClient st- finish (Left err) = errorM "Language.Discord.Events" $ show err+ rateLimits :: Vault (DiscordApp m) [(Int, Int)]+ rateLimits = unsafePerformIO $ newMVar []+ {-# NOINLINE rateLimits #-} - -- | Monad to compose event handlers- type DiscordBot c a = Writer (Handle c) a+ delete :: Eq a => [(a, b)] -> a -> [(a, b)]+ delete ((a, b):xs) a'+ | a == a' = delete xs a'+ | otherwise = (a, b):delete xs a'+ delete [] _ = [] - -- | Event handlers for 'Gateway' events. These correspond to events listed in- -- 'Event'- data D.Client c => Handle c = Null- | Misc (Event -> Effect DiscordM ())- | ReadyEvent (Init -> Effect DiscordM ())- | ResumedEvent (Object -> Effect DiscordM ())- | ChannelCreateEvent (Channel -> Effect DiscordM ())- | ChannelUpdateEvent (Channel -> Effect DiscordM ())- | ChannelDeleteEvent (Channel -> Effect DiscordM ())- | GuildCreateEvent (Guild -> Effect DiscordM ())- | GuildUpdateEvent (Guild -> Effect DiscordM ())- | GuildDeleteEvent (Guild -> Effect DiscordM ())- | GuildBanAddEvent (Member -> Effect DiscordM ())- | GuildBanRemoveEvent (Member -> Effect DiscordM ())- | GuildEmojiUpdateEvent (Object -> Effect DiscordM ())- | GuildIntegrationsUpdateEvent (Object -> Effect DiscordM ())- | GuildMemberAddEvent (Member -> Effect DiscordM ())- | GuildMemberRemoveEvent (Member -> Effect DiscordM ())- | GuildMemberUpdateEvent (Member -> Effect DiscordM ())- | GuildMemberChunkEvent (Object -> Effect DiscordM ())- | GuildRoleCreateEvent (Object -> Effect DiscordM ())- | GuildRoleUpdateEvent (Object -> Effect DiscordM ())- | GuildRoleDeleteEvent (Object -> Effect DiscordM ())- | MessageCreateEvent (Message -> Effect DiscordM ())- | MessageUpdateEvent (Message -> Effect DiscordM ())- | MessageDeleteEvent (Object -> Effect DiscordM ())- | MessageDeleteBulkEvent (Object -> Effect DiscordM ())- | PresenceUpdateEvent (Object -> Effect DiscordM ())- | TypingStartEvent (Object -> Effect DiscordM ())- | UserSettingsUpdateEvent (Object -> Effect DiscordM ())- | UserUpdateEvent (Object -> Effect DiscordM ())- | VoiceStateUpdateEvent (Object -> Effect DiscordM ())- | VoiceServerUpdateEvent (Object -> Effect DiscordM ())- | Event String (Object -> Effect DiscordM ())+ modify :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+ modify a' b' ((a, b):xs)+ | a == a' = (a', b'): delete xs a+ | otherwise = (a, b): modify a' b' xs+ modify a' b' [] = [(a', b')] - -- | Provides a typehint for the correct 'D.Client' given an Event 'Handle'- clientProxy :: Handle c -> Proxy c- clientProxy _ = Proxy+ instance DiscordAuth m => DiscordRest (DiscordApp m) where+ getRateLimit f = lookup' (hash f) =<< get rateLimits+ where+ lookup' :: (Eq a, Monad m) => a -> [(a, b)] -> m (Maybe b)+ lookup' a' ((a, b):xs)+ | a' == a = return (Just b)+ | otherwise = lookup' a' xs+ lookup' _ [] = return Nothing+ setRateLimit f l = put rateLimits =<< modify (hash f) l `fmap` get rateLimits - -- | Register an Event 'Handle' in the 'DiscordBot' monad- with :: D.Client c => (a -> Handle c) -> a -> DiscordBot c ()- with f a = tell $ f a- - instance D.Client c => Monoid (Handle c) where- mempty = Null- a `mappend` b = Misc (\ev -> handle a ev <> handle b ev)+ instance DiscordAuth m => DiscordGate (DiscordApp m) where+ type Vault (DiscordApp m) = MVar - -- | Asynchronously run an Event 'Handle' against a Gateway 'Event'- handle :: D.Client a => Handle a -> Event -> Effect DiscordM ()- handle a@(Misc p) ev - = runAsync (clientProxy a) $ p ev- handle a@(ReadyEvent p) (D.Ready o) - = runAsync (clientProxy a) $ p o- handle a@(ResumedEvent p) (D.Resumed o) - = runAsync (clientProxy a) $ p o- handle a@(ChannelCreateEvent p) (D.ChannelCreate o) - = runAsync (clientProxy a) $ p o- handle a@(ChannelUpdateEvent p) (D.ChannelUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(ChannelDeleteEvent p) (D.ChannelDelete o) - = runAsync (clientProxy a) $ p o- handle a@(GuildCreateEvent p) (D.GuildCreate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildUpdateEvent p) (D.GuildUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildDeleteEvent p) (D.GuildDelete o) - = runAsync (clientProxy a) $ p o- handle a@(GuildBanAddEvent p) (D.GuildBanAdd o) - = runAsync (clientProxy a) $ p o- handle a@(GuildBanRemoveEvent p) (D.GuildBanRemove o) - = runAsync (clientProxy a) $ p o- handle a@(GuildEmojiUpdateEvent p) (D.GuildEmojiUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildIntegrationsUpdateEvent p) (D.GuildIntegrationsUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildMemberAddEvent p) (D.GuildMemberAdd o) - = runAsync (clientProxy a) $ p o- handle a@(GuildMemberRemoveEvent p) (D.GuildMemberRemove o) - = runAsync (clientProxy a) $ p o- handle a@(GuildMemberUpdateEvent p) (D.GuildMemberUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildMemberChunkEvent p) (D.GuildMemberChunk o) - = runAsync (clientProxy a) $ p o- handle a@(GuildRoleCreateEvent p) (D.GuildRoleCreate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildRoleUpdateEvent p) (D.GuildRoleUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(GuildRoleDeleteEvent p) (D.GuildRoleDelete o) - = runAsync (clientProxy a) $ p o- handle a@(MessageCreateEvent p) (D.MessageCreate o) - = runAsync (clientProxy a) $ p o- handle a@(MessageUpdateEvent p) (D.MessageUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(MessageDeleteEvent p) (D.MessageDelete o) - = runAsync (clientProxy a) $ p o- handle a@(MessageDeleteBulkEvent p) (D.MessageDeleteBulk o) - = runAsync (clientProxy a) $ p o- handle a@(PresenceUpdateEvent p) (D.PresenceUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(TypingStartEvent p) (D.TypingStart o) - = runAsync (clientProxy a) $ p o- handle a@(UserSettingsUpdateEvent p) (D.UserSettingsUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(UserUpdateEvent p) (D.UserUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(VoiceStateUpdateEvent p) (D.VoiceStateUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(VoiceServerUpdateEvent p) (D.VoiceServerUpdate o) - = runAsync (clientProxy a) $ p o- handle a@(Event s p) (D.UnknownEvent v o)- | s == v = runAsync (clientProxy a) $ p o- handle _ ev = liftIO $ debugM "Discord-hs.Language.Events" $ show ev+ data VaultKey (DiscordApp m) a = Store (MVar a)+ get = liftIO . readMVar+ put s v = liftIO $ do+ _ <- tryTakeMVar s+ putMVar s v++ sequenceKey = Store $ unsafePerformIO newEmptyMVar+ {-# NOINLINE sequenceKey #-}+ storeFor (Store var) = return var++ connection = DiscordApp $ \c _ -> pure c+ feed m event = do+ liftIO $ print "Running event handler"+ c <- connection+ _ <- liftIO . runIO $ runEvent m c event+ liftIO $ print "Returning from handler"++ run m conn =+ runIO $ (runEvent $ eventStream Create m) conn Nil+ fork m = do+ c <- connection+ _ <- DiscordApp $ \_ e -> liftIO . forkIO . runIO $ runEvent m c e+ return ()++ instance Functor (DiscordApp m) where+ f `fmap` DiscordApp a = DiscordApp (\c e -> f `fmap` a c e)++ instance Monad (DiscordApp m) where+ m >>= k = DiscordApp $ \c e -> do+ a <- runEvent m c e+ runEvent (k a) c e++ instance MonadIO (DiscordApp m) where+ liftIO f = DiscordApp (\_ _ -> liftIO f)++ instance MonadPlus (DiscordApp m)++ class DiscordRest m => EventMap f m where+ type Domain f+ type Codomain f+ mapEvent :: Proxy f -> Domain f -> m (Codomain f)++ data a :> b+ data a :<>: b++ instance (DiscordRest m, EventMap f m, EventMap g m, Codomain f ~ Domain g)+ => EventMap (f :> g) m where++ type Domain (f :> g) = Domain f+ type Codomain (f :> g) = Codomain g++ mapEvent p event = mapEvent b =<< mapEvent a event+ where+ (a, b) = split p+ split :: Proxy (a :> b) -> (Proxy a, Proxy b)+ split _ = (Proxy, Proxy)++ instance (DiscordRest m, EventMap f m, EventMap g m+ , Domain f ~ Domain g, Codomain f ~ Codomain g)+ => EventMap (f :<>: g) m where+ + type Domain (f :<>: g) = Domain f+ type Codomain (f :<>: g) = Codomain f++ mapEvent p event = mapEvent a event <|> mapEvent b event+ where+ (a, b) = split p+ split :: Proxy (a :<>: b) -> (Proxy a, Proxy b)+ split _ = (Proxy, Proxy)+
− src/Network/Discord/Gateway.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, RankNTypes #-}-{-# OPTIONS_HADDOCK prune, not-home #-}--- | Provides logic code for interacting with the Discord websocket--- gateway. Reallistically, this is probably lower level than most--- people will need, and you should use Language.Discord.-module Network.Discord.Gateway where- import Control.Concurrent (forkIO, threadDelay)- import Control.Monad.State- import Data.ByteString.Lazy.Char8 (unpack)-- import Control.Concurrent.STM- import Data.Aeson- import Data.Aeson.Types- import Network.WebSockets- import Network.URL- import Pipes- import System.Log.Logger- import Wuss-- import Network.Discord.Types-- -- | Turn a websocket Connection into a Pipes Producer- -- (data source)- makeWebsocketSource :: (FromJSON a, MonadIO m)- => Connection -> Producer a m ()- makeWebsocketSource conn = forever $ do- msg' <- lift . liftIO $ receiveData conn- case eitherDecode msg' of- Right msg -> yield $ msg- Left err -> liftIO $- errorM "Discord-hs.Gateway.Parse" err- >> infoM "Discord-hs.Gateway.Raw" (unpack msg')-- -- | Starts a websocket connection that allows you to handle Discord events.- runWebsocket :: (Client c)- => URL -> c -> Effect DiscordM a -> IO a- runWebsocket (URL (Absolute h) path _) client inner = do- rl <- newTVarIO []- runSecureClient (host h) 443 (path++"/?v=6")- $ \conn -> evalDiscordM (runEffect inner)- (DiscordState Create client conn undefined rl)- runWebsocket _ _ _ = mzero-- -- | Spawn a heartbeat thread- heartbeat :: Int -> Connection -> TMVar Integer -> IO ()- heartbeat interval conn sq = void . forkIO . forever $ do- seqNum <- atomically $ readTMVar sq- sendTextData conn $ Heartbeat seqNum- threadDelay $ interval * 1000- - -- | Turn a websocket data source into an 'Event' data- -- source- makeEvents :: Pipe Payload Event DiscordM a- makeEvents = forever $ do- st@(DiscordState dState client ws _ _) <- get- case dState of- Create -> do- Hello interval <- await- sq <- liftIO . atomically $ newEmptyTMVar- put st {getState=Start, getSequenceNum=sq}- liftIO $ heartbeat interval ws sq- Start -> do- liftIO $ sendTextData ws- (Identify (getAuth client) False 50 (0, 1))- Dispatch o sq "READY" <- await- liftIO . atomically $ putTMVar (getSequenceNum st) sq- case parseEither parseJSON $ Object o of- Right a -> yield $ Ready a- Left reason -> liftIO $ errorM "Discord-hs.Gateway.Dispatch" reason- put st {getState=Running}- Running -> do- pl <- await- case pl of- Dispatch _ sq _ -> do- liftIO . atomically $ tryTakeTMVar (getSequenceNum st)- >> putTMVar (getSequenceNum st) sq- case parseDispatch pl of- Left reason -> liftIO $ errorM "Discord-hs.Gateway.Dispatch" reason- Right payload -> yield payload- Heartbeat sq -> do- liftIO . atomically $ tryTakeTMVar (getSequenceNum st)- >> putTMVar (getSequenceNum st) sq- liftIO . sendTextData ws $ Heartbeat sq- Reconnect -> put st {getState=InvalidReconnect}- InvalidSession -> put st {getState=Start}- HeartbeatAck -> liftIO $ infoM "Discord-hs.Gateway.Heartbeat" "HeartbeatAck"- _ -> do- liftIO $ errorM "Discord-hs.Gateway.Error" "InvalidPacket"- put st {getState=InvalidDead}- InvalidReconnect -> put st {getState=InvalidDead}- InvalidDead -> liftIO $ errorM "Discord-hs.Gateway.Error" "BotDied"- - -- | Utility function providing core functionality by converting a Websocket- -- 'Connection' to a stream of gateway 'Event's- eventCore :: Connection -> Producer Event DiscordM ()- eventCore conn = makeWebsocketSource conn >-> makeEvents-
− src/Network/Discord/Rest.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}-{-# OPTIONS_HADDOCK prune, not-home #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Provides framework to interact with REST api gateways. Implementations specific to the--- Discord API are provided in Network.Discord.Rest.Channel, Network.Discord.Rest.Guild,--- and Network.Discord.Rest.User.-module Network.Discord.Rest- ( module Network.Discord.Rest- , module Network.Discord.Rest.Prelude- , module Network.Discord.Rest.Channel- , module Network.Discord.Rest.Guild- , module Network.Discord.Rest.User- ) where- import Control.Monad (void)- import Data.Maybe (fromJust)- import Control.Exception (throwIO)-- import qualified Network.HTTP.Req as R- import Control.Monad.Morph (lift)- import Data.Aeson.Types- import Data.Hashable- import Network.URL- import Pipes.Core-- import Network.Discord.Types as Dc- import Network.Discord.Rest.Channel- import Network.Discord.Rest.Guild- import Network.Discord.Rest.Prelude- import Network.Discord.Rest.User- import Network.Discord.Rest.HTTP (baseUrl)-- -- | Perform an API request.- fetch :: (DoFetch a, Hashable a)- => a -> Pipes.Core.Proxy X () c' c DiscordM Fetched- fetch req = restServer +>> (request $ Fetch req)-- -- | Perform an API request, ignoring the response- fetch' :: (DoFetch a, Hashable a)- => a -> Pipes.Core.Proxy X () c' c DiscordM ()- fetch' = void . fetch-- -- | Alternative method of interacting with the REST api- withApi :: Pipes.Core.Client Fetchable Fetched DiscordM Fetched- -> Effect DiscordM ()- withApi inner = void $ restServer +>> inner-- -- | Provides a pipe to perform REST actions- restServer :: Fetchable -> Server Fetchable Fetched DiscordM Fetched- restServer req =- lift (doFetch req) >>= respond >>= restServer-- instance R.MonadHttp IO where- handleHttpException = throwIO-- -- | Obtains a new gateway to connect to.- getGateway :: IO URL- getGateway = do- r <- R.req R.GET (baseUrl R./: "gateway") R.NoReqBody R.jsonResponse mempty- return . fromJust $ importURL =<< parseMaybe getURL (R.responseBody r)-- where- getURL :: Value -> Parser String- getURL = withObject "url" (.: "url")
− src/Network/Discord/Rest/Channel.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--- | Provides actions for Channel API interactions-module Network.Discord.Rest.Channel- (- ChannelRequest(..)- ) where- - import Data.Aeson- import Data.ByteString.Lazy- import Data.Hashable- import Data.Monoid (mempty, (<>))- import Data.Text as T- import Network.HTTP.Client (RequestBody (..))- import Network.HTTP.Client.MultipartFormData (partFileRequestBody)- import Network.HTTP.Req (reqBodyMultipart)- - import Network.Discord.Rest.Prelude- import Network.Discord.Types- import Network.Discord.Rest.HTTP-- -- | Data constructor for Channel requests. See <https://discordapp.com/developers/docs/resources/Channel Channel API>- data ChannelRequest a where- -- | Gets a channel by its id.- GetChannel :: Snowflake -> ChannelRequest Channel- -- | Edits channels options.- ModifyChannel :: ToJSON a => Snowflake -> a -> 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 -> Range -> ChannelRequest [Message]- -- | Gets a message in a channel by its id.- GetChannelMessage :: Snowflake -> Snowflake -> ChannelRequest Message- -- | Sends a message to a channel.- CreateMessage :: Snowflake -> Text -> Maybe Embed -> ChannelRequest Message- -- | Sends a message with a file to a channel.- UploadFile :: Snowflake -> FilePath -> ByteString -> ChannelRequest Message- -- | Edits a message content.- EditMessage :: Message -> Text -> Maybe Embed -> ChannelRequest Message- -- | Deletes a message.- DeleteMessage :: Message -> ChannelRequest ()- -- | Deletes a group of messages.- BulkDeleteMessage :: Snowflake -> [Message] -> ChannelRequest ()- -- | Edits a permission overrides for a channel.- EditChannelPermissions :: ToJSON a => Snowflake -> Snowflake -> a -> ChannelRequest ()- -- | Gets all instant invites to a channel.- GetChannelInvites :: Snowflake -> ChannelRequest Object- -- | Creates an instant invite to a channel.- CreateChannelInvite :: ToJSON a => Snowflake -> a -> 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 ()-- instance Hashable (ChannelRequest a) where- hashWithSalt s (GetChannel chan) = hashWithSalt s ("get_chan"::Text, chan)- hashWithSalt s (ModifyChannel chan _) = hashWithSalt s ("mod_chan"::Text, chan)- hashWithSalt s (DeleteChannel chan) = hashWithSalt s ("mod_chan"::Text, chan)- hashWithSalt s (GetChannelMessages chan _) = hashWithSalt s ("msg"::Text, chan)- hashWithSalt s (GetChannelMessage chan _) = hashWithSalt s ("get_msg"::Text, chan)- hashWithSalt s (CreateMessage chan _ _) = hashWithSalt s ("msg"::Text, chan)- hashWithSalt s (UploadFile chan _ _) = hashWithSalt s ("msg"::Text, chan)- hashWithSalt s (EditMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _) _ _) =- hashWithSalt s ("get_msg"::Text, chan)- hashWithSalt s (DeleteMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _)) =- hashWithSalt s ("get_msg"::Text, chan)- hashWithSalt s (BulkDeleteMessage chan _) = hashWithSalt s ("del_msgs"::Text, chan)- hashWithSalt s (EditChannelPermissions chan _ _) = hashWithSalt s ("perms"::Text, chan)- hashWithSalt s (GetChannelInvites chan) = hashWithSalt s ("invites"::Text, chan)- hashWithSalt s (CreateChannelInvite chan _) = hashWithSalt s ("invites"::Text, chan)- hashWithSalt s (DeleteChannelPermission chan _) = hashWithSalt s ("perms"::Text, chan)- hashWithSalt s (TriggerTypingIndicator chan) = hashWithSalt s ("tti"::Text, chan)- hashWithSalt s (GetPinnedMessages chan) = hashWithSalt s ("pins"::Text, chan)- hashWithSalt s (AddPinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)- hashWithSalt s (DeletePinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)-- instance RateLimit (ChannelRequest a)-- instance (FromJSON a) => DoFetch (ChannelRequest a) where- doFetch req = SyncFetched <$> go req- where- maybeEmbed :: Maybe Embed -> [(Text, Value)]- maybeEmbed = maybe [] $ \embed -> ["embed" .= embed]- url = baseUrl /: "channels"- go :: ChannelRequest a -> DiscordM a- go r@(GetChannel chan) = makeRequest r- $ Get (url // chan) mempty- go r@(ModifyChannel chan patch) = makeRequest r- $ Patch (url // chan)- (ReqBodyJson patch) mempty- go r@(DeleteChannel chan) = makeRequest r- $ Delete (url // chan) mempty- go r@(GetChannelMessages chan range) = makeRequest r- $ Get (url // chan /: "messages") (toQueryString range)- go r@(GetChannelMessage chan msg) = makeRequest r- $ Get (url // chan /: "messages" // msg) mempty- go r@(CreateMessage chan msg embed) = makeRequest r- $ Post (url // chan /: "messages")- (ReqBodyJson . object $ ["content" .= msg] <> maybeEmbed embed)- mempty- go r@(UploadFile chan fileName file) = do- body <- reqBodyMultipart [partFileRequestBody "file" fileName $ RequestBodyLBS file]- makeRequest r $ Post (url // chan /: "messages")- body mempty- go r@(EditMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) new embed) = makeRequest r- $ Patch (url // chan /: "messages" // msg)- (ReqBodyJson . object $ ["content" .= new] <> maybeEmbed embed)- mempty- go r@(DeleteMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _)) = makeRequest r- $ Delete (url // chan /: "messages" // msg) mempty- go r@(BulkDeleteMessage chan msgs) = makeRequest r- $ Post (url // chan /: "messages" /: "bulk-delete")- (ReqBodyJson $ object ["messages" .= Prelude.map messageId msgs])- mempty- go r@(EditChannelPermissions chan perm patch) = makeRequest r- $ Put (url // chan /: "permissions" // perm)- (ReqBodyJson patch) mempty- go r@(GetChannelInvites chan) = makeRequest r- $ Get (url // chan /: "invites") mempty- go r@(CreateChannelInvite chan patch) = makeRequest r- $ Post (url // chan /: "invites")- (ReqBodyJson patch) mempty- go r@(DeleteChannelPermission chan perm) = makeRequest r- $ Delete (url // chan /: "permissions" // perm) mempty- go r@(TriggerTypingIndicator chan) = makeRequest r- $ Post (url // chan /: "typing")- NoReqBody mempty- go r@(GetPinnedMessages chan) = makeRequest r- $ Get (url // chan /: "pins") mempty- go r@(AddPinnedMessage chan msg) = makeRequest r- $ Put (url // chan /: "pins" // msg)- NoReqBody mempty- go r@(DeletePinnedMessage chan msg) = makeRequest r- $ Delete (url // chan /: "pins" // msg) mempty
− src/Network/Discord/Rest/Guild.hs
@@ -1,229 +0,0 @@-{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--- | Provides actions for Guild API interactions.-module Network.Discord.Rest.Guild- (- GuildRequest(..)- ) where- - import Data.Aeson- import Data.Hashable- import Data.Monoid (mempty)- import Data.Text as T- import Network.HTTP.Req ((=:))- - import Network.Discord.Rest.Prelude- import Network.Discord.Types- import Network.Discord.Rest.HTTP-- -- | Data constructor for Guild requests. See - -- <https://discordapp.com/developers/docs/resources/guild Guild API>- data GuildRequest a where- -- | 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'.- ModifyGuild :: ToJSON a => Snowflake -> a -> 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'- CreateGuildChannel :: ToJSON a => Snowflake -> a -> 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.- ModifyChanPosition :: ToJSON a => Snowflake -> a -> GuildRequest [Channel]- -- | Returns a guild 'Member' object for the specified user- GetGuildMember :: Snowflake -> Snowflake -> GuildRequest Member- -- | Returns a list of guild 'Member' objects that are members of the guild.- ListGuildMembers :: Snowflake -> Range -> GuildRequest [Member]- -- | 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.- AddGuildMember :: ToJSON a => Snowflake -> Snowflake -> a - -> GuildRequest Member- -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'.- ModifyGuildMember :: ToJSON a => Snowflake -> Snowflake -> a - -> 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.- ModifyGuildRolePositions :: ToJSON a => Snowflake -> [a] -> GuildRequest [Role]- -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the - -- updated 'Role' on success. Fires a Guild Role Update 'Event's.- ModifyGuildRole :: ToJSON a => Snowflake -> Snowflake -> a - -> 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'.- CreateGuildIntegration :: ToJSON a => Snowflake -> a -> GuildRequest ()- -- | Modify the behavior and settings of a 'Integration' object for the guild.- -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.- ModifyGuildIntegration :: ToJSON a => Snowflake -> Snowflake -> a -> 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-- instance Hashable (GuildRequest a) where- hashWithSalt s (GetGuild g) = hashWithSalt s ("guild"::Text, g)- hashWithSalt s (ModifyGuild g _) = hashWithSalt s ("guild"::Text, g)- hashWithSalt s (DeleteGuild g) = hashWithSalt s ("guild"::Text, g)- hashWithSalt s (GetGuildChannels g) = hashWithSalt s ("guild_chan"::Text, g)- hashWithSalt s (CreateGuildChannel g _) = hashWithSalt s ("guild_chan"::Text, g)- hashWithSalt s (ModifyChanPosition g _) = hashWithSalt s ("guild_chan"::Text, g)- hashWithSalt s (GetGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)- hashWithSalt s (ListGuildMembers g _) = hashWithSalt s ("guild_membs"::Text, g)- hashWithSalt s (AddGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)- hashWithSalt s (ModifyGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)- hashWithSalt s (RemoveGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)- hashWithSalt s (GetGuildBans g) = hashWithSalt s ("guild_bans"::Text, g)- hashWithSalt s (CreateGuildBan g _ _) = hashWithSalt s ("guild_ban" ::Text, g)- hashWithSalt s (RemoveGuildBan g _) = hashWithSalt s ("guild_ban" ::Text, g)- hashWithSalt s (GetGuildRoles g) = hashWithSalt s ("guild_roles"::Text, g)- hashWithSalt s (CreateGuildRole g) = hashWithSalt s ("guild_roles"::Text, g)- hashWithSalt s (ModifyGuildRolePositions g _)- = hashWithSalt s ("guild_roles"::Text, g)- hashWithSalt s (ModifyGuildRole g _ _) = hashWithSalt s ("guild_role" ::Text, g)- hashWithSalt s (DeleteGuildRole g _ ) = hashWithSalt s ("guild_role" ::Text, g)- hashWithSalt s (GetGuildPruneCount g _) = hashWithSalt s ("guild_prune"::Text, g)- hashWithSalt s (BeginGuildPrune g _) = hashWithSalt s ("guild_prune"::Text, g)- hashWithSalt s (GetGuildVoiceRegions g) = hashWithSalt s ("guild_voice"::Text, g)- hashWithSalt s (GetGuildInvites g) = hashWithSalt s ("guild_invit"::Text, g)- hashWithSalt s (GetGuildIntegrations g) = hashWithSalt s ("guild_integ"::Text, g)- hashWithSalt s (CreateGuildIntegration g _)- = hashWithSalt s ("guild_integ"::Text, g)- hashWithSalt s (ModifyGuildIntegration g _ _)- = hashWithSalt s ("guild_intgr"::Text, g)- hashWithSalt s (DeleteGuildIntegration g _)- = hashWithSalt s ("guild_intgr"::Text, g)- hashWithSalt s (SyncGuildIntegration g _)= hashWithSalt s ("guild_sync" ::Text, g)- hashWithSalt s (GetGuildEmbed g) = hashWithSalt s ("guild_embed"::Text, g)- hashWithSalt s (ModifyGuildEmbed g _) = hashWithSalt s ("guild_embed"::Text, g)-- instance RateLimit (GuildRequest a)-- instance (FromJSON a) => DoFetch (GuildRequest a) where- doFetch req = SyncFetched <$> go req- where- url = baseUrl /: "guilds"- go :: GuildRequest a -> DiscordM a- go r@(GetGuild guild) = makeRequest r- $ Get (url // guild) mempty- go r@(ModifyGuild guild patch) = makeRequest r- $ Patch (url // guild) (ReqBodyJson patch) mempty- go r@(DeleteGuild guild) = makeRequest r- $ Delete (url // guild) mempty- go r@(GetGuildChannels guild) = makeRequest r- $ Get (url // guild /: "channels") mempty- go r@(CreateGuildChannel guild patch) = makeRequest r- $ Post (url // guild /: "channels") (ReqBodyJson patch) mempty- go r@(ModifyChanPosition guild patch) = makeRequest r- $ Post (url // guild /: "channels") (ReqBodyJson patch) mempty- go r@(GetGuildMember guild member) = makeRequest r- $ Get (url // guild /: "members" // member) mempty- go r@(ListGuildMembers guild range) = makeRequest r- $ Get (url // guild /: "members") (toQueryString range)- go r@(AddGuildMember guild user patch) = makeRequest r- $ Put (url // guild /: "members" // user) (ReqBodyJson patch) mempty- go r@(ModifyGuildMember guild member patch) = makeRequest r- $ Patch (url // guild /: "members" // member) (ReqBodyJson patch) mempty- go r@(RemoveGuildMember guild user) = makeRequest r- $ Delete (url // guild /: "members" // user) mempty- go r@(GetGuildBans guild) = makeRequest r- $ Get (url // guild /: "bans") mempty- go r@(CreateGuildBan guild user msgs) = makeRequest r- $ Put (url // guild /: "bans" // user)- (ReqBodyJson $ object [ "delete-message-days" .= msgs])- mempty- go r@(RemoveGuildBan guild ban) = makeRequest r- $ Delete (url // guild /: "bans" // ban) mempty- go r@(GetGuildRoles guild) = makeRequest r- $ Get (url // guild /: "roles") mempty- go r@(CreateGuildRole guild) = makeRequest r- $ Post (url // guild /: "roles")- NoReqBody mempty- go r@(ModifyGuildRolePositions guild patch) = makeRequest r- $ Post (url // guild /: "roles")- (ReqBodyJson patch) mempty- go r@(ModifyGuildRole guild role patch) = makeRequest r- $ Post (url // guild /: "roles" // role)- (ReqBodyJson patch) mempty- go r@(DeleteGuildRole guild role) = makeRequest r- $ Delete (url // guild /: "roles" // role) mempty- go r@(GetGuildPruneCount guild days) = makeRequest r- $ Get (url // guild /: "prune") ("days" =: days)- go r@(BeginGuildPrune guild days) = makeRequest r- $ Post (url // guild /: "prune") - NoReqBody ("days" =: days)- go r@(GetGuildVoiceRegions guild) = makeRequest r- $ Get (url // guild /: "regions") mempty- go r@(GetGuildInvites guild) = makeRequest r- $ Get (url // guild /: "invites") mempty- go r@(GetGuildIntegrations guild) = makeRequest r- $ Get (url // guild /: "integrations") mempty- go r@(CreateGuildIntegration guild patch) = makeRequest r- $ Post (url // guild /: "integrations")- (ReqBodyJson patch) mempty- go r@(ModifyGuildIntegration guild integ patch) = makeRequest r- $ Patch (url // guild /: "integrations" // integ)- (ReqBodyJson patch) mempty- go r@(DeleteGuildIntegration guild integ) = makeRequest r- $ Delete (url // guild /: "integrations" // integ)- mempty- go r@(SyncGuildIntegration guild integ) = makeRequest r- $ Post (url // guild /: "integrations" // integ)- NoReqBody mempty- go r@(GetGuildEmbed guild) = makeRequest r- $ Get (url // guild /: "integrations") mempty- go r@(ModifyGuildEmbed guild patch) = makeRequest r- $ Patch (url // guild /: "embed")- (ReqBodyJson patch) mempty
− src/Network/Discord/Rest/HTTP.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE DataKinds, ScopedTypeVariables, Rank2Types #-}--- | Provide HTTP primitives-module Network.Discord.Rest.HTTP- ( JsonRequest(..)- , R.ReqBodyJson(..)- , R.NoReqBody(..)- , baseUrl- , fetch- , makeRequest- , (//)- , (R./:)- ) where-- import Data.Semigroup ((<>))-- import Control.Monad.State (get, when)- import Data.Aeson- import Data.ByteString.Char8 (pack, ByteString)- import Data.Maybe (fromMaybe)- import qualified Data.Text as T (pack)- import qualified Network.HTTP.Req as R-- import Data.Version (showVersion)- import Network.Discord.Rest.Prelude- import Network.Discord.Types (DiscordM, getClient, DiscordState(..), getAuth)- import Paths_discord_hs (version)-- -- | The base url (Req) for API requests- baseUrl :: R.Url 'R.Https- baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion- where apiVersion = "v6"-- -- | Construct base options with auth from Discord state- baseRequestOptions :: DiscordM Option- baseRequestOptions = do- DiscordState {getClient=client} <- get- return $ R.header "Authorization" (pack . show $ getAuth client)- <> R.header "User-Agent" (pack $ "DiscordBot (https://github.com/jano017/Discord.hs,"- ++ showVersion version ++ ")")- infixl 5 //- (//) :: Show a => R.Url scheme -> a -> R.Url scheme- url // part = url R./: (T.pack $ show part)-- type Option = R.Option 'R.Https- - -- | Represtents a HTTP request made to an API that supplies a Json response- data JsonRequest r where- Delete :: FromJSON r => R.Url 'R.Https -> Option -> JsonRequest r- Get :: FromJSON r => R.Url 'R.Https -> Option -> JsonRequest r- Patch :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r- Post :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r- Put :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r-- fetch :: FromJSON r => JsonRequest r -> DiscordM (R.JsonResponse r)- fetch (Delete url opts) = R.req R.DELETE url R.NoReqBody R.jsonResponse =<< (<> opts) <$> baseRequestOptions- fetch (Get url opts) = R.req R.GET url R.NoReqBody R.jsonResponse =<< (<> opts) <$> baseRequestOptions- fetch (Patch url body opts) = R.req R.PATCH url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions- fetch (Post url body opts) = R.req R.POST url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions- fetch (Put url body opts) = R.req R.PUT url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions-- makeRequest :: (RateLimit a, FromJSON r) => a -> JsonRequest r -> DiscordM r- makeRequest req action = do- waitRateLimit req- resp <- fetch action- when (parseHeader resp "X-RateLimit-Remaining" 1 < 1) $- setRateLimit req $ parseHeader resp "X-RateLimit-Reset" 0- return $ R.responseBody resp- where- parseHeader :: R.HttpResponse resp => resp -> ByteString -> Int -> Int- parseHeader resp header def = fromMaybe def $ decodeStrict =<< R.responseHeader resp header- - -- | Base implementation of DoFetch, allows arbitrary HTTP requests to be performed- instance (FromJSON r) => DoFetch (JsonRequest r) where- doFetch req = SyncFetched . R.responseBody <$> fetch req
− src/Network/Discord/Rest/Prelude.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings, DataKinds #-}---- | Utility and base types and functions for the Discord Rest API-module Network.Discord.Rest.Prelude where- import Control.Concurrent (threadDelay)-- import Control.Comonad- import Control.Concurrent.STM- import Data.Aeson- import Data.Default- import Data.Hashable- import Data.Monoid ((<>))- import Data.Time.Clock.POSIX- import Network.HTTP.Req (Option, Scheme(..), (=:))- import System.Log.Logger- import qualified Control.Monad.State as St-- import Network.Discord.Types-- -- | The base url for API requests- baseURL :: String- baseURL = "https://discordapp.com/api/v6"-- -- | Class for rate-limitable actions- class Hashable a => RateLimit a where- -- | Return seconds to expiration if we're waiting- -- for a rate limit to reset- getRateLimit :: a -> DiscordM (Maybe Int)- getRateLimit req = do- DiscordState {getRateLimits=rl} <- St.get- now <- St.liftIO (fmap round getPOSIXTime :: IO Int)- St.liftIO . atomically $ do- rateLimits <- readTVar rl- case lookup (hash req) rateLimits of- Nothing -> return Nothing- Just a- | a >= now -> return $ Just a- | otherwise -> modifyTVar' rl (delete $ hash req) >> return Nothing- -- | Set seconds to the next rate limit reset when- -- we hit a rate limit- setRateLimit :: a -> Int -> DiscordM ()- setRateLimit req reset = do- DiscordState {getRateLimits=rl} <- St.get- St.liftIO . atomically . modifyTVar rl $ insert (hash req) reset- -- | If we hit a rate limit, wait for it to reset- waitRateLimit :: a -> DiscordM ()- waitRateLimit endpoint = do- rl <- getRateLimit endpoint- case rl of- Nothing -> return ()- Just a -> do- now <- St.liftIO (fmap round getPOSIXTime :: IO Int)- St.liftIO $ do- infoM "Discord-hs.Rest" "Waiting for rate limit to reset..."- threadDelay $ 1000000 * (a - now)- putStrLn "Done"- return ()-- -- | Class over which performing a data retrieval action is defined- class DoFetch a where- doFetch :: a -> DiscordM Fetched-- -- | Polymorphic type for all DoFetch types- data Fetchable = forall a. (DoFetch a, Hashable a) => Fetch a-- instance DoFetch Fetchable where- doFetch (Fetch a) = doFetch a-- instance Hashable Fetchable where- hashWithSalt s (Fetch a) = hashWithSalt s a-- instance Eq Fetchable where- (Fetch a) == (Fetch b) = hash a == hash b-- -- | Result of a data retrieval action- data Fetched = forall a. (FromJSON a) => SyncFetched a-- instance Functor Fetched where- fmap f (SyncFetched a) = SyncFetched (f a)-- instance Comonad Fetched where- extend = (SyncFetched .)- extract (SyncFetched a) = a-- -- | Represents a range of 'Snowflake's- data Range = Range { after :: Snowflake, before :: Snowflake, limit :: Int}-- instance Default Range where- def = Range 0 18446744073709551615 100-- -- | Convert a Range to a query string- toQueryString :: Range -> Option 'Https- toQueryString (Range a b l)- = "after" =: show a- <> "before" =: show b- <> "limit" =: show l
− src/Network/Discord/Rest/User.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--- | Provide actions for User API interactions.-module Network.Discord.Rest.User- (- UserRequest(..)- ) where- - import Data.Aeson- import Data.Hashable- import Data.Monoid (mempty)- import Data.Text as T- - import Network.Discord.Rest.Prelude- import Network.Discord.Types- import Network.Discord.Rest.HTTP-- -- | Data constructor for User requests. See- -- <https://discordapp.com/developers/docs/resources/user User API>- 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.- ModifyCurrentUser :: ToJSON a => a -> UserRequest User- -- | Returns a list of user 'Guild' objects the current user is a member of.- -- Requires the guilds OAuth2 scope.- GetCurrentUserGuilds :: Range -> UserRequest Guild- -- | 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-- instance Hashable (UserRequest a) where- hashWithSalt s (GetCurrentUser) = hashWithSalt s ("me"::Text)- hashWithSalt s (GetUser _) = hashWithSalt s ("user"::Text)- hashWithSalt s (ModifyCurrentUser _) = hashWithSalt s ("modify_user"::Text)- hashWithSalt s (GetCurrentUserGuilds _) = hashWithSalt s ("get_user_guilds"::Text)- hashWithSalt s (LeaveGuild g) = hashWithSalt s ("leave_guild"::Text, g)- hashWithSalt s (GetUserDMs) = hashWithSalt s ("get_dms"::Text)- hashWithSalt s (CreateDM _) = hashWithSalt s ("make_dm"::Text)-- instance RateLimit (UserRequest a)-- instance (FromJSON a) => DoFetch (UserRequest a) where- doFetch req = SyncFetched <$> go req- where- url = baseUrl /: "users"- go :: UserRequest a -> DiscordM a- go r@(GetCurrentUser) = makeRequest r- $ Get (url /: "@me") mempty-- go r@(GetUser user) = makeRequest r - $ Get (url // user ) mempty-- go r@(ModifyCurrentUser patch) = makeRequest r - $ Patch (url /: "@me") (ReqBodyJson patch) mempty-- go r@(GetCurrentUserGuilds range) = makeRequest r - $ Get url $ toQueryString range-- go r@(LeaveGuild guild) = makeRequest r- $ Delete (url /: "@me" /: "guilds" // guild) mempty-- go r@(GetUserDMs) = makeRequest r- $ Get (url /: "@me" /: "channels") mempty-- go r@(CreateDM user) = makeRequest r- $ Post (url /: "@me" /: "channels")- (ReqBodyJson $ object ["recipient_id" .= user])- mempty
− src/Network/Discord/Types.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE RankNTypes, ExistentialQuantification, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_HADDOCK prune, not-home #-}--- | Provides types and encoding/decoding code. Types should be identical to those provided--- in the Discord API documentation.-module Network.Discord.Types- ( module Network.Discord.Types- , module Network.Discord.Types.Prelude- , module Network.Discord.Types.Channel- , module Network.Discord.Types.Events- , module Network.Discord.Types.Gateway- , module Network.Discord.Types.Guild- ) where-- import Data.Proxy (Proxy)- import Control.Monad.State (StateT, MonadState, evalStateT, execStateT)-- import Control.Concurrent.STM- import Control.Monad.IO.Class (MonadIO)- import Network.WebSockets (Connection)- import System.IO.Unsafe (unsafePerformIO)- import qualified Network.HTTP.Req as R (MonadHttp(..))-- import Network.Discord.Types.Channel- import Network.Discord.Types.Events- import Network.Discord.Types.Gateway- import Network.Discord.Types.Guild- import Network.Discord.Types.Prelude-- -- | Provides a list of possible states for the client gateway to be in.- data StateEnum = Create | Start | Running | InvalidReconnect | InvalidDead-- -- | Stores details needed to manage the gateway and bot- data DiscordState = forall a . (Client a) => DiscordState- { getState :: StateEnum -- ^ Current state of the gateway- , getClient :: a -- ^ Currently running bot client- , getWebSocket :: Connection -- ^ Stored WebSocket gateway- , getSequenceNum :: TMVar Integer -- ^ Heartbeat sequence number- , getRateLimits :: TVar [(Int, Int)] -- ^ List of rate-limited endpoints- }-- -- | Convenience type alias for the monad most used throughout most Discord.hs operations- newtype DiscordM a = DiscordM (StateT DiscordState IO a)- deriving (MonadIO, MonadState DiscordState, Monad, Applicative, Functor)- - -- | Allow HTTP requests to be made from the DiscordM monad- instance R.MonadHttp DiscordM where- handleHttpException e = error $ show e- - -- | Unwrap and eval a 'DiscordM'- evalDiscordM :: DiscordM a -> DiscordState -> IO a- evalDiscordM (DiscordM inner) = evalStateT inner-- -- | Unwrap and exec a 'DiscordM'- execDiscordM :: DiscordM a -> DiscordState -> IO DiscordState- execDiscordM (DiscordM inner) = execStateT inner- - -- | The Client typeclass holds the majority of the user-customizable state,- -- including merging states resulting from async operations.- class Client c where- -- | Provides authorization token associated with the client- getAuth :: c -> Auth- -- | Function for resolving state differences due to async operations.- -- Developers are responsible for preventing race conditions.- -- Remember as `merge newState oldState`- merge :: c -- ^ Modified state- -> c -- ^ Initial state- -> c -- ^ Merged state- merge _ st = st -- By default, we simply discard the modified state (we don't- -- store state by default)-- -- | Control access to state. In cases where state locks aren't needed, this- -- is most likely the best solution. This implementation most likely- -- needs an accompanying {-\# NOINLINE getTMClient \#-} pragma to ensure- -- that a single state is shared between events- getTMClient :: TVar c- getTMClient = unsafePerformIO $ newTVarIO undefined- {-# NOINLINE getTMClient #-}-- -- | In some cases, state locks are needed to prevent race conditions or - -- TVars are an unwanted solution. In these cases, both getClient and- -- modifyClient should be implemented.- getSTMClient :: Proxy c -- ^ Type witness for the client- -> STM c- getSTMClient _ = readTVar getTMClient- - -- | modifyClient is used by mergeClient to merge application states before- -- and after an event handler is run- {-# NOINLINE getSTMClient #-}- modifyClient :: (c -> c) -> STM ()- modifyClient f = modifyTVar getTMClient f- - -- | Merges application states before and after an event handler- mergeClient :: c -> STM ()- mergeClient client = modifyClient $ merge client
− src/Network/Discord/Types/Channel.hs
@@ -1,328 +0,0 @@-{-# LANGUAGE OverloadedStrings, MultiWayIf #-}-{-# LANGUAGE RecordWildCards #-}--- | Data structures pertaining to Discord Channels-module Network.Discord.Types.Channel where- import Control.Monad (mzero)- import Data.Text as Text (pack, Text)-- import Data.Aeson- import Data.Aeson.Types (Parser)- import Data.Time.Clock- import Data.Vector (toList)- import qualified Data.HashMap.Strict as HM- import qualified Data.Vector as V-- import Network.Discord.Types.Prelude-- -- |Represents information about a user.- data User = User- { userId :: {-# UNPACK #-} !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 (Object o) =- User <$> o .: "id"- <*> o .: "username"- <*> o .: "discriminator"- <*> o .:? "avatar"- <*> o .:? "bot" .!= False- <*> o .:? "mfa_enabled"- <*> o .:? "verified"- <*> o .:? "email"- parseJSON _ = mzero-- -- | 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 :: 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 :: Snowflake- } deriving (Show, Eq)-- instance FromJSON Channel where- parseJSON = withObject "text or voice" $ \o -> do- type' <- (o .: "type") :: Parser Int- case type' of- 0 ->- Text <$> o .: "id"- <*> o .: "guild_id"- <*> o .: "name"- <*> o .: "position"- <*> o .: "permission_overwrites"- <*> o .:? "topic" .!= ""- <*> o .:? "last_message_id" .!= 0- 1 ->- DirectMessage <$> o .: "id"- <*> o .: "recipients"- <*> o .:? "last_message_id" .!= 0- 2 ->- Voice <$> o .: "id"- <*> o .: "guild_id"- <*> o .: "name"- <*> o .: "position"- <*> o .: "permission_overwrites"- <*> o .: "bitrate"- <*> o .: "user_limit"- _ -> mzero-- -- | Permission overwrites for a channel.- data Overwrite = Overwrite - { overwriteId:: {-# UNPACK #-} !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 (Object o) =- Overwrite <$> o .: "id"- <*> o .: "type"- <*> o .: "allow"- <*> o .: "deny"- parseJSON _ = mzero-- -- | Represents information about a message in a Discord channel.- data Message = Message- { messageId :: {-# UNPACK #-} !Snowflake -- ^ The id of the message- , messageChannel :: {-# UNPACK #-} !Snowflake -- ^ Id of the channel the message- -- was sent in- , messageAuthor :: User -- ^ The 'User' the message was sent- -- by- , messageContent :: 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 (Object 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- parseJSON _ = mzero-- -- |Represents an attached to a message file.- data Attachment = Attachment- { attachmentId :: {-# UNPACK #-} !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 (Object o) =- Attachment <$> o .: "id"- <*> o .: "filename"- <*> o .: "size"- <*> o .: "url"- <*> o .: "proxy_url"- <*> o .:? "height"- <*> o .:? "width"- parseJSON _ = mzero-- -- |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 (Object 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- | k == pack "footer" =- (Footer <$> v .: "text"- <*> v .:? "icon_url" .!= ""- <*> v .:? "proxy_icon_url" .!= "") : a- | k == pack "image" =- (Image <$> v .: "url"- <*> v .: "proxy_url"- <*> v .: "height"- <*> v .: "width") : a- | k == pack "thumbnail" =- (Thumbnail <$> v .: "url"- <*> v .: "proxy_url"- <*> v .: "height"- <*> v .: "width") : a- | k == pack "video" =- (Video <$> v .: "url"- <*> v .: "height"- <*> v .: "width") : a- | k == pack "provider" =- (Provider <$> v .: "name"- <*> v .:? "url" .!= "") : a- | k == pack "author" =- (Author <$> v .: "name"- <*> v .:? "url" .!= ""- <*> v .:? "icon_url" .!= ""- <*> v .:? "proxy_icon_url" .!= "") : a- to_embed k (Array v) a- | k == pack "fields" =- [Field <$> i .: "name"- <*> i .: "value"- <*> i .: "inline"- | Object i <- toList v] ++ a- to_embed _ _ a = a-- parseJSON _ = mzero-- instance ToJSON Embed where- toJSON (Embed {..}) = object - [ "title" .= embedTitle- , "type" .= embedType- , "description" .= embedDesc- , "url" .= embedUrl- , "timestamp" .= embedTime- , "color" .= embedColor- ] |> makeSubEmbeds embedFields- where- (Object o) |> hm = Object $ HM.union o hm- _ |> _ = error "Type mismatch"- makeSubEmbeds = foldr embed HM.empty- 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)
− src/Network/Discord/Types/Events.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE OverloadedStrings, GADTs #-}--- | Data structures pertaining to gateway dispatch 'Event's-module Network.Discord.Types.Events where- import Control.Monad (mzero)-- import Data.Aeson-- import Network.Discord.Types.Channel- import Network.Discord.Types.Gateway- import Network.Discord.Types.Guild (Member, Guild)- import Network.Discord.Types.Prelude-- -- |Represents data sent on READY event.- data Init = Init Int User [Channel] [Guild] String deriving Show-- -- |Allows Init type to be generated using a JSON response by Discord.- instance FromJSON Init where- parseJSON (Object o) = Init <$> o .: "v"- <*> o .: "user"- <*> o .: "private_channels"- <*> o .: "guilds"- <*> o .: "session_id"- parseJSON _ = mzero-- -- |Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway.- data Event =- Ready Init- | Resumed Object- | ChannelCreate Channel- | ChannelUpdate Channel- | ChannelDelete Channel- | GuildCreate Guild- | GuildUpdate Guild- | GuildDelete Guild- | GuildBanAdd Member- | GuildBanRemove Member- | GuildEmojiUpdate Object- | GuildIntegrationsUpdate Object- | GuildMemberAdd Member- | GuildMemberRemove Member- | GuildMemberUpdate Member- | GuildMemberChunk Object- | GuildRoleCreate Object- | GuildRoleUpdate Object- | GuildRoleDelete Object- | MessageCreate Message- | MessageUpdate Message- | MessageDelete Object- | MessageDeleteBulk Object- | PresenceUpdate Object- | TypingStart Object- | UserSettingsUpdate Object- | UserUpdate Object- | VoiceStateUpdate Object- | VoiceServerUpdate Object- | UnknownEvent String Object- deriving Show-- -- |Parses JSON stuff by Discord to an event type.- parseDispatch :: Payload -> Either String Event- parseDispatch (Dispatch ob _ ev) = case ev of- "READY" -> Ready <$> reparse o- "RESUMED" -> Resumed <$> reparse o- "CHANNEL_CREATE" -> ChannelCreate <$> reparse o- "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o- "CHANNEL_DELETE" -> ChannelDelete <$> reparse o- "GUILD_CREATE" -> GuildCreate <$> reparse o- "GUILD_UPDATE" -> GuildUpdate <$> reparse o- "GUILD_DELETE" -> GuildDelete <$> reparse o- "GUILD_BAN_ADD" -> GuildBanAdd <$> reparse o- "GUILD_BAN_REMOVE" -> GuildBanRemove <$> reparse o- "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> reparse o- "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> reparse o- "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> reparse o- "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> reparse o- "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> reparse o- "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> reparse o- "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> reparse o- "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> reparse o- "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> reparse o- "MESSAGE_CREATE" -> MessageCreate <$> reparse o- "MESSAGE_UPDATE" -> MessageUpdate <$> reparse o- "MESSAGE_DELETE" -> MessageDelete <$> reparse o- "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> reparse o- "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o- "TYPING_START" -> TypingStart <$> reparse o- "USER_SETTINGS_UPDATE" -> UserSettingsUpdate <$> reparse o- "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o- "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o- _ -> UnknownEvent ev <$> reparse o- where o = Object ob- parseDispatch _ = error "Tried to parse non-Dispatch payload"-
− src/Network/Discord/Types/Gateway.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Data structures needed for interfacing with the Websocket--- Gateway-module Network.Discord.Types.Gateway where- import Control.Monad (mzero)- import System.Info-- import Data.Aeson- import Data.Aeson.Types- import Network.WebSockets-- import Network.Discord.Types.Prelude-- -- |Represents all sorts of things that we can send to Discord.- data Payload = Dispatch- Object- Integer- String- | Heartbeat- Integer- | Identify- Auth- Bool- Integer- (Int, Int)- | StatusUpdate- (Maybe Integer)- (Maybe String)- | VoiceStatusUpdate- {-# UNPACK #-} !Snowflake- !(Maybe Snowflake)- Bool- Bool- | Resume- String- String- Integer- | Reconnect- | RequestGuildMembers- {-# UNPACK #-} !Snowflake- String- Integer- | InvalidSession- | Hello- Int- | HeartbeatAck- | ParseError String- deriving Show-- instance FromJSON Payload where- parseJSON = withObject "payload" $ \o -> do- op <- o .: "op" :: Parser Int- case op of- 0 -> Dispatch <$> o .: "d" <*> o .: "s" <*> o .: "t"- 1 -> Heartbeat <$> o .: "d"- 7 -> return Reconnect- 9 -> return InvalidSession- 10 -> (\od -> Hello <$> od .: "heartbeat_interval") =<< o .: "d"- 11 -> return HeartbeatAck- _ -> mzero-- instance ToJSON Payload where- toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= i ]- toJSON (Identify token compress large shard) = object [- "op" .= (2 :: Int)- , "d" .= object [- "token" .= authToken token- , "properties" .= object [- "$os" .= os- , "$browser" .= ("discord.hs" :: String)- , "$device" .= ("discord.hs" :: String)- , "$referrer" .= ("" :: String)- , "$referring_domain" .= ("" :: String)- ]- , "compress" .= compress- , "large_threshold" .= large- , "shard" .= shard- ]- ]- toJSON (StatusUpdate idle game) = object [- "op" .= (3 :: Int)- , "d" .= object [- "idle_since" .= idle- , "game" .= object [- "name" .= game- ]- ]- ]- toJSON (VoiceStatusUpdate 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 guild query limit) = object [- "op" .= (8 :: Int)- , "d" .= object [- "guild_id" .= guild- , "query" .= query- , "limit" .= limit- ]- ]- toJSON _ = object []-- instance WebSocketsData Payload where- fromLazyByteString bs = case eitherDecode bs of- Right payload -> payload- Left reason -> ParseError reason- toLazyByteString = encode
− src/Network/Discord/Types/Guild.hs
@@ -1,238 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Types relating to Discord Guilds (servers)-module Network.Discord.Types.Guild where- import Data.Time.Clock-- import Data.Aeson- import Control.Applicative ((<|>))- import Control.Monad (mzero)-- import Network.Discord.Types.Channel- import Network.Discord.Types.Prelude-- -- |Representation of a guild member.- data Member = GuildMember {-# UNPACK #-} !Snowflake User- | MemberShort User (Maybe String) ![Snowflake]- deriving Show- instance FromJSON Member where- parseJSON (Object o) =- GuildMember <$> o .: "guild_id" <*> o .: "user"- parseJSON _ = mzero-- -- | Guilds in Discord represent a collection of users and channels into an isolated- -- "Server"- data Guild- = Guild - { guildId :: {-# UNPACK #-} !Snowflake -- ^ Gulid id- , guildName :: String -- ^ Guild name (2 - 100 chars)- , guildIcon :: String -- ^ Icon hash- , guildSplash :: String -- ^ Splash hash- , guildOwner :: !Snowflake -- ^ Guild owner id- , guildRegion :: String -- ^ Guild voice region- , guildAfkId :: !Snowflake -- ^ Id of afk channel- , guildAfkTimeout :: !Integer -- ^ Afk timeout in seconds- , guildEmbedEnabled :: !Bool -- ^ Is this guild embeddable?- , guildEmbedChannel :: !Snowflake -- ^ Id of embedded channel- , guildVerification :: !Integer -- ^ Level of verification- , guildNotification :: !Integer -- ^ Level of default notifications- , guildRoles :: [Role] -- ^ Array of 'Role' objects- , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects- }- | Unavailable - { guildId :: {-# UNPACK #-} !Snowflake- } deriving Show-- instance FromJSON Guild where- parseJSON (Object o) = do- short <- o .:? "unavailable" .!= False- if short- then Unavailable <$> o .: "id"- else- Guild <$> o .: "id"- <*> o .: "name"- <*> o .:? "icon" .!= ""- <*> o .:? "hash" .!= ""- <*> o .: "owner_id"- <*> o .: "region"- <*> o .:? "afk_channel_id" .!= 0- <*> o .:? "afk_timeout" .!= 0- <*> o .:? "embed_enabled" .!= False- <*> o .:? "embed_channel_id" .!= 0- <*> o .: "verification_level"- <*> o .: "default_message_notifications"- <*> o .: "roles"- <*> o .: "emojis"- parseJSON _ = mzero-- -- | Represents an emoticon (emoji)- data Emoji = Emoji- { emojiId :: {-# UNPACK #-} !Snowflake -- ^ The emoji id- , emojiName :: String -- ^ The emoji name- , emojiRoles :: ![Snowflake] -- ^ Roles the emoji is active for- , emojiManaged :: !Bool -- ^ Whether this emoji is managed- } deriving (Show)-- instance FromJSON Emoji where- parseJSON (Object o) =- Emoji <$> o .: "id"- <*> o .: "name"- <*> o .: "roles"- <*> o .: "managed"- parseJSON _ = mzero-- -- | 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 :: {-# UNPACK #-} !Snowflake -- ^ The role id- , roleName :: String -- ^ 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 (Object o) = Role- <$> o .: "id"- <*> o .: "name"- <*> o .: "color"- <*> o .: "hoist"- <*> o .: "position"- <*> o .: "permissions"- <*> o .: "managed"- <*> o .: "mentionable"- parseJSON _ = mzero- - -- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added- data VoiceRegion =- VoiceRegion- { regionId :: {-# UNPACK #-} !Snowflake -- ^ Unique id of the region- , regionName :: String -- ^ Name of the region- , regionHostname :: String -- ^ 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 (Object o) = VoiceRegion- <$> o .: "id"- <*> o .: "name"- <*> o .: "sample_hostname"- <*> o .: "sample_port"- <*> o .: "vip"- <*> o .: "optimal"- <*> o .: "deprecated"- <*> o .: "custom"- parseJSON _ = mzero-- -- | Represents a code to add a user to a guild- data Invite =- Invite {- inviteCode :: String -- ^ The invite code- , inviteGuild :: !Snowflake -- ^ The guild the code will invite to- , inviteChan :: !Snowflake -- ^ The channel the code will invite to- }- -- | Invite code with additional metadata- | InviteLong Invite InviteMeta-- instance FromJSON Invite where- parseJSON ob@(Object o) =- InviteLong <$> parseJSON ob <*> parseJSON ob- <|> Invite- <$> o .: "code"- <*> ((o .: "guild") >>= (.: "id"))- <*> ((o .: "channel") >>= (.: "id"))- parseJSON _ = mzero- - -- | 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 (Object o) = InviteMeta- <$> o .: "inviter"- <*> o .: "uses"- <*> o .: "max_uses"- <*> o .: "max_age"- <*> o .: "temporary"- <*> o .: "created_at"- <*> o .: "revoked"- parseJSON _ = mzero-- -- | Represents the behavior of a third party account link.- data Integration =- Integration- { integrationId :: {-# UNPACK #-} !Snowflake -- ^ Integration id- , integrationName :: String -- ^ Integration name- , integrationType :: String -- ^ 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 (Object 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"- parseJSON _ = mzero- - -- | Represents a third party account link.- data IntegrationAccount =- Account - { accountId :: String -- ^ The id of the account.- , accountName :: String -- ^ The name of the account.- } deriving (Show)-- instance FromJSON IntegrationAccount where- parseJSON (Object o) = Account- <$> o .: "id"- <*> o .: "name"- parseJSON _ = mzero-- -- | 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 :: {-# UNPACK #-} !Snowflake -- ^ The embed channel id- }- instance FromJSON GuildEmbed where- parseJSON (Object o) = GuildEmbed- <$> o .: "enabled"- <*> o .: "snowflake"- parseJSON _ = mzero-- instance ToJSON GuildEmbed where- toJSON (GuildEmbed enabled snowflake) = object- [ "enabled" .= enabled- , "snowflake" .= snowflake- ]
− src/Network/Discord/Types/Prelude.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, GeneralizedNewtypeDeriving #-}--- | Provides base types and utility functions needed for modules in Network.Discord.Types-module Network.Discord.Types.Prelude where- import Data.Bits- import Data.Word-- import Data.Aeson.Types- import Data.Hashable- import Data.Text- import Data.Time.Clock- import Data.Time.Clock.POSIX- import Control.Monad (mzero)-- -- | Authorization token for the Discord API- data Auth = Bot String- | Client String- | Bearer String- - -- | Formats the token for use with the REST API- instance Show Auth where- show (Bot token) = "Bot " ++ token- show (Client token) = token- show (Bearer token) = "Bearer " ++ token-- -- | Get the raw token formatted for use with the websocket gateway- authToken :: Auth -> String- authToken (Bot token) = token- authToken (Client token) = token- authToken (Bearer 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, Hashable)-- instance Show Snowflake where- show (Snowflake a) = show a-- instance ToJSON Snowflake where- toJSON (Snowflake snowflake) = String . pack $ show snowflake-- instance FromJSON Snowflake where- parseJSON (String snowflake) = Snowflake <$> (return . read $ 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-- -- | Delete a (key, value) pair if the key exists- delete :: Eq a => a -> [(a, b)] -> [(a, b)]- delete k ((x,y):xs)- | k == x = delete k xs- | otherwise = (x, y):delete k xs- delete _ [] = []- - -- | Insert or modify a (key, value) pair- insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]- insert k v s = (k, v):delete k s-- -- | Return only the Right vaule from an either- justRight :: (Show a) => Either a b -> b- justRight (Right b) = b- justRight (Left a) = error $ show a-- -- | Convert ToJSON values to FromJSON values- reparse :: (ToJSON a, FromJSON b) => a -> Either String b- reparse val = parseEither parseJSON $ toJSON val