diff --git a/discord-hs.cabal b/discord-hs.cabal --- a/discord-hs.cabal +++ b/discord-hs.cabal @@ -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 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 diff --git a/docs/Site.hs b/docs/Site.hs deleted file mode 100644 --- a/docs/Site.hs +++ /dev/null @@ -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 diff --git a/src/Network/Discord.hs b/src/Network/Discord.hs --- a/src/Network/Discord.hs +++ b/src/Network/Discord.hs @@ -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 diff --git a/src/Network/Discord/Framework.hs b/src/Network/Discord/Framework.hs --- a/src/Network/Discord/Framework.hs +++ b/src/Network/Discord/Framework.hs @@ -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) + diff --git a/src/Network/Discord/Gateway.hs b/src/Network/Discord/Gateway.hs deleted file mode 100644 --- a/src/Network/Discord/Gateway.hs +++ /dev/null @@ -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 - diff --git a/src/Network/Discord/Rest.hs b/src/Network/Discord/Rest.hs deleted file mode 100644 --- a/src/Network/Discord/Rest.hs +++ /dev/null @@ -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") diff --git a/src/Network/Discord/Rest/Channel.hs b/src/Network/Discord/Rest/Channel.hs deleted file mode 100644 --- a/src/Network/Discord/Rest/Channel.hs +++ /dev/null @@ -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 - 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 diff --git a/src/Network/Discord/Rest/Guild.hs b/src/Network/Discord/Rest/Guild.hs deleted file mode 100644 --- a/src/Network/Discord/Rest/Guild.hs +++ /dev/null @@ -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 - -- - 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 diff --git a/src/Network/Discord/Rest/HTTP.hs b/src/Network/Discord/Rest/HTTP.hs deleted file mode 100644 --- a/src/Network/Discord/Rest/HTTP.hs +++ /dev/null @@ -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 diff --git a/src/Network/Discord/Rest/Prelude.hs b/src/Network/Discord/Rest/Prelude.hs deleted file mode 100644 --- a/src/Network/Discord/Rest/Prelude.hs +++ /dev/null @@ -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 diff --git a/src/Network/Discord/Rest/User.hs b/src/Network/Discord/Rest/User.hs deleted file mode 100644 --- a/src/Network/Discord/Rest/User.hs +++ /dev/null @@ -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 - -- - 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 diff --git a/src/Network/Discord/Types.hs b/src/Network/Discord/Types.hs deleted file mode 100644 --- a/src/Network/Discord/Types.hs +++ /dev/null @@ -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 diff --git a/src/Network/Discord/Types/Channel.hs b/src/Network/Discord/Types/Channel.hs deleted file mode 100644 --- a/src/Network/Discord/Types/Channel.hs +++ /dev/null @@ -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) diff --git a/src/Network/Discord/Types/Events.hs b/src/Network/Discord/Types/Events.hs deleted file mode 100644 --- a/src/Network/Discord/Types/Events.hs +++ /dev/null @@ -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" - diff --git a/src/Network/Discord/Types/Gateway.hs b/src/Network/Discord/Types/Gateway.hs deleted file mode 100644 --- a/src/Network/Discord/Types/Gateway.hs +++ /dev/null @@ -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 diff --git a/src/Network/Discord/Types/Guild.hs b/src/Network/Discord/Types/Guild.hs deleted file mode 100644 --- a/src/Network/Discord/Types/Guild.hs +++ /dev/null @@ -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 - ] diff --git a/src/Network/Discord/Types/Prelude.hs b/src/Network/Discord/Types/Prelude.hs deleted file mode 100644 --- a/src/Network/Discord/Types/Prelude.hs +++ /dev/null @@ -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