diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for Calamity +## 0.1.24.0 + ++ Switch from using Wreq to Req ++ The `session` parameter has been removed from `runBotIO'` ++ Add an `Upgradeable` instance for `Role`s ++ Add a command `Parser` instance for `Role`s + ## 0.1.23.1 + Fix some more json parsing issues diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0772994714492feed4b5b795eb15b0795c3b76609b3e5675079f5b442d29687f +-- hash: 00a40615c76f1d2bb08dcb114163494c4189aa1e755216a1553cacaeba8bb83f name: calamity -version: 0.1.23.1 +version: 0.1.24.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -158,6 +158,7 @@ , generic-override >=0.0.0.0 && <0.0.1 , generic-override-aeson >=0.0.0.0 && <0.0.1 , hashable >=1.2 && <2 + , http-client >=0.5 && <0.8 , http-date >=0.0.8 && <0.1 , http-types >=0.12 && <0.13 , lens >=4.18 && <5 @@ -168,6 +169,7 @@ , polysemy >=1.3 && <2 , polysemy-plugin >=0.2 && <0.3 , reflection >=2.1 && <3 + , req >=3.1 && <3.9 , safe-exceptions >=0.1 && <2 , scientific >=0.3 && <0.4 , stm >=2.5 && <3 @@ -182,6 +184,5 @@ , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.13 , websockets >=0.12 && <0.13 - , wreq >=0.5 && <0.6 , wuss >=1.1 && <2 default-language: Haskell2010 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -57,8 +57,6 @@ import qualified Df1 import qualified DiPolysemy as Di -import Network.Wreq.Session ( Session, newAPISession ) - import Fmt import qualified Polysemy as P @@ -80,8 +78,8 @@ pure (duration, res) -newClient :: Token -> Session -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client -newClient token session initialDi = do +newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client +newClient token initialDi = do shards' <- newTVarIO [] numShards' <- newEmptyMVar rlState' <- newRateLimitState @@ -95,7 +93,6 @@ inc outc ehidCounter - session initialDi -- | Create a bot, run your setup action, and then loop until the bot closes. @@ -106,7 +103,7 @@ -- ^ The intents the bot should use -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) -runBotIO token intents setup = runBotIO' token intents Nothing Nothing setup +runBotIO token intents = runBotIO' token intents Nothing resetDi :: BotC r => P.Sem r a -> P.Sem r a resetDi m = do @@ -115,22 +112,19 @@ -- | Create a bot, run your setup action, and then loop until the bot closes. -- --- This version allows you to specify the http session, initial status, and intents. +-- This version allows you to specify the initial status, and intents. runBotIO' :: forall r a. (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) => Token -> Intents -- ^ The intents the bot should use - -> Maybe Session - -- ^ The HTTP session to use, defaults to 'newAPISession' -> Maybe StatusUpdateData -- ^ The initial status to send to the gateway -> P.Sem (SetupEff r) a -> P.Sem r (Maybe StartupError) -runBotIO' token intents session status setup = do +runBotIO' token intents status setup = do initialDi <- Di.fetch - session' <- maybe (P.embed newAPISession) pure session - client <- P.embed $ newClient token session' initialDi + client <- P.embed $ newClient token initialDi handlers <- P.embed $ newTVarIO def P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do void $ Di.push "calamity-setup" setup diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -45,8 +45,6 @@ import Data.Typeable import Data.Void -import Network.Wreq.Session ( Session ) - import GHC.Exts ( fromList ) import GHC.Generics @@ -68,7 +66,6 @@ , eventsIn :: InChan CalamityEvent , eventsOut :: OutChan CalamityEvent , ehidCounter :: IORef Integer - , session :: Session , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message) } deriving ( Generic ) diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -266,7 +266,7 @@ -- and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching -- from http. instance P.Member CacheEff r => Parser Guild r where - parse = parseMP (parserName @Guild @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) + parse = parseMP (parserName @Guild @r) $ mapParserMaybeM snowflake "Couldn't find a Guild with this id" getGuild @@ -274,7 +274,7 @@ -- looks in the cache. Use @'Snowflake' 'Emoji'@ and use -- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. instance Parser Emoji r where - parse = parseMP (parserName @Emoji @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) + parse = parseMP (parserName @Emoji @r) $ mapParserMaybeM (try emoji <|> snowflake) "Couldn't find an Emoji with this id" (\eid -> do ctx <- P.ask @@ -284,6 +284,16 @@ instance Parser RawEmoji r where parse = parseMP (parserName @RawEmoji) (try parseCustomEmoji <|> (UnicodeEmoji <$> takeP (Just "A unicode emoji") 1)) where parseCustomEmoji = CustomEmoji <$> partialEmoji + +-- | Parser for roles in the guild the command was invoked in, this only +-- looks in the cache. Use @'Snowflake' 'Role'@ and use +-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +instance Parser Role r where + parse = parseMP (parserName @Role @r) $ mapParserMaybeM (try (ping "@&") <|> snowflake) + "Couldn't find an Emoji with this id" + (\rid -> do + ctx <- P.ask + pure $ ctx ^? #guild . _Just . #roles . ix rid) instance (Parser a r, Parser b r) => Parser (a, b) r where type ParserResult (a, b) = (ParserResult a, ParserResult b) diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs --- a/src/Calamity/Gateway/Shard.hs +++ b/src/Calamity/Gateway/Shard.hs @@ -73,11 +73,9 @@ -> UC.InChan CalamityEvent -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) newShard gateway id count token presence intents evtIn = do - (cmdIn, stateVar) <- P.embed $ mdo - (cmdIn, cmdOut) <- UC.newChan - stateVar <- newIORef $ newShardState shard - let shard = Shard id count gateway evtIn cmdOut stateVar (rawToken token) presence intents - pure (cmdIn, stateVar) + (cmdIn, cmdOut) <- P.embed UC.newChan + let shard = Shard id count gateway evtIn cmdOut (rawToken token) presence intents + stateVar <- P.embed . newIORef $ newShardState shard let runShard = P.runAtomicStateIORef stateVar shardLoop let action = push "calamity-shard" . attr "shard-id" id $ runShard @@ -186,7 +184,7 @@ debug "Entering inner loop of shard" shard <- P.atomicGets (^. #shardS) - P.atomicModify (#wsConn ?~ ws) + P.atomicModify' (#wsConn ?~ ws) seqNum' <- P.atomicGets (^. #seqNum) sessionID' <- P.atomicGets (^. #sessionID) @@ -228,7 +226,7 @@ debug "Exiting inner loop of shard" - P.atomicModify (#wsConn .~ Nothing) + P.atomicModify' (#wsConn .~ Nothing) haltHeartBeat pure result @@ -237,11 +235,11 @@ handleMsg (Discord msg) = case msg of EvtDispatch sn data' -> do -- trace $ "Handling event: ("+||data'||+")" - P.atomicModify (#seqNum ?~ sn) + P.atomicModify' (#seqNum ?~ sn) case data' of Ready rdata' -> - P.atomicModify (#sessionID ?~ (rdata' ^. #sessionID)) + P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID)) _NotReady -> pure () @@ -262,8 +260,8 @@ info "Received resumable invalid session" else do info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" - P.atomicModify (#sessionID .~ Nothing) - P.atomicModify (#seqNum .~ Nothing) + P.atomicModify' (#sessionID .~ Nothing) + P.atomicModify' (#seqNum .~ Nothing) P.embed $ threadDelay (15 * 1000 * 1000) P.throw ShardFlowRestart @@ -273,7 +271,7 @@ HeartBeatAck -> do debug "Received heartbeat ack" - P.atomicModify (#hbResponse .~ True) + P.atomicModify' (#hbResponse .~ True) handleMsg (Control msg) = case msg of SendPresence data' -> do @@ -287,7 +285,7 @@ startHeartBeatLoop interval = do haltHeartBeat -- cancel any currently running hb thread thread <- P.async $ heartBeatLoop interval - P.atomicModify (#hbThread ?~ thread) + P.atomicModify' (#hbThread ?~ thread) haltHeartBeat :: ShardC r => Sem r () haltHeartBeat = do @@ -306,7 +304,7 @@ sn <- P.atomicGets (^. #seqNum) debug $ "Sending heartbeat (seq: " +|| sn ||+ ")" sendToWs $ HeartBeat sn - P.atomicModify (#hbResponse .~ False) + P.atomicModify' (#hbResponse .~ False) heartBeatLoop :: ShardC r => Int -> Sem r () heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs --- a/src/Calamity/Gateway/Types.hs +++ b/src/Calamity/Gateway/Types.hs @@ -31,7 +31,6 @@ import Data.Aeson import qualified Data.Aeson.Types as AT import Data.Generics.Labels () -import Data.IORef import Data.Maybe import Data.Text.Lazy ( Text ) @@ -272,7 +271,6 @@ , gateway :: Text , evtIn :: InChan CalamityEvent , cmdOut :: OutChan ControlMessage - , shardState :: IORef ShardState , token :: Text , initialStatus :: Maybe StatusUpdateData , intents :: Intents diff --git a/src/Calamity/HTTP/AuditLog.hs b/src/Calamity/HTTP/AuditLog.hs --- a/src/Calamity/HTTP/AuditLog.hs +++ b/src/Calamity/HTTP/AuditLog.hs @@ -1,34 +1,31 @@ -- | Audit Log endpoints -module Calamity.HTTP.AuditLog - ( AuditLogRequest(..) - , GetAuditLogOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +module Calamity.HTTP.AuditLog ( + AuditLogRequest (..), + GetAuditLogOptions (..), +) where -import Control.Lens -import Control.Arrow ( (>>>) ) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils () +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Data.Default.Class -import Data.Maybe ( maybeToList ) +import Control.Lens -import GHC.Generics +import Data.Default.Class -import Network.Wreq.Lens +import GHC.Generics -import TextShow ( showt ) +import TextShow (showt) data GetAuditLogOptions = GetAuditLogOptions - { userID :: Maybe (Snowflake User) + { userID :: Maybe (Snowflake User) , actionType :: Maybe AuditLogAction - , before :: Maybe (Snowflake AuditLogEntry) - , limit :: Maybe Integer + , before :: Maybe (Snowflake AuditLogEntry) + , limit :: Maybe Integer } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data AuditLogRequest a where GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog @@ -36,12 +33,15 @@ instance Request (AuditLogRequest a) where type Result (AuditLogRequest a) = a - route (GetAuditLog (getID @Guild -> gid) _) = mkRouteBuilder // S "guilds" // ID @Guild // S "audit-logs" - & giveID gid - & buildRoute + route (GetAuditLog (getID @Guild -> gid) _) = + mkRouteBuilder // S "guilds" // ID @Guild // S "audit-logs" + & giveID gid + & buildRoute - action (GetAuditLog _ GetAuditLogOptions { userID, actionType, before, limit }) = getWithP - (param "user_id" .~ maybeToList (showt <$> userID) >>> - param "action_type" .~ maybeToList (showt .fromEnum <$> actionType) >>> - param "before" .~ maybeToList (showt <$> before) >>> - param "limit" .~ maybeToList (showt <$> limit)) + action (GetAuditLog _ GetAuditLogOptions{userID, actionType, before, limit}) = + getWithP + ( "user_id" =:? (showt <$> userID) + <> "action_type" =:? (showt . fromEnum <$> actionType) + <> "before" =:? (showt <$> before) + <> "limit" =:? (showt <$> limit) + ) diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs --- a/src/Calamity/HTTP/Channel.hs +++ b/src/Calamity/HTTP/Channel.hs @@ -1,60 +1,51 @@ -- | Channel endpoints -module Calamity.HTTP.Channel - ( ChannelRequest(..) - , CreateMessageOptions(..) - , ChannelUpdate(..) - , AllowedMentionType(..) - , AllowedMentions(..) - , ChannelMessagesQuery(..) - , GetReactionsOptions(..) - , CreateChannelInviteOptions(..) - , GroupDMAddRecipientOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Arrow -import Control.Lens hiding ( (.=) ) - -import Data.Aeson -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Generics.Product.Subtype ( upcast ) -import Data.Maybe -import qualified Data.Text as S -import qualified Data.Text.Encoding as S -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq ( partLBS ) -import Network.Wreq.Lens -import Network.Wreq.Session -import Network.Mime +module Calamity.HTTP.Channel ( + ChannelRequest (..), + CreateMessageOptions (..), + ChannelUpdate (..), + AllowedMentionType (..), + AllowedMentions (..), + ChannelMessagesQuery (..), + GetReactionsOptions (..), + CreateChannelInviteOptions (..), + GroupDMAddRecipientOptions (..), +) where -import TextShow -import Network.HTTP.Types (urlEncode) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Default.Class +import Data.Generics.Product.Subtype (upcast) +import Data.Text (Text) +import qualified Data.Text as S +import GHC.Generics +import Network.HTTP.Req +import Network.Mime +import Network.HTTP.Client.MultipartFormData +import TextShow data CreateMessageOptions = CreateMessageOptions - { content :: Maybe Text - , nonce :: Maybe Text - , tts :: Maybe Bool - , file :: Maybe (Text, ByteString) - , embed :: Maybe Embed + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , file :: Maybe (Text, ByteString) + , embed :: Maybe Embed , allowedMentions :: Maybe AllowedMentions } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data AllowedMentionType = AllowedMentionRoles | AllowedMentionUsers | AllowedMentionEveryone - deriving ( Show, Generic ) + deriving (Show, Generic) instance ToJSON AllowedMentionType where toJSON AllowedMentionRoles = String "roles" @@ -66,8 +57,8 @@ , roles :: [Snowflake Role] , users :: [Snowflake User] } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON AllowedMentions + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON AllowedMentions instance Semigroup AllowedMentions where AllowedMentions p0 r0 u0 <> AllowedMentions p1 r1 u1 = @@ -78,26 +69,26 @@ data CreateMessageJson = CreateMessageJson { content :: Maybe Text - , nonce :: Maybe Text - , tts :: Maybe Bool - , embed :: Maybe Embed + , nonce :: Maybe Text + , tts :: Maybe Bool + , embed :: Maybe Embed } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateMessageJson + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON CreateMessageJson data ChannelUpdate = ChannelUpdate - { name :: Maybe Text - , position :: Maybe Int - , topic :: Maybe Text - , nsfw :: Maybe Bool - , rateLimitPerUser :: Maybe Int - , bitrate :: Maybe Int - , userLimit :: Maybe Int + { name :: Maybe Text + , position :: Maybe Int + , topic :: Maybe Text + , nsfw :: Maybe Bool + , rateLimitPerUser :: Maybe Int + , bitrate :: Maybe Int + , userLimit :: Maybe Int , permissionOverwrites :: Maybe [Overwrite] - , parentID :: Maybe (Snowflake Channel) + , parentID :: Maybe (Snowflake Channel) } - deriving ( Generic, Show, Default ) - deriving ( ToJSON ) via CalamityJSON ChannelUpdate + deriving (Generic, Show, Default) + deriving (ToJSON) via CalamityJSON ChannelUpdate data ChannelMessagesQuery = ChannelMessagesAround @@ -112,175 +103,197 @@ | ChannelMessagesLimit { limit :: Int } - deriving ( Generic, Show ) - deriving ( ToJSON ) via CalamityJSON ChannelMessagesQuery + deriving (Generic, Show) + deriving (ToJSON) via CalamityJSON ChannelMessagesQuery data GetReactionsOptions = GetReactionsOptions { before :: Maybe (Snowflake User) - , after :: Maybe (Snowflake User) - , limit :: Maybe Integer + , after :: Maybe (Snowflake User) + , limit :: Maybe Integer } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data CreateChannelInviteOptions = CreateChannelInviteOptions - { maxAge :: Maybe Int - , maxUses :: Maybe Int + { maxAge :: Maybe Int + , maxUses :: Maybe Int , temporary :: Maybe Bool - , unique :: Maybe Bool + , unique :: Maybe Bool } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON CreateChannelInviteOptions + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON CreateChannelInviteOptions data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions { accessToken :: Text - , nick :: Text + , nick :: Text } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON GroupDMAddRecipientOptions + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON GroupDMAddRecipientOptions data ChannelRequest a where - CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message - GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message - EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> ChannelRequest Message - DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest () - GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel - ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel - DeleteChannel :: (HasID Channel c) => c -> ChannelRequest () - GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesQuery -> ChannelRequest [Message] - CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () - DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () - DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest () - GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User] - DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite] - CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite - EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest () - DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest () - TriggerTyping :: (HasID Channel c) => c -> ChannelRequest () - GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message] - AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest () - GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest () - + CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message + GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message + EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> ChannelRequest Message + DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest () + GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel + ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel + DeleteChannel :: (HasID Channel c) => c -> ChannelRequest () + GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesQuery -> ChannelRequest [Message] + CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () + DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () + DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest () + GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User] + DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite] + CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite + EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest () + DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest () + TriggerTyping :: (HasID Channel c) => c -> ChannelRequest () + GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message] + AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest () + GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest () baseRoute :: Snowflake Channel -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "channels" // ID @Channel - & giveID id - -encodeEmoji :: RawEmoji -> S.Text -encodeEmoji = S.decodeUtf8 . urlEncode True . S.encodeUtf8 . showt +baseRoute id = + mkRouteBuilder // S "channels" // ID @Channel + & giveID id instance Request (ChannelRequest a) where type Result (ChannelRequest a) = a - route (CreateMessage (getID -> id) _) = baseRoute id // S "messages" - & buildRoute - route (GetChannel (getID -> id)) = baseRoute id - & buildRoute - route (ModifyChannel (getID -> id) _) = baseRoute id - & buildRoute - route (DeleteChannel (getID -> id)) = baseRoute id - & buildRoute - route (GetChannelMessages (getID -> id) _) = baseRoute id // S "messages" - & buildRoute - route (GetMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute + route (CreateMessage (getID -> id) _) = + baseRoute id // S "messages" + & buildRoute + route (GetChannel (getID -> id)) = + baseRoute id + & buildRoute + route (ModifyChannel (getID -> id) _) = + baseRoute id + & buildRoute + route (DeleteChannel (getID -> id)) = + baseRoute id + & buildRoute + route (GetChannelMessages (getID -> id) _) = + baseRoute id // S "messages" + & buildRoute + route (GetMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid // S "messages" // ID @Message + & giveID mid + & buildRoute route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" - & giveID mid - & buildRoute + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" + & giveID mid + & buildRoute route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" - & giveID mid - & buildRoute + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" + & giveID mid + & buildRoute route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // ID @User - & giveID mid - & giveID uid - & buildRoute + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // ID @User + & giveID mid + & giveID uid + & buildRoute route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) - & giveID mid - & buildRoute + baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) + & giveID mid + & buildRoute route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message // S "reactions" - & giveID mid - & buildRoute - route (EditMessage (getID -> cid) (getID @Message -> mid) _ _) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute - route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute - route (BulkDeleteMessages (getID -> cid) _) = baseRoute cid // S "messages" // S "bulk-delete" - & buildRoute - route (GetChannelInvites (getID -> cid)) = baseRoute cid // S "invites" - & buildRoute - route (CreateChannelInvite (getID -> cid) _) = baseRoute cid // S "invites" - & buildRoute + & giveID mid + & buildRoute + route (EditMessage (getID -> cid) (getID @Message -> mid) _ _) = + baseRoute cid // S "messages" // ID @Message + & giveID mid + & buildRoute + route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid // S "messages" // ID @Message + & giveID mid + & buildRoute + route (BulkDeleteMessages (getID -> cid) _) = + baseRoute cid // S "messages" // S "bulk-delete" + & buildRoute + route (GetChannelInvites (getID -> cid)) = + baseRoute cid // S "invites" + & buildRoute + route (CreateChannelInvite (getID -> cid) _) = + baseRoute cid // S "invites" + & buildRoute route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute + & giveID oid + & buildRoute route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute - route (TriggerTyping (getID -> cid)) = baseRoute cid // S "typing" - & buildRoute - route (GetPinnedMessages (getID -> cid)) = baseRoute cid // S "pins" - & buildRoute - route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute - route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute - route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute - route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute + & giveID oid + & buildRoute + route (TriggerTyping (getID -> cid)) = + baseRoute cid // S "typing" + & buildRoute + route (GetPinnedMessages (getID -> cid)) = + baseRoute cid // S "pins" + & buildRoute + route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid // S "pins" // ID @Message + & giveID mid + & buildRoute + route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid // S "pins" // ID @Message + & giveID mid + & buildRoute + route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = + baseRoute cid // S "recipients" // ID @User + & giveID uid + & buildRoute + route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = + baseRoute cid // S "recipients" // ID @User + & giveID uid + & buildRoute - action (CreateMessage _ o@CreateMessageOptions { file = Nothing }) = postWith' - (toJSON . upcast @CreateMessageJson $ o) - action (CreateMessage _ o@CreateMessageOptions { file = Just f }) = postWith' - [partLBS @IO "file" (snd f) & partFileName ?~ (S.unpack $ fst f) & partContentType ?~ defaultMimeLookup (fst f), - partLBS "payload_json" (encode . upcast @CreateMessageJson $ o)] + action (CreateMessage _ o@CreateMessageOptions{file = Nothing}) = + postWith' + (ReqBodyJson . upcast @CreateMessageJson $ o) + action (CreateMessage _ cm@CreateMessageOptions{file = Just f}) = \u o -> do + let filePart = + (partLBS @IO "file" (snd f)) + { partFilename = Just (S.unpack $ fst f) + , partContentType = Just (defaultMimeLookup $ fst f) + } + body <- reqBodyMultipart [filePart, partLBS "payload_json" (encode . upcast @CreateMessageJson $ cm)] + postWith' body u o action (GetChannel _) = getWith - action (ModifyChannel _ p) = putWith' (toJSON p) + action (ModifyChannel _ p) = putWith' (ReqBodyJson p) action (DeleteChannel _) = deleteWith - action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = getWithP - (param "around" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = getWithP - (param "before" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a)))) = getWithP - (param "after" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesLimit (showt -> a)))) = getWithP (param "around" .~ [a]) + action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = + getWithP ("around" =: a) + action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = + getWithP ("before" =: a) + action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a)))) = + getWithP ("after" =: a) + action (GetChannelMessages _ (Just (ChannelMessagesLimit (showt -> a)))) = getWithP ("around" =: a) action (GetChannelMessages _ Nothing) = getWith action (GetMessage _ _) = getWith - action CreateReaction {} = putEmpty - action DeleteOwnReaction {} = deleteWith - action DeleteUserReaction {} = deleteWith - action (GetReactions _ _ _ GetReactionsOptions { before, after, limit }) = getWithP - (param "before" .~ maybeToList (showt <$> before) >>> - param "after" .~ maybeToList (showt <$> after) >>> - param "limit" .~ maybeToList (showt <$> limit)) + action CreateReaction{} = putEmpty + action DeleteOwnReaction{} = deleteWith + action DeleteUserReaction{} = deleteWith + action (GetReactions _ _ _ GetReactionsOptions{before, after, limit}) = + getWithP + ( "before" =:? (showt <$> before) + <> "after" =:? (showt <$> after) + <> "limit" =:? (showt <$> limit) + ) action (DeleteAllReactions _ _) = deleteWith - action (EditMessage _ _ content embed) = patchWith' (object ["content" .= content, "embed" .= embed]) + action (EditMessage _ _ content embed) = patchWith' (ReqBodyJson $ object ["content" .= content, "embed" .= embed]) action (DeleteMessage _ _) = deleteWith - action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (object ["messages" .= ids]) + action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ object ["messages" .= ids]) action (GetChannelInvites _) = getWith - action (CreateChannelInvite _ o) = postWith' (toJSON o) - action (EditChannelPermissions _ o) = putWith' (toJSON o) + action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o) + action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o) action (DeleteChannelPermission _ _) = deleteWith action (TriggerTyping _) = postEmpty action (GetPinnedMessages _) = getWith action (AddPinnedMessage _ _) = putEmpty action (DeletePinnedMessage _ _) = deleteWith - action (GroupDMAddRecipient _ _ o) = putWith' (toJSON o) + action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o) action (GroupDMRemoveRecipient _ _) = deleteWith diff --git a/src/Calamity/HTTP/Emoji.hs b/src/Calamity/HTTP/Emoji.hs --- a/src/Calamity/HTTP/Emoji.hs +++ b/src/Calamity/HTTP/Emoji.hs @@ -1,46 +1,46 @@ -- | Emoji endpoints -module Calamity.HTTP.Emoji - ( EmojiRequest(..) - , CreateGuildEmojiOptions(..) - , ModifyGuildEmojiOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake +module Calamity.HTTP.Emoji ( + EmojiRequest (..), + CreateGuildEmojiOptions (..), + ModifyGuildEmojiOptions (..), +) where -import Data.Aeson -import Data.Function -import Data.Text ( Text ) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake -import GHC.Generics +import Data.Aeson +import Data.Function +import Data.Text (Text) -import Network.Wreq.Session +import GHC.Generics +import Network.HTTP.Req data CreateGuildEmojiOptions = CreateGuildEmojiOptions - { name :: Text + { name :: Text , image :: Text , roles :: [Snowflake Role] } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateGuildEmojiOptions + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON CreateGuildEmojiOptions data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions - { name :: Text + { name :: Text , roles :: [Snowflake Role] } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildEmojiOptions + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON ModifyGuildEmojiOptions data EmojiRequest a where - ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji] - GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji - CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji + ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji] + GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji + CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji ModifyGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> ModifyGuildEmojiOptions -> EmojiRequest Emoji - DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest () + DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest () baseRoute :: Snowflake Guild -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id @@ -49,19 +49,22 @@ type Result (EmojiRequest a) = a route (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute - route (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute + route (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute route (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute - route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute - route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute + route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute + route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute - action (ListGuildEmojis _) = getWith - action (GetGuildEmoji _ _) = getWith - action (CreateGuildEmoji _ o) = postWith' (toJSON o) - action (ModifyGuildEmoji _ _ o) = patchWith' (toJSON o) - action (DeleteGuildEmoji _ _) = deleteWith + action (ListGuildEmojis _) = getWith + action (GetGuildEmoji _ _) = getWith + action (CreateGuildEmoji _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildEmoji _ _ o) = patchWith' (ReqBodyJson o) + action (DeleteGuildEmoji _ _) = deleteWith diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs --- a/src/Calamity/HTTP/Guild.hs +++ b/src/Calamity/HTTP/Guild.hs @@ -1,289 +1,315 @@ -- | Guild endpoints -module Calamity.HTTP.Guild - ( GuildRequest(..) - , CreateGuildData(..) - , ModifyGuildData(..) - , ChannelCreateData(..) - , ChannelPosition(..) - , ListMembersOptions(..) - , AddGuildMemberData(..) - , ModifyGuildMemberData(..) - , CreateGuildBanData(..) - , ModifyGuildRoleData(..) - , ModifyGuildRolePositionsData(..) ) where +module Calamity.HTTP.Guild ( + GuildRequest (..), + CreateGuildData (..), + ModifyGuildData (..), + ChannelCreateData (..), + ChannelPosition (..), + ListMembersOptions (..), + AddGuildMemberData (..), + ModifyGuildMemberData (..), + CreateGuildBanData (..), + ModifyGuildRoleData (..), + ModifyGuildRolePositionsData (..), +) where -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour () -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice -import Calamity.Types.Snowflake +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Internal.IntColour () +import Calamity.Internal.Utils () +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake -import Control.Arrow -import Control.Lens hiding ( (.=) ) +import Control.Lens hiding ((.=)) -import Data.Aeson -import Data.Aeson.Lens -import Data.Colour ( Colour ) -import Data.Default.Class -import Data.Maybe -import Data.Text ( Text ) +import Data.Aeson +import Data.Aeson.Lens +import Data.Colour (Colour) +import Data.Default.Class +import Data.Text (Text) -import GHC.Generics +import GHC.Generics -import Network.Wreq.Lens -import Network.Wreq.Session +import Network.HTTP.Req -import TextShow +import TextShow data CreateGuildData = CreateGuildData - { name :: Text - , region :: Text - , icon :: Text - , verificationLevel :: Integer -- TODO: enums for these + { name :: Text + , region :: Text + , icon :: Text + , verificationLevel :: Integer -- TODO: enums for these , defaultMessageNotifications :: Integer - , explicitContentFilter :: Integer - , roles :: [Role] - , channels :: [Partial Channel] + , explicitContentFilter :: Integer + , roles :: [Role] + , channels :: [Partial Channel] } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateGuildData + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON CreateGuildData data ModifyGuildData = ModifyGuildData - { name :: Maybe Text - , region :: Maybe Text - , icon :: Maybe Text - , verificationLevel :: Maybe Integer -- TODO: enums for these + { name :: Maybe Text + , region :: Maybe Text + , icon :: Maybe Text + , verificationLevel :: Maybe Integer -- TODO: enums for these , defaultMessageNotifications :: Maybe Integer - , explicitContentFilter :: Maybe Integer - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Maybe Integer - , ownerID :: Maybe (Snowflake User) - , splash :: Maybe Text - , banner :: Maybe Text - , systemChannelID :: Maybe (Snowflake GuildChannel) + , explicitContentFilter :: Maybe Integer + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Maybe Integer + , ownerID :: Maybe (Snowflake User) + , splash :: Maybe Text + , banner :: Maybe Text + , systemChannelID :: Maybe (Snowflake GuildChannel) } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON ModifyGuildData data ChannelCreateData = ChannelCreateData - { name :: Text - , type_ :: Maybe ChannelType - , topic :: Maybe Text - , bitrate :: Maybe Integer - , userLimit :: Maybe Integer - , rateLimitPerUser :: Maybe Integer - , position :: Maybe Integer + { name :: Text + , type_ :: Maybe ChannelType + , topic :: Maybe Text + , bitrate :: Maybe Integer + , userLimit :: Maybe Integer + , rateLimitPerUser :: Maybe Integer + , position :: Maybe Integer , permissionOverwrites :: Maybe [Overwrite] - , parentID :: Maybe (Snowflake Category) - , nsfw :: Maybe Bool + , parentID :: Maybe (Snowflake Category) + , nsfw :: Maybe Bool } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ChannelCreateData + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON ChannelCreateData data ChannelPosition = ChannelPosition - { id :: Snowflake GuildChannel + { id :: Snowflake GuildChannel , position :: Maybe Integer } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ChannelPosition + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON ChannelPosition data ListMembersOptions = ListMembersOptions { limit :: Maybe Integer , after :: Maybe (Snowflake User) } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data AddGuildMemberData = AddGuildMemberData { accessToken :: Text - , nick :: Maybe Text - , roles :: Maybe [Snowflake Role] - , mute :: Maybe Bool - , deaf :: Maybe Bool + , nick :: Maybe Text + , roles :: Maybe [Snowflake Role] + , mute :: Maybe Bool + , deaf :: Maybe Bool } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON AddGuildMemberData + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON AddGuildMemberData data ModifyGuildMemberData = ModifyGuildMemberData - { nick :: Maybe Text - , roles :: Maybe [Snowflake Role] - , mute :: Maybe Bool - , deaf :: Maybe Bool + { nick :: Maybe Text + , roles :: Maybe [Snowflake Role] + , mute :: Maybe Bool + , deaf :: Maybe Bool , channelID :: Maybe (Snowflake VoiceChannel) } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildMemberData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON ModifyGuildMemberData data CreateGuildBanData = CreateGuildBanData { deleteMessageDays :: Maybe Integer - , reason :: Maybe Text + , reason :: Maybe Text } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data ModifyGuildRoleData = ModifyGuildRoleData - { name :: Maybe Text + { name :: Maybe Text , permissions :: Maybe Permissions - , color :: Maybe (Colour Double) - , hoist :: Maybe Bool + , color :: Maybe (Colour Double) + , hoist :: Maybe Bool , mentionable :: Maybe Bool } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildRoleData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON ModifyGuildRoleData data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData - { id :: Snowflake Role + { id :: Snowflake Role , position :: Maybe Integer } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildRolePositionsData + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON ModifyGuildRolePositionsData data GuildRequest a where - CreateGuild :: CreateGuildData -> GuildRequest Guild - GetGuild :: HasID Guild g => g -> GuildRequest Guild - ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild - DeleteGuild :: HasID Guild g => g -> GuildRequest () - GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel] - CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel - ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest () - GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member - ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member] - AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member) - ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest () - ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest () - AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () - RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () - RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildBans :: HasID Guild g => g -> GuildRequest [BanData] - GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData - CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest () - RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role] - CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role - ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] - ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role - DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest () - GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer - BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer) - GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion] - GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite] + CreateGuild :: CreateGuildData -> GuildRequest Guild + GetGuild :: HasID Guild g => g -> GuildRequest Guild + ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild + DeleteGuild :: HasID Guild g => g -> GuildRequest () + GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel] + CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel + ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest () + GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member + ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member] + AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member) + ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest () + ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest () + AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () + RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () + RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () + GetGuildBans :: HasID Guild g => g -> GuildRequest [BanData] + GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData + CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest () + RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () + GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role] + CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role + ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] + ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role + DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest () + GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer + BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer) + GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion] + GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite] baseRoute :: Snowflake Guild -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild - & giveID id +baseRoute id = + mkRouteBuilder // S "guilds" // ID @Guild + & giveID id instance Request (GuildRequest a) where type Result (GuildRequest a) = a - route (CreateGuild _) = mkRouteBuilder // S "guilds" - & buildRoute - route (GetGuild (getID -> gid)) = baseRoute gid - & buildRoute - route (ModifyGuild (getID -> gid) _) = baseRoute gid - & buildRoute - route (DeleteGuild (getID -> gid)) = baseRoute gid - & buildRoute - route (GetGuildChannels (getID -> gid)) = baseRoute gid // S "channels" - & buildRoute - route (CreateGuildChannel (getID -> gid) _) = baseRoute gid // S "channels" - & buildRoute - route (ModifyGuildChannelPositions (getID -> gid) _) = baseRoute gid // S "channels" - & buildRoute - route (GetGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ListGuildMembers (getID -> gid) _) = baseRoute gid // S "members" - & buildRoute - route (AddGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ModifyCurrentUserNick (getID -> gid) _) = baseRoute gid // S "members" // S "@me" // S "nick" - & buildRoute + route (CreateGuild _) = + mkRouteBuilder // S "guilds" + & buildRoute + route (GetGuild (getID -> gid)) = + baseRoute gid + & buildRoute + route (ModifyGuild (getID -> gid) _) = + baseRoute gid + & buildRoute + route (DeleteGuild (getID -> gid)) = + baseRoute gid + & buildRoute + route (GetGuildChannels (getID -> gid)) = + baseRoute gid // S "channels" + & buildRoute + route (CreateGuildChannel (getID -> gid) _) = + baseRoute gid // S "channels" + & buildRoute + route (ModifyGuildChannelPositions (getID -> gid) _) = + baseRoute gid // S "channels" + & buildRoute + route (GetGuildMember (getID -> gid) (getID @User -> uid)) = + baseRoute gid // S "members" // ID @User + & giveID uid + & buildRoute + route (ListGuildMembers (getID -> gid) _) = + baseRoute gid // S "members" + & buildRoute + route (AddGuildMember (getID -> gid) (getID @User -> uid) _) = + baseRoute gid // S "members" // ID @User + & giveID uid + & buildRoute + route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = + baseRoute gid // S "members" // ID @User + & giveID uid + & buildRoute + route (ModifyCurrentUserNick (getID -> gid) _) = + baseRoute gid // S "members" // S "@me" // S "nick" + & buildRoute route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute + & giveID uid + & giveID rid + & buildRoute route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute - route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (GetGuildBans (getID -> gid)) = baseRoute gid // S "bans" - & buildRoute - route (GetGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (GetGuildRoles (getID -> gid)) = baseRoute gid // S "roles" - & buildRoute - route (CreateGuildRole (getID -> gid) _) = baseRoute gid // S "roles" - & buildRoute - route (ModifyGuildRolePositions (getID -> gid) _) = baseRoute gid // S "roles" - & buildRoute - route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute - route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute - route (GetGuildPruneCount (getID -> gid) _) = baseRoute gid // S "prune" - & buildRoute - route (BeginGuildPrune (getID -> gid) _ _) = baseRoute gid // S "prune" - & buildRoute - route (GetGuildVoiceRegions (getID -> gid)) = baseRoute gid // S "regions" - & buildRoute - route (GetGuildInvites (getID -> gid)) = baseRoute gid // S "invites" - & buildRoute + & giveID uid + & giveID rid + & buildRoute + route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = + baseRoute gid // S "members" // ID @User + & giveID uid + & buildRoute + route (GetGuildBans (getID -> gid)) = + baseRoute gid // S "bans" + & buildRoute + route (GetGuildBan (getID -> gid) (getID @User -> uid)) = + baseRoute gid // S "bans" // ID @User + & giveID uid + & buildRoute + route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = + baseRoute gid // S "bans" // ID @User + & giveID uid + & buildRoute + route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = + baseRoute gid // S "bans" // ID @User + & giveID uid + & buildRoute + route (GetGuildRoles (getID -> gid)) = + baseRoute gid // S "roles" + & buildRoute + route (CreateGuildRole (getID -> gid) _) = + baseRoute gid // S "roles" + & buildRoute + route (ModifyGuildRolePositions (getID -> gid) _) = + baseRoute gid // S "roles" + & buildRoute + route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = + baseRoute gid // S "roles" // ID @Role + & giveID rid + & buildRoute + route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = + baseRoute gid // S "roles" // ID @Role + & giveID rid + & buildRoute + route (GetGuildPruneCount (getID -> gid) _) = + baseRoute gid // S "prune" + & buildRoute + route (BeginGuildPrune (getID -> gid) _ _) = + baseRoute gid // S "prune" + & buildRoute + route (GetGuildVoiceRegions (getID -> gid)) = + baseRoute gid // S "regions" + & buildRoute + route (GetGuildInvites (getID -> gid)) = + baseRoute gid // S "invites" + & buildRoute - action (CreateGuild o) = postWith' (toJSON o) + action (CreateGuild o) = postWith' (ReqBodyJson o) action (GetGuild _) = getWith - action (ModifyGuild _ o) = patchWith' (toJSON o) + action (ModifyGuild _ o) = patchWith' (ReqBodyJson o) action (DeleteGuild _) = deleteWith action (GetGuildChannels _) = getWith - action (CreateGuildChannel _ o) = postWith' (toJSON o) - action (ModifyGuildChannelPositions _ o) = postWith' (toJSON o) + action (CreateGuildChannel _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildChannelPositions _ o) = postWith' (ReqBodyJson o) action (GetGuildMember _ _) = getWith - action (ListGuildMembers _ ListMembersOptions { limit, after }) = getWithP - (param "limit" .~ maybeToList (showt <$> limit) >>> param "after" .~ maybeToList (showt <$> after)) - action (AddGuildMember _ _ o) = putWith' (toJSON o) - action (ModifyGuildMember _ _ o) = patchWith' (toJSON o) - action (ModifyCurrentUserNick _ nick) = patchWith' (object ["nick" .= nick]) - action (AddGuildMemberRole {}) = putEmpty - action (RemoveGuildMemberRole {}) = deleteWith + action (ListGuildMembers _ ListMembersOptions{limit, after}) = + getWithP + ("limit" =:? (showt <$> limit) <> "after" =:? (showt <$> after)) + action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o) + action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o) + action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick]) + action AddGuildMemberRole{} = putEmpty + action RemoveGuildMemberRole{} = deleteWith action (RemoveGuildMember _ _) = deleteWith action (GetGuildBans _) = getWith action (GetGuildBan _ _) = getWith - action (CreateGuildBan _ _ CreateGuildBanData { deleteMessageDays, reason }) = putEmptyP - (param "delete-message-days" .~ maybeToList (showt <$> deleteMessageDays) >>> param "reason" .~ maybeToList - (showt <$> reason)) + action (CreateGuildBan _ _ CreateGuildBanData{deleteMessageDays, reason}) = + putEmptyP + ("delete-message-days" =:? (showt <$> deleteMessageDays) <> "reason" =:? (showt <$> reason)) action (RemoveGuildBan _ _) = deleteWith action (GetGuildRoles _) = getWith - action (CreateGuildRole _ o) = postWith' (toJSON o) - action (ModifyGuildRolePositions _ o) = patchWith' (toJSON o) - action (ModifyGuildRole _ _ o) = patchWith' (toJSON o) + action (CreateGuildRole _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildRolePositions _ o) = patchWith' (ReqBodyJson o) + action (ModifyGuildRole _ _ o) = patchWith' (ReqBodyJson o) action (DeleteGuildRole _ _) = deleteWith - action (GetGuildPruneCount _ d) = getWithP (param "days" .~ [showt d]) - action (BeginGuildPrune _ d r) = postEmptyP (param "days" .~ [showt d] >>> param "compute_prune_count" .~ [showt r]) + action (GetGuildPruneCount _ d) = getWithP ("days" =: d) + action (BeginGuildPrune _ d r) = postEmptyP ("days" =: d <> "compute_prune_count" =: r) action (GetGuildVoiceRegions _) = getWith action (GetGuildInvites _) = getWith -- this is a bit of a hack -- TODO: add something to allow for contextual parsing - modifyResponse (GetGuildMember (getID @Guild -> gid) _) = _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) - modifyResponse (ListGuildMembers (getID @Guild -> gid) _) = values . _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) + modifyResponse (GetGuildMember (getID @Guild -> gid) _) = _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) + modifyResponse (ListGuildMembers (getID @Guild -> gid) _) = values . _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) modifyResponse _ = Prelude.id diff --git a/src/Calamity/HTTP/Internal/Ratelimit.hs b/src/Calamity/HTTP/Internal/Ratelimit.hs --- a/src/Calamity/HTTP/Internal/Ratelimit.hs +++ b/src/Calamity/HTTP/Internal/Ratelimit.hs @@ -1,117 +1,122 @@ -- | Module containing ratelimit stuff -module Calamity.HTTP.Internal.Ratelimit - ( newRateLimitState - , doRequest ) where +module Calamity.HTTP.Internal.Ratelimit ( + newRateLimitState, + doRequest, +) where -import Calamity.Client.Types ( BotC ) -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types -import Calamity.Internal.Utils +import Calamity.Client.Types (BotC) +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types +import Calamity.Internal.Utils -import Control.Concurrent -import Control.Concurrent.Event ( Event ) -import qualified Control.Concurrent.Event as E -import Control.Concurrent.STM -import Control.Concurrent.STM.Lock ( Lock ) -import qualified Control.Concurrent.STM.Lock as L -import Control.Lens -import Control.Monad +import Control.Concurrent +import Control.Concurrent.Event (Event) +import qualified Control.Concurrent.Event as E +import Control.Concurrent.STM +import Control.Concurrent.STM.Lock (Lock) +import qualified Control.Concurrent.STM.Lock as L +import Control.Lens +import Control.Monad -import Data.Aeson -import Data.Aeson.Lens -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as LB -import Data.Functor -import Data.Maybe -import qualified Data.Text.Lazy as LT -import Data.Time -import Data.Time.Clock.POSIX +import Data.Aeson +import Data.Aeson.Lens +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Functor +import Data.Maybe +import qualified Data.Text.Lazy as LT +import Data.Time +import Data.Time.Clock.POSIX -import Fmt +import Fmt -import Focus +import Focus -import Network.HTTP.Date -import Network.HTTP.Types hiding ( statusCode ) -import Network.Wreq +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Date +import Network.HTTP.Req +import Network.HTTP.Types -import qualified Polysemy as P -import Polysemy ( Sem ) -import qualified Polysemy.Async as P +import Polysemy (Sem) +import qualified Polysemy as P +import qualified Polysemy.Async as P -import Prelude hiding ( error ) +import Prelude hiding (error) -import qualified StmContainers.Map as SC import qualified Control.Exception.Safe as Ex +import qualified StmContainers.Map as SC newRateLimitState :: IO RateLimitState newRateLimitState = RateLimitState <$> SC.newIO <*> E.newSet lookupOrInsertDefaultM :: Monad m => m a -> Focus a m a -lookupOrInsertDefaultM aM = casesM - (do a <- aM - pure (a, Set a)) - (\a -> pure (a, Leave)) +lookupOrInsertDefaultM aM = + casesM + ( do + a <- aM + pure (a, Set a) + ) + (\a -> pure (a, Leave)) getRateLimit :: RateLimitState -> Route -> STM Lock getRateLimit s h = SC.focus (lookupOrInsertDefaultM L.new) h (rateLimits s) -doDiscordRequest :: BotC r => IO (Response LB.ByteString) -> Sem r DiscordResponseType +doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType doDiscordRequest r = do r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException) case r'' of Right r' -> do - let status = r' ^. responseStatus + let status = responseStatus . toVanillaResponse $ r' if - | statusIsSuccessful status -> do - let resp = r' ^. responseBody - debug $ "Got good response from discord: " +|| r' ^. responseStatus ||+ "" - pure $ if isExhausted r' + | statusIsSuccessful status -> do + let resp = responseBody r' + debug $ "Got good response from discord: " +|| status ||+ "" + pure $ + if isExhausted r' then case parseRateLimitHeader r' of - Just sleepTime -> ExhaustedBucket resp sleepTime - Nothing -> ServerError (status ^. statusCode) + Just sleepTime -> ExhaustedBucket resp sleepTime + Nothing -> ServerError (statusCode status) else Good resp - | status == status429 -> do - debug "Got 429 from discord, retrying." - case asValue r' of - Just rv -> pure $ Ratelimited (parseRetryAfter rv) (isGlobal rv) - Nothing -> pure $ ClientError (status ^. statusCode) "429 with invalid json???" - | statusIsClientError status -> do - let err = r' ^. responseBody - error $ "Something went wrong: " +|| err ||+ " response: " +|| r' ||+ "" - pure $ ClientError (status ^. statusCode) err - | otherwise -> do - debug $ "Got server error from discord: " +| status ^. statusCode |+ "" - pure $ ServerError (status ^. statusCode) + | status == status429 -> do + debug "Got 429 from discord, retrying." + let resp = responseBody r' + case resp ^? _Value of + Just rv -> pure $ Ratelimited (parseRetryAfter rv) (isGlobal rv) + Nothing -> pure $ ClientError (statusCode status) "429 with invalid json???" + | statusIsClientError status -> do + let err = responseBody r' + error $ "Something went wrong: " +|| err ||+ " response: " +|| r' ||+ "" + pure $ ClientError (statusCode status) err + | otherwise -> do + debug $ "Got server error from discord: " +| statusCode status |+ "" + pure $ ServerError (statusCode status) Left e -> do error $ "Something went wrong with the http client: " +| LT.pack e |+ "" pure . InternalResponseError $ LT.pack e - parseDiscordTime :: ByteString -> Maybe UTCTime parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s computeDiscordTimeDiff :: Double -> UTCTime -> Int computeDiscordTimeDiff end now = round . (* 1000.0) $ diffUTCTime end' now - where end' = end & toRational & fromRational & posixSecondsToUTCTime + where + end' = end & toRational & fromRational & posixSecondsToUTCTime -- | Parse a ratelimit header returning the number of milliseconds until it resets -parseRateLimitHeader :: Response a -> Maybe Int -parseRateLimitHeader r = computeDiscordTimeDiff end <$> now +parseRateLimitHeader :: HttpResponse r => r -> Maybe Int +parseRateLimitHeader r = computeDiscordTimeDiff <$> end <*> now where - end = r ^?! responseHeader "X-Ratelimit-Reset" . _Double - now = r ^?! responseHeader "Date" & parseDiscordTime - -isExhausted :: Response a -> Bool -isExhausted r = r ^? responseHeader "X-RateLimit-Remaining" == Just "0" + end = responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double + now = parseDiscordTime =<< responseHeader r "Date" -parseRetryAfter :: Response Value -> Int -parseRetryAfter r = - r ^?! responseBody . key "retry_after" . _Integral +isExhausted :: HttpResponse r => r -> Bool +isExhausted r = responseHeader r "X-RateLimit-Remaining" == Just "0" -isGlobal :: Response Value -> Bool -isGlobal r = r ^? responseBody . key "global" . _Bool == Just True +parseRetryAfter :: Value -> Int +parseRetryAfter r = r ^?! key "retry_after" . _Integral +isGlobal :: Value -> Bool +isGlobal r = r ^? key "global" . _Bool == Just True -- Either (Either a a) b data ShouldRetry a b @@ -119,12 +124,15 @@ | RFail a | RGood b -retryRequest - :: BotC r - => Int -- ^ number of retries - -> Sem r (ShouldRetry a b) -- ^ action to perform - -> Sem r () -- ^ action to run if max number of retries was reached - -> Sem r (Either a b) +retryRequest :: + BotC r => + -- | number of retries + Int -> + -- | action to perform + Sem r (ShouldRetry a b) -> + -- | action to run if max number of retries was reached + Sem r () -> + Sem r (Either a b) retryRequest max_retries action failAction = retryInner 0 where retryInner num_retries = do @@ -138,25 +146,27 @@ debug "Request failed due to error response." doFail $ Left r RGood r -> pure $ Right r - where doFail v = failAction $> v - + where + doFail v = failAction $> v -- Run a single request -- NOTE: this function will only unlock the ratelimit lock if the request -- gave a response, otherwise it will stay locked so that it can be retried again -doSingleRequest - :: BotC r - => Event -- ^ Global lock - -> Lock -- ^ Local lock - -> IO (Response LB.ByteString) -- ^ Request action - -> Sem r (ShouldRetry RestError LB.ByteString) +doSingleRequest :: + BotC r => + -- | Global lock + Event -> + -- | Local lock + Lock -> + -- | Request action + IO LbsResponse -> + Sem r (ShouldRetry RestError LB.ByteString) doSingleRequest gl l r = do r' <- doDiscordRequest r case r' of Good v -> do P.embed . atomically $ L.release l pure $ RGood v - ExhaustedBucket v d -> do debug $ "Exhausted bucket, unlocking after " +| d |+ "ms" void . P.async $ do @@ -165,12 +175,10 @@ atomically $ L.release l debug "unlocking bucket" pure $ RGood v - Ratelimited d False -> do debug $ "429 ratelimited on route, sleeping for " +| d |+ " ms" P.embed . threadDelay $ 1000 * d pure $ Retry (HTTPError 429 Nothing) - Ratelimited d True -> do debug "429 ratelimited globally" P.embed $ do @@ -178,18 +186,15 @@ threadDelay $ 1000 * d E.set gl pure $ Retry (HTTPError 429 Nothing) - ServerError c -> do debug "Server failed, retrying" pure $ Retry (HTTPError c Nothing) - InternalResponseError c -> do debug "Internal error, retrying" pure $ Retry (InternalClientError c) - ClientError c v -> pure $ RFail (HTTPError c $ decode v) -doRequest :: BotC r => RateLimitState -> Route -> IO (Response LB.ByteString) -> Sem r (Either RestError LB.ByteString) +doRequest :: BotC r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlState route action = do P.embed $ E.wait (globalLock rlState) @@ -198,5 +203,7 @@ L.acquire lock pure lock - retryRequest 5 (doSingleRequest (globalLock rlState) ratelimit action) + retryRequest + 5 + (doSingleRequest (globalLock rlState) ratelimit action) (P.embed . atomically $ L.release ratelimit) diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs --- a/src/Calamity/HTTP/Internal/Request.hs +++ b/src/Calamity/HTTP/Internal/Request.hs @@ -1,44 +1,45 @@ -- | Generic Request type -module Calamity.HTTP.Internal.Request - ( Request(..) - , invoke - , postWith' - , postWithP' - , putWith' - , patchWith' - , putEmpty - , putEmptyP - , postEmpty - , postEmptyP - , getWithP ) where +module Calamity.HTTP.Internal.Request ( + Request (..), + invoke, + getWith, + postWith', + postWithP', + putWith', + patchWith', + putEmpty, + putEmptyP, + postEmpty, + postEmptyP, + getWithP, + deleteWith, + (=:?), +) where -import Calamity.Client.Types -import Calamity.HTTP.Internal.Ratelimit -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types -import Calamity.Metrics.Eff -import Calamity.Types.Token +import Calamity.Client.Types +import Calamity.HTTP.Internal.Ratelimit +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types +import Calamity.Metrics.Eff +import Calamity.Types.Token -import Control.Lens -import Control.Monad +import Control.Lens +import Control.Monad -import Data.Aeson hiding ( Options ) -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy as TL -import Data.Text.Strict.Lens +import Data.Aeson hiding (Options) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy as TL -import DiPolysemy hiding ( debug, error, info ) +import DiPolysemy hiding (debug, error, info) -import Network.Wreq (Response, checkResponse, header, defaults) -import Network.Wreq.Session -import Network.Wreq.Types (Options, Postable, Putable ) +import Network.HTTP.Req -import Polysemy ( Sem ) -import qualified Polysemy as P -import qualified Polysemy.Error as P -import qualified Polysemy.Reader as P +import Polysemy (Sem) +import qualified Polysemy as P +import qualified Polysemy.Error as P +import qualified Polysemy.Reader as P fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a fromResult (Success a) = pure a @@ -58,7 +59,7 @@ instance ReadResponse () where readResp = const (Right ()) -instance {-# OVERLAPS #-}FromJSON a => ReadResponse a where +instance {-# OVERLAPS #-} FromJSON a => ReadResponse a where readResp = eitherDecode class Request a where @@ -66,66 +67,79 @@ route :: a -> Route - action :: a -> Options -> Session -> String -> IO (Response LB.ByteString) + action :: a -> Url 'Https -> Option 'Https -> Req LbsResponse modifyResponse :: a -> Value -> Value modifyResponse _ = id - invoke :: (BotC r, Request a, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) invoke a = do - rlState' <- P.asks (^. #rlState) - session <- P.asks (^. #session) - token' <- P.asks (^. #token) + rlState' <- P.asks (^. #rlState) + token' <- P.asks (^. #token) - let route' = route a + let route' = route a - inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)] - totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)] - void $ modifyGauge (+ 1) inFlightRequests - void $ addCounter 1 totalRequests + inFlightRequests <- registerGauge "inflight_requests" [("route", renderUrl $ route' ^. #path)] + totalRequests <- registerCounter "total_requests" [("route", renderUrl $ route' ^. #path)] + void $ modifyGauge (+ 1) inFlightRequests + void $ addCounter 1 totalRequests - resp <- attr "route" (route' ^. #path) $ doRequest rlState' route' - (action a (requestOptions token') session (route' ^. #path . unpacked)) + let r = action a (route' ^. #path) (requestOptions token') + act = runReq reqConfig r - void $ modifyGauge (subtract 1) inFlightRequests + resp <- attr "route" (renderUrl $ route' ^. #path) $ doRequest rlState' route' act - P.runError $ (fromResult . fromJSON . modifyResponse a) =<< (fromJSONDecode . readResp) =<< extractRight resp + void $ modifyGauge (subtract 1) inFlightRequests + P.runError $ fromResult . fromJSON . modifyResponse a =<< fromJSONDecode . readResp =<< extractRight resp -defaultRequestOptions :: Options -defaultRequestOptions = defaults - & header "User-Agent" .~ ["Calamity (https://github.com/nitros12/calamity)"] - & header "X-RateLimit-Precision" .~ ["millisecond"] - & checkResponse ?~ (\_ _ -> pure ()) +reqConfig :: HttpConfig +reqConfig = + defaultHttpConfig + { httpConfigCheckResponse = \_ _ _ -> Nothing + } -requestOptions :: Token -> Options -requestOptions t = defaultRequestOptions - & header "Authorization" .~ [TS.encodeUtf8 . TL.toStrict $ formatToken t] +defaultRequestOptions :: Option 'Https +defaultRequestOptions = + header "User-Agent" "Calamity (https://github.com/nitros12/calamity)" + <> header "X-RateLimit-Precision" "millisecond" -postWith' :: Postable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -postWith' p o sess s = postWith o sess s p +requestOptions :: Token -> Option 'Https +requestOptions t = defaultRequestOptions <> header "Authorization" (TS.encodeUtf8 . TL.toStrict $ formatToken t) -postWithP' :: Postable a => a -> (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -postWithP' p oF o sess s = postWith (oF o) sess s p +getWith :: Url 'Https -> Option 'Https -> Req LbsResponse +getWith u = req GET u NoReqBody lbsResponse -postEmpty :: Options -> Session -> String -> IO (Response LB.ByteString) -postEmpty o sess s = postWith o sess s ("" :: ByteString) +postWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +postWith' a u = req POST u a lbsResponse -putWith' :: Putable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -putWith' p o sess s = putWith o sess s p +postWithP' :: HttpBody a => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +postWithP' a o u o' = req POST u a lbsResponse (o <> o') -patchWith' :: Postable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -patchWith' p o sess s = customPayloadMethodWith "PATCH" o sess s p +postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse +postEmpty u = req POST u NoReqBody lbsResponse -putEmpty :: Options -> Session -> String -> IO (Response LB.ByteString) -putEmpty o sess s = putWith o sess s ("" :: ByteString) +putWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +putWith' a u = req PUT u a lbsResponse -putEmptyP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -putEmptyP = (putEmpty .) +patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse +patchWith' a u = req PATCH u a lbsResponse -postEmptyP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -postEmptyP = (postEmpty .) +putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse +putEmpty u = req PUT u NoReqBody lbsResponse -getWithP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -getWithP oF o = getWith (oF o) +putEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +putEmptyP o u o' = req PUT u NoReqBody lbsResponse (o <> o') + +postEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +postEmptyP o u o' = req POST u NoReqBody lbsResponse (o <> o') + +getWithP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +getWithP o u o' = req GET u NoReqBody lbsResponse (o <> o') + +deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse +deleteWith u = req DELETE u NoReqBody lbsResponse + +(=:?) :: T.Text -> Maybe T.Text -> Option 'Https +n =:? (Just x) = n =: x +n =:? Nothing = mempty diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs --- a/src/Calamity/HTTP/Internal/Route.hs +++ b/src/Calamity/HTTP/Internal/Route.hs @@ -24,7 +24,10 @@ import qualified Data.Text as T import Data.Typeable import Data.Word +import Data.List ( foldl' ) +import Network.HTTP.Req + import GHC.Generics hiding ( S ) import TextShow @@ -115,7 +118,7 @@ infixl 5 // data Route = Route - { path :: Text + { path :: Url 'Https , key :: Text , channelID :: Maybe (Snowflake Channel) , guildID :: Maybe (Snowflake Guild) @@ -124,8 +127,8 @@ instance Hashable Route where hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g) -baseURL :: Text -baseURL = "https://discord.com/api/v8" +baseURL :: Url 'Https +baseURL = https "discord.com" /: "api" /: "v8" buildRoute :: forall (ids :: [(Type, RouteRequirement)]) @@ -133,7 +136,7 @@ => RouteBuilder ids -> Route buildRoute (UnsafeMkRouteBuilder route ids) = Route - (T.intercalate "/" (baseURL : map goR route)) + (foldl' (/:) baseURL $ map goR route) (T.concat (map goIdent route)) (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) diff --git a/src/Calamity/HTTP/Invite.hs b/src/Calamity/HTTP/Invite.hs --- a/src/Calamity/HTTP/Invite.hs +++ b/src/Calamity/HTTP/Invite.hs @@ -1,22 +1,18 @@ -- | Invite endpoints -module Calamity.HTTP.Invite - ( InviteRequest(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Types.Model.Guild +module Calamity.HTTP.Invite (InviteRequest (..)) where -import Control.Lens hiding ( (.=) ) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Types.Model.Guild -import Data.Text ( Text ) +import Control.Lens hiding ((.=)) -import Network.Wreq.Lens -import Network.Wreq.Session +import Data.Text (Text) -import TextShow +import Network.HTTP.Req data InviteRequest a where - GetInvite :: Text -> InviteRequest Invite + GetInvite :: Text -> InviteRequest Invite DeleteInvite :: Text -> InviteRequest () baseRoute :: RouteBuilder _ @@ -25,10 +21,12 @@ instance Request (InviteRequest a) where type Result (InviteRequest a) = a - route (GetInvite c) = baseRoute // S c - & buildRoute - route (DeleteInvite c) = baseRoute // S c - & buildRoute + route (GetInvite c) = + baseRoute // S c + & buildRoute + route (DeleteInvite c) = + baseRoute // S c + & buildRoute - action (GetInvite _) = getWithP (param "with_counts" .~ [showt True]) + action (GetInvite _) = getWithP ("with_counts" =: True) action (DeleteInvite _) = deleteWith diff --git a/src/Calamity/HTTP/MiscRoutes.hs b/src/Calamity/HTTP/MiscRoutes.hs --- a/src/Calamity/HTTP/MiscRoutes.hs +++ b/src/Calamity/HTTP/MiscRoutes.hs @@ -1,26 +1,25 @@ -- | Miscellaneous routes module Calamity.HTTP.MiscRoutes where -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types - -import Data.Function +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types -import Network.Wreq.Session +import Data.Function data MiscRequest a where - GetGateway :: MiscRequest GatewayResponse + GetGateway :: MiscRequest GatewayResponse GetGatewayBot :: MiscRequest BotGatewayResponse instance Request (MiscRequest a) where type Result (MiscRequest a) = a - route GetGateway = mkRouteBuilder // S "gateway" - & buildRoute - - route GetGatewayBot = mkRouteBuilder // S "gateway" // S "bot" - & buildRoute + route GetGateway = + mkRouteBuilder // S "gateway" + & buildRoute + route GetGatewayBot = + mkRouteBuilder // S "gateway" // S "bot" + & buildRoute action GetGateway = getWith action GetGatewayBot = getWith diff --git a/src/Calamity/HTTP/Reason.hs b/src/Calamity/HTTP/Reason.hs --- a/src/Calamity/HTTP/Reason.hs +++ b/src/Calamity/HTTP/Reason.hs @@ -1,21 +1,20 @@ -- | A wrapper request that adds a reson to a request -module Calamity.HTTP.Reason - ( Reason(..) - , reason ) where - -import Calamity.HTTP.Internal.Request +module Calamity.HTTP.Reason ( + Reason (..), + reason, +) where -import Control.Lens hiding ( (.=) ) +import Calamity.HTTP.Internal.Request -import Data.Text ( Text ) -import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) -import GHC.Generics +import GHC.Generics -import Network.Wreq.Lens +import Network.HTTP.Req data Reason a = Reason a Text - deriving ( Show, Eq, Generic ) + deriving (Show, Eq, Generic) -- | Attach a reason to a request reason :: Request a => Text -> a -> Reason a @@ -26,4 +25,5 @@ route (Reason a _) = route a - action (Reason a r) = action a . (header "X-Audit-Log-Reason" .~ [encodeUtf8 r]) + action (Reason a r) = \u o -> + action a u (o <> header "X-Audit-Log-Reason" (encodeUtf8 r)) diff --git a/src/Calamity/HTTP/User.hs b/src/Calamity/HTTP/User.hs --- a/src/Calamity/HTTP/User.hs +++ b/src/Calamity/HTTP/User.hs @@ -1,54 +1,52 @@ -- | User endpoints -module Calamity.HTTP.User - ( UserRequest(..) - , ModifyUserData(..) - , GetCurrentUserGuildsOptions(..) ) where +module Calamity.HTTP.User ( + UserRequest (..), + ModifyUserData (..), + GetCurrentUserGuildsOptions (..), +) where -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Control.Arrow -import Control.Lens hiding ( (.=) ) +import Control.Lens hiding ((.=)) -import Data.Aeson -import Data.Default.Class -import Data.Maybe -import Data.Text ( Text ) +import Data.Aeson +import Data.Default.Class +import Data.Text (Text) -import GHC.Generics +import GHC.Generics -import Network.Wreq.Lens -import Network.Wreq.Session +import Network.HTTP.Req -import TextShow +import TextShow data ModifyUserData = ModifyUserData { username :: Maybe Text - -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data - , avatar :: Maybe Text + , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data + avatar :: Maybe Text } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyUserData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON ModifyUserData data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions { before :: Maybe (Snowflake Guild) - , after :: Maybe (Snowflake Guild) - , limit :: Maybe Integer + , after :: Maybe (Snowflake Guild) + , limit :: Maybe Integer } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data UserRequest a where - GetCurrentUser :: UserRequest User - GetUser :: HasID User u => u -> UserRequest User - ModifyCurrentUser :: ModifyUserData -> UserRequest User + GetCurrentUser :: UserRequest User + GetUser :: HasID User u => u -> UserRequest User + ModifyCurrentUser :: ModifyUserData -> UserRequest User GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild] - LeaveGuild :: HasID Guild g => g -> UserRequest () - CreateDM :: HasID User u => u -> UserRequest DMChannel + LeaveGuild :: HasID Guild g => g -> UserRequest () + CreateDM :: HasID User u => u -> UserRequest DMChannel baseRoute :: RouteBuilder _ baseRoute = mkRouteBuilder // S "users" // S "@me" @@ -56,26 +54,34 @@ instance Request (UserRequest a) where type Result (UserRequest a) = a - route GetCurrentUser = baseRoute - & buildRoute - route (GetUser (getID @User -> uid)) = mkRouteBuilder // S "users" // ID @User - & giveID uid - & buildRoute - route (ModifyCurrentUser _) = baseRoute - & buildRoute - route (GetCurrentUserGuilds _) = baseRoute // S "guilds" - & buildRoute - route (LeaveGuild (getID @Guild -> gid)) = baseRoute // S "guilds" // ID @Guild - & giveID gid - & buildRoute - route (CreateDM _) = baseRoute // S "channels" - & buildRoute + route GetCurrentUser = + baseRoute + & buildRoute + route (GetUser (getID @User -> uid)) = + mkRouteBuilder // S "users" // ID @User + & giveID uid + & buildRoute + route (ModifyCurrentUser _) = + baseRoute + & buildRoute + route (GetCurrentUserGuilds _) = + baseRoute // S "guilds" + & buildRoute + route (LeaveGuild (getID @Guild -> gid)) = + baseRoute // S "guilds" // ID @Guild + & giveID gid + & buildRoute + route (CreateDM _) = + baseRoute // S "channels" + & buildRoute action GetCurrentUser = getWith action (GetUser _) = getWith - action (ModifyCurrentUser o) = patchWith' (toJSON o) - action (GetCurrentUserGuilds GetCurrentUserGuildsOptions { before, after, limit }) = getWithP - (param "before" .~ maybeToList (showt <$> before) >>> param "after" .~ maybeToList (showt <$> after) >>> param - "limit" .~ maybeToList (showt <$> limit)) + action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o + action (GetCurrentUserGuilds GetCurrentUserGuildsOptions{before, after, limit}) = + getWithP + ( "before" =:? (showt <$> before) <> "after" =:? (showt <$> after) + <> "limit" =:? (showt <$> limit) + ) action (LeaveGuild _) = deleteWith - action (CreateDM (getID @User -> uid)) = postWith' (object ["recipient_id" .= uid]) + action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (object ["recipient_id" .= uid]) diff --git a/src/Calamity/HTTP/Webhook.hs b/src/Calamity/HTTP/Webhook.hs --- a/src/Calamity/HTTP/Webhook.hs +++ b/src/Calamity/HTTP/Webhook.hs @@ -1,84 +1,82 @@ -- | Webhook endpoints -module Calamity.HTTP.Webhook - ( WebhookRequest(..) - , CreateWebhookData(..) - , ModifyWebhookData(..) - , ExecuteWebhookOptions(..) ) where +module Calamity.HTTP.Webhook ( + WebhookRequest (..), + CreateWebhookData (..), + ModifyWebhookData (..), + ExecuteWebhookOptions (..), +) where -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake -import Control.Lens hiding ( (.=) ) +import Control.Lens hiding ((.=)) -import Data.Aeson -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Generics.Product.Subtype ( upcast ) -import Data.Maybe -import Data.Text ( Text ) +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Default.Class +import Data.Generics.Product.Subtype (upcast) +import Data.Text (Text) -import GHC.Generics +import GHC.Generics -import Network.Wreq ( partLBS ) -import Network.Wreq.Lens -import Network.Wreq.Session +import Network.HTTP.Req -import TextShow +import Network.HTTP.Client.MultipartFormData +import TextShow data CreateWebhookData = CreateWebhookData { username :: Maybe Text - -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data - , avatar :: Maybe Text + , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data + avatar :: Maybe Text } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON CreateWebhookData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON CreateWebhookData data ModifyWebhookData = ModifyWebhookData - { username :: Maybe Text - -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data - , avatar :: Maybe Text + { username :: Maybe Text + , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data + avatar :: Maybe Text , channelID :: Maybe (Snowflake Channel) } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyWebhookData + deriving (Show, Generic, Default) + deriving (ToJSON) via CalamityJSON ModifyWebhookData data ExecuteWebhookOptions = ExecuteWebhookOptions - { wait :: Maybe Bool - , content :: Maybe Text - , file :: Maybe ByteString - , embeds :: Maybe [Embed] - , username :: Maybe Text + { wait :: Maybe Bool + , content :: Maybe Text + , file :: Maybe ByteString + , embeds :: Maybe [Embed] + , username :: Maybe Text , avatarUrl :: Maybe Text - , tts :: Maybe Bool + , tts :: Maybe Bool } - deriving ( Show, Generic, Default ) + deriving (Show, Generic, Default) data ExecuteWebhookJson = ExecuteWebhookJson - { content :: Maybe Text - , embeds :: Maybe [Embed] - , username :: Maybe Text + { content :: Maybe Text + , embeds :: Maybe [Embed] + , username :: Maybe Text , avatarUrl :: Maybe Text - , tts :: Maybe Bool + , tts :: Maybe Bool } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ExecuteWebhookJson + deriving (Show, Generic) + deriving (ToJSON) via CalamityJSON ExecuteWebhookJson data WebhookRequest a where - CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook - GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] - GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook] - GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook - GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook - ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook - ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook - DeleteWebhook :: HasID Webhook w => w -> WebhookRequest () - DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest () - ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () - + CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook + GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] + GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook] + GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook + GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook + ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook + ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook + DeleteWebhook :: HasID Webhook w => w -> WebhookRequest () + DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest () + ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () baseRoute :: Snowflake Webhook -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id @@ -86,41 +84,53 @@ instance Request (WebhookRequest a) where type Result (WebhookRequest a) = a - route (CreateWebhook (getID @Channel -> cid) _) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute - route (GetChannelWebhooks (getID @Channel -> cid)) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute - route (GetGuildWebhooks (getID @Guild -> gid)) = mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" - & giveID gid - & buildRoute - route (GetWebhook (getID @Webhook -> wid)) = baseRoute wid - & buildRoute - route (GetWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t - & buildRoute - route (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid - & buildRoute - route (ModifyWebhookToken (getID @Webhook -> wid) t _) = baseRoute wid // S t - & buildRoute - route (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid - & buildRoute - route (DeleteWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t - & buildRoute - route (ExecuteWebhook (getID @Webhook -> wid) t _) = baseRoute wid // S t - & buildRoute + route (CreateWebhook (getID @Channel -> cid) _) = + mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" + & giveID cid + & buildRoute + route (GetChannelWebhooks (getID @Channel -> cid)) = + mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" + & giveID cid + & buildRoute + route (GetGuildWebhooks (getID @Guild -> gid)) = + mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" + & giveID gid + & buildRoute + route (GetWebhook (getID @Webhook -> wid)) = + baseRoute wid + & buildRoute + route (GetWebhookToken (getID @Webhook -> wid) t) = + baseRoute wid // S t + & buildRoute + route (ModifyWebhook (getID @Webhook -> wid) _) = + baseRoute wid + & buildRoute + route (ModifyWebhookToken (getID @Webhook -> wid) t _) = + baseRoute wid // S t + & buildRoute + route (DeleteWebhook (getID @Webhook -> wid)) = + baseRoute wid + & buildRoute + route (DeleteWebhookToken (getID @Webhook -> wid) t) = + baseRoute wid // S t + & buildRoute + route (ExecuteWebhook (getID @Webhook -> wid) t _) = + baseRoute wid // S t + & buildRoute - action (CreateWebhook _ o) = postWith' (toJSON o) + action (CreateWebhook _ o) = postWith' $ ReqBodyJson o action (GetChannelWebhooks _) = getWith action (GetGuildWebhooks _) = getWith action (GetWebhook _) = getWith action (GetWebhookToken _ _) = getWith - action (ModifyWebhook _ o) = patchWith' (toJSON o) - action (ModifyWebhookToken _ _ o) = patchWith' (toJSON o) + action (ModifyWebhook _ o) = patchWith' $ ReqBodyJson o + action (ModifyWebhookToken _ _ o) = patchWith' $ ReqBodyJson o action (DeleteWebhook _) = deleteWith action (DeleteWebhookToken _ _) = deleteWith - action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Nothing }) = postWithP' - (toJSON . upcast @ExecuteWebhookJson $ o) (param "wait" .~ maybeToList (showt <$> o ^. #wait)) - action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Just f }) = postWithP' - [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ o)] - (param "wait" .~ maybeToList (showt <$> o ^. #wait)) + action (ExecuteWebhook _ _ o@ExecuteWebhookOptions{file = Nothing}) = + postWithP' + (ReqBodyJson . upcast @ExecuteWebhookJson $ o) + ("wait" =:? (showt <$> o ^. #wait)) + action (ExecuteWebhook _ _ wh@ExecuteWebhookOptions{file = Just f}) = \u o -> do + body <- reqBodyMultipart [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ wh)] + postWithP' body ("wait" =:? (showt <$> wh ^. #wait)) u o diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs --- a/src/Calamity/Internal/SnowflakeMap.hs +++ b/src/Calamity/Internal/SnowflakeMap.hs @@ -30,7 +30,7 @@ deriving ( Generic, Eq, Data, Ord, Show ) deriving ( TextShow ) via TSG.FromGeneric (SnowflakeMap a) deriving newtype ( IsList, Semigroup, Monoid ) - deriving anyclass ( NFData, Hashable ) + deriving newtype ( NFData, Hashable ) -- instance At (SnowflakeMap a) where -- at k f m = at (unSnowflakeMap k) f m diff --git a/src/Calamity/Types/Upgradeable.hs b/src/Calamity/Types/Upgradeable.hs --- a/src/Calamity/Types/Upgradeable.hs +++ b/src/Calamity/Types/Upgradeable.hs @@ -6,6 +6,7 @@ import Calamity.Client.Types import Calamity.HTTP as H import Calamity.Internal.Utils +import qualified Calamity.Internal.SnowflakeMap as SM import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User @@ -97,3 +98,17 @@ Right e <- invoke $ H.GetGuildEmoji gid eid updateGuild gid (#emojis . at eid ?~ e) pure e + +instance Upgradeable Role (Snowflake Guild, Snowflake Role) where + upgrade (gid, rid) = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just r <- pure (g ^. #roles . at rid) + pure r + gethttp = P.failToNonDet $ do + Right rs <- invoke $ H.GetGuildRoles gid + let sm = SM.fromList rs + updateGuild gid (#roles <>~ sm) + Just r <- pure (sm ^. at rid) + pure r