From 7c9b809078b5cd53e3d54c0004c683da2ec679af Mon Sep 17 00:00:00 2001 From: Adelyn Breedlove Date: Mon, 11 Feb 2019 17:23:59 +0000 Subject: Add a cache --- lib/cache.ml | 38 +++ lib/cache.mli | 27 ++ lib/client.ml | 1 + lib/client.mli | 2 +- lib/disml.ml | 2 + lib/dispatch.ml | 36 --- lib/dispatch.mli | 120 ------- lib/dune | 2 +- lib/endpoints.ml | 63 ---- lib/endpoints.mli | 63 ---- lib/event.ml | 114 ------- lib/event.mli | 49 --- lib/gateway/dispatch.ml | 36 +++ lib/gateway/dispatch.mli | 120 +++++++ lib/gateway/event.ml | 176 +++++++++++ lib/gateway/event.mli | 49 +++ lib/gateway/opcode.ml | 54 ++++ lib/gateway/opcode.mli | 29 ++ lib/gateway/sharder.ml | 393 +++++++++++++++++++++++ lib/gateway/sharder.mli | 102 ++++++ lib/http.ml | 359 --------------------- lib/http.mli | 185 ----------- lib/http/endpoints.ml | 63 ++++ lib/http/endpoints.mli | 63 ++++ lib/http/http.ml | 360 +++++++++++++++++++++ lib/http/http.mli | 185 +++++++++++ lib/impl.ml | 168 ---------- lib/models/channel/channel.ml | 54 +++- lib/models/channel/channel.mli | 47 ++- lib/models/channel/message/embed.ml | 12 +- lib/models/event_models.ml | 605 +++++++++++++++++++++++++++--------- lib/models/guild/guild.ml | 108 ++++++- lib/models/guild/guild.mli | 32 +- lib/models/guild/guild_t.ml | 13 +- lib/models/guild/guild_t.mli | 3 +- lib/models/id/channel_id.ml | 55 +++- lib/models/id/channel_id.mli | 47 ++- lib/models/id/channel_id_t.ml | 4 + lib/models/id/channel_id_t.mli | 1 + lib/models/id/guild_id.ml | 104 ++++++- lib/models/id/guild_id.mli | 32 +- lib/models/id/guild_id_t.ml | 4 + lib/models/id/guild_id_t.mli | 1 + lib/models/id/user_id.ml | 3 +- lib/models/id/user_id.mli | 4 +- lib/models/id/user_id_t.ml | 4 + lib/models/id/user_id_t.mli | 1 + lib/models/user/presence.ml | 2 - lib/models/user/presence.mli | 2 - lib/models/user/user_t.ml | 4 + lib/models/user/user_t.mli | 4 + lib/opcode.ml | 54 ---- lib/opcode.mli | 29 -- lib/s.ml | 93 ------ lib/sharder.ml | 376 ---------------------- lib/sharder.mli | 101 ------ 56 files changed, 2655 insertions(+), 2003 deletions(-) create mode 100644 lib/cache.ml create mode 100644 lib/cache.mli delete mode 100644 lib/dispatch.ml delete mode 100644 lib/dispatch.mli delete mode 100644 lib/endpoints.ml delete mode 100644 lib/endpoints.mli delete mode 100644 lib/event.ml delete mode 100644 lib/event.mli create mode 100644 lib/gateway/dispatch.ml create mode 100644 lib/gateway/dispatch.mli create mode 100644 lib/gateway/event.ml create mode 100644 lib/gateway/event.mli create mode 100644 lib/gateway/opcode.ml create mode 100644 lib/gateway/opcode.mli create mode 100644 lib/gateway/sharder.ml create mode 100644 lib/gateway/sharder.mli delete mode 100644 lib/http.ml delete mode 100644 lib/http.mli create mode 100644 lib/http/endpoints.ml create mode 100644 lib/http/endpoints.mli create mode 100644 lib/http/http.ml create mode 100644 lib/http/http.mli delete mode 100644 lib/impl.ml delete mode 100644 lib/opcode.ml delete mode 100644 lib/opcode.mli delete mode 100644 lib/s.ml delete mode 100644 lib/sharder.ml delete mode 100644 lib/sharder.mli (limited to 'lib') diff --git a/lib/cache.ml b/lib/cache.ml new file mode 100644 index 0000000..50d431c --- /dev/null +++ b/lib/cache.ml @@ -0,0 +1,38 @@ +open Async +open Core + +module ChannelMap = Map.Make(Channel_id_t) +module GuildMap = Map.Make(Guild_id_t) +module UserMap = Map.Make(User_id_t) + +type t = { + text_channels: Channel_t.guild_text ChannelMap.t; + voice_channels: Channel_t.guild_voice ChannelMap.t; + categories: Channel_t.category ChannelMap.t; + groups: Channel_t.group ChannelMap.t; + private_channels: Channel_t.dm ChannelMap.t; + guilds: Guild_t.t GuildMap.t; + presences: Presence.t UserMap.t; + (* messages: Channel_id_t.t GuildMap.t; *) + unavailable_guilds: Guild_t.unavailable GuildMap.t; + user: User_t.t option; + users: User_t.t UserMap.t; +} + +let create () = { + text_channels = ChannelMap.empty; + voice_channels = ChannelMap.empty; + categories = ChannelMap.empty; + groups = ChannelMap.empty; + private_channels = ChannelMap.empty; + guilds = GuildMap.empty; + presences = UserMap.empty; + unavailable_guilds = GuildMap.empty; + user = None; + users = UserMap.empty; + } + +let cache = + let m = Mvar.create () in + Mvar.set m (create ()); + m \ No newline at end of file diff --git a/lib/cache.mli b/lib/cache.mli new file mode 100644 index 0000000..111e5bc --- /dev/null +++ b/lib/cache.mli @@ -0,0 +1,27 @@ +open Async +open Core + +module ChannelMap : module type of Map.Make(Channel_id_t) +module GuildMap : module type of Map.Make(Guild_id_t) +module UserMap : module type of Map.Make(User_id_t) + +type t = { + text_channels: Channel_t.guild_text ChannelMap.t; + voice_channels: Channel_t.guild_voice ChannelMap.t; + categories: Channel_t.category ChannelMap.t; + groups: Channel_t.group ChannelMap.t; + private_channels: Channel_t.dm ChannelMap.t; + guilds: Guild_t.t GuildMap.t; + presences: Presence.t UserMap.t; + (* messages: Channel_id_t.t GuildMap.t; *) + unavailable_guilds: Guild_t.unavailable GuildMap.t; + user: User_t.t option; + users: User_t.t UserMap.t; +} + +val cache : t Mvar.Read_write.t + +val create : + (* ?max_messages:int -> *) + unit -> + t \ No newline at end of file diff --git a/lib/client.ml b/lib/client.ml index 97a736b..d1778e7 100644 --- a/lib/client.ml +++ b/lib/client.ml @@ -18,4 +18,5 @@ let set_status_with ~f client = Sharder.set_status_with ~f client.sharder let request_guild_members ~guild ?query ?limit client = + let `Guild_id guild = guild in Sharder.request_guild_members ~guild ?query ?limit client.sharder \ No newline at end of file diff --git a/lib/client.mli b/lib/client.mli index 991f8e3..c5b5501 100644 --- a/lib/client.mli +++ b/lib/client.mli @@ -35,4 +35,4 @@ val set_status : status:Yojson.Safe.t -> t -> Sharder.Shard.shard list Deferred. val set_status_with : f:(Sharder.Shard.shard -> Yojson.Safe.t) -> t -> Sharder.Shard.shard list Deferred.t (** Same as {!Sharder.request_guild_members} where [client.sharder] is passed. *) -val request_guild_members : guild:Snowflake.t -> ?query:string -> ?limit:int -> t -> Sharder.Shard.shard list Deferred.t \ No newline at end of file +val request_guild_members : guild:Guild_id.t -> ?query:string -> ?limit:int -> t -> Sharder.Shard.shard list Deferred.t \ No newline at end of file diff --git a/lib/disml.ml b/lib/disml.ml index 922a4d3..2e44658 100644 --- a/lib/disml.ml +++ b/lib/disml.ml @@ -29,6 +29,8 @@ (** The primary interface for connecting to Discord and handling gateway events. *) module Client = Client +module Cache = Cache + (** Raw HTTP abstractions for Discord's REST API. *) module Http = Http diff --git a/lib/dispatch.ml b/lib/dispatch.ml deleted file mode 100644 index b4fc9d2..0000000 --- a/lib/dispatch.ml +++ /dev/null @@ -1,36 +0,0 @@ -open Event_models - -let ready = ref (fun (_:Ready.t) -> ()) -let resumed = ref (fun (_:Resumed.t) -> ()) -let channel_create = ref (fun (_:ChannelCreate.t) -> ()) -let channel_update = ref (fun (_:ChannelUpdate.t) -> ()) -let channel_delete = ref (fun (_:ChannelDelete.t) -> ()) -let channel_pins_update = ref (fun (_:ChannelPinsUpdate.t) -> ()) -let guild_create = ref (fun (_:GuildCreate.t) -> ()) -let guild_update = ref (fun (_:GuildUpdate.t) -> ()) -let guild_delete = ref (fun (_:GuildDelete.t) -> ()) -let member_ban = ref (fun (_:GuildBanAdd.t) -> ()) -let member_unban = ref (fun (_:GuildBanRemove.t) -> ()) -let guild_emojis_update = ref (fun (_:GuildEmojisUpdate.t) -> ()) -(* let integrations_update = ref (fun (_:Yojson.Safe.t) -> ()) *) -let member_join = ref (fun (_:GuildMemberAdd.t) -> ()) -let member_leave = ref (fun (_:GuildMemberRemove.t) -> ()) -let member_update = ref (fun (_:GuildMemberUpdate.t) -> ()) -let members_chunk = ref (fun (_:GuildMembersChunk.t) -> ()) -let role_create = ref (fun (_:GuildRoleCreate.t) -> ()) -let role_update = ref (fun (_:GuildRoleUpdate.t) -> ()) -let role_delete = ref (fun (_:GuildRoleDelete.t) -> ()) -let message_create = ref (fun (_:MessageCreate.t) -> ()) -let message_update = ref (fun (_:MessageUpdate.t) -> ()) -let message_delete = ref (fun (_:MessageDelete.t) -> ()) -let message_delete_bulk = ref (fun (_:MessageDeleteBulk.t) -> ()) -let reaction_add = ref (fun (_:ReactionAdd.t) -> ()) -let reaction_remove = ref (fun (_:ReactionRemove.t) -> ()) -let reaction_remove_all = ref (fun (_:ReactionRemoveAll.t) -> ()) -let presence_update = ref (fun (_:PresenceUpdate.t) -> ()) -let typing_start = ref (fun (_:TypingStart.t) -> ()) -let user_update = ref (fun (_:UserUpdate.t) -> ()) -(* let voice_state_update = ref (fun (_:Yojson.Safe.t) -> ()) *) -(* let voice_server_update = ref (fun (_:Yojson.Safe.t) -> ()) *) -let webhook_update = ref (fun (_:WebhookUpdate.t) -> ()) -let unknown = ref (fun (_:Unknown.t) -> ()) \ No newline at end of file diff --git a/lib/dispatch.mli b/lib/dispatch.mli deleted file mode 100644 index 18b9261..0000000 --- a/lib/dispatch.mli +++ /dev/null @@ -1,120 +0,0 @@ -(** Used to store dispatch callbacks. Each event can only have one callback registered at a time. - These should be accessed through their re-export in {!Client}. - {3 Examples} - [Client.ready := (fun _ -> print_endline "Shard is Ready!")] - - [Client.guild_create := (fun guild -> print_endline guild.name)] - - {[ - open Core - open Disml - - let check_command (msg : Message.t) = - if String.is_prefix ~prefix:"!ping" msg.content then - Message.reply msg "Pong!" >>> ignore - - Client.message_create := check_command - ]} -*) - -open Event_models - -(** Dispatched when each shard receives READY from discord after identifying on the gateway. Other event dispatch is received after this. *) -val ready : (Ready.t -> unit) ref - -(** Dispatched when successfully reconnecting to the gateway. *) -val resumed : (Resumed.t -> unit) ref - -(** Dispatched when a channel is created which is visible to the bot. *) -val channel_create : (ChannelCreate.t -> unit) ref - -(** Dispatched when a channel visible to the bot is changed. *) -val channel_update : (ChannelUpdate.t -> unit) ref - -(** Dispatched when a channel visible to the bot is deleted. *) -val channel_delete : (ChannelDelete.t -> unit) ref - -(** Dispatched when messages are pinned or unpinned from a a channel. *) -val channel_pins_update : (ChannelPinsUpdate.t -> unit) ref - -(** Dispatched when the bot joins a guild, and during startup. *) -val guild_create : (GuildCreate.t -> unit) ref - -(** Dispatched when a guild the bot is in is edited. *) -val guild_update : (GuildUpdate.t -> unit) ref - -(** Dispatched when the bot is removed from a guild. *) -val guild_delete : (GuildDelete.t -> unit) ref - -(** Dispatched when a member is banned. *) -val member_ban : (GuildBanAdd.t -> unit) ref - -(** Dispatched when a member is unbanned. *) -val member_unban : (GuildBanRemove.t -> unit) ref - -(** Dispatched when emojis are added or removed from a guild. *) -val guild_emojis_update : (GuildEmojisUpdate.t -> unit) ref - -(** Dispatched when a guild's integrations are updated. *) -(* val integrations_update : (Yojson.Safe.t -> unit) ref *) - -(** Dispatched when a member joins a guild. *) -val member_join : (GuildMemberAdd.t -> unit) ref - -(** Dispatched when a member leaves a guild. Is Dispatched alongside {!Client.member_ban} when a user is banned. *) -val member_leave : (GuildMemberRemove.t -> unit) ref - -(** Dispatched when a member object is updated. *) -val member_update : (GuildMemberUpdate.t -> unit) ref - -(** Dispatched when requesting guild members through {!Client.request_guild_members} *) -val members_chunk : (GuildMembersChunk.t -> unit) ref - -(** Dispatched when a role is created. *) -val role_create : (GuildRoleCreate.t -> unit) ref - -(** Dispatched when a role is edited. *) -val role_update : (GuildRoleUpdate.t -> unit) ref - -(** Dispatched when a role is deleted. *) -val role_delete : (GuildRoleDelete.t -> unit) ref - -(** Dispatched when a message is sent. *) -val message_create : (MessageCreate.t -> unit) ref - -(** Dispatched when a message is edited. This does not necessarily mean the content changed. *) -val message_update : (MessageUpdate.t -> unit) ref - -(** Dispatched when a message is deleted. *) -val message_delete : (MessageDelete.t -> unit) ref - -(** Dispatched when messages are bulk deleted. *) -val message_delete_bulk : (MessageDeleteBulk.t -> unit) ref - -(** Dispatched when a rection is added to a message. *) -val reaction_add : (ReactionAdd.t -> unit) ref - -(** Dispatched when a reaction is removed from a message. *) -val reaction_remove : (ReactionRemove.t -> unit) ref - -(** Dispatched when all reactions are cleared from a message. *) -val reaction_remove_all : (ReactionRemoveAll.t -> unit) ref - -(** Dispatched when a user updates their presence. *) -val presence_update : (PresenceUpdate.t -> unit) ref - -(** Dispatched when a typing indicator is displayed. *) -val typing_start : (TypingStart.t -> unit) ref - -(** Dispatched when the current user is updated. You most likely want {!Client.member_update} or {!Client.presence_update} instead. *) -val user_update : (UserUpdate.t -> unit) ref - -(** Dispatched when a webhook is updated. *) -val webhook_update : (WebhookUpdate.t -> unit) ref - -(** Dispatched as a fallback for unknown events. *) -val unknown : (Unknown.t -> unit) ref - -(**/**) -(* val voice_state_update : (Yojson.Safe.t -> unit) ref *) -(* val voice_server_update : (Yojson.Safe.t -> unit) ref *) \ No newline at end of file diff --git a/lib/dune b/lib/dune index 936b5e9..99da59b 100644 --- a/lib/dune +++ b/lib/dune @@ -18,7 +18,7 @@ snowflake user user_t user_id user_id_t event_models - client client_options disml dispatch endpoints event http impl opcode rl s sharder + cache client client_options disml dispatch endpoints event http opcode rl sharder ) (libraries checkseum.ocaml core async_ssl cohttp-async decompress logs yojson websocket-async ppx_deriving_yojson.runtime) (preprocess (pps ppx_sexp_conv ppx_deriving_yojson)) diff --git a/lib/endpoints.ml b/lib/endpoints.ml deleted file mode 100644 index c23ae88..0000000 --- a/lib/endpoints.ml +++ /dev/null @@ -1,63 +0,0 @@ -open Printf - -let gateway = "/gateway" -let gateway_bot = "/gateway/bot" -let channel = sprintf "/channels/%d" -let channel_messages = sprintf "/channels/%d/messages" -let channel_message = sprintf "/channels/%d/messages/%d" -let channel_reaction_me = sprintf "/channels/%d/messages/%d/reactions/%s/@me" -let channel_reaction = sprintf "/channels/%d/messages/%d/reactions/%s/%d" -let channel_reactions_get = sprintf "/channels/%d/messages/%d/reactions/%s" -let channel_reactions_delete = sprintf "/channels/%d/messages/%d/reactions" -let channel_bulk_delete = sprintf "/channels/%d" -let channel_permission = sprintf "/channels/%d/permissions/%d" -let channel_permissions = sprintf "/channels/%d/permissions" -let channels = "/channels" -let channel_call_ring = sprintf "/channels/%d/call/ring" -let channel_invites = sprintf "/channels/%d/invites" -let channel_typing = sprintf "/channels/%d/typing" -let channel_pins = sprintf "/channels/%d/pins" -let channel_pin = sprintf "/channels/%d/pins/%d" -let guilds = "/guilds" -let guild = sprintf "/guilds/%d" -let guild_channels = sprintf "/guilds/%d/channels" -let guild_members = sprintf "/guilds/%d/members" -let guild_member = sprintf "/guilds/%d/members/%d" -let guild_member_role = sprintf "/guilds/%d/members/%d/roles/%d" -let guild_bans = sprintf "/guilds/%d/bans" -let guild_ban = sprintf "/guilds/%d/bans/%d" -let guild_roles = sprintf "/guilds/%d/roles" -let guild_role = sprintf "/guilds/%d/roles/%d" -let guild_prune = sprintf "/guilds/%d/prune" -let guild_voice_regions = sprintf "/guilds/%d/regions" -let guild_invites = sprintf "/guilds/%d/invites" -let guild_integrations = sprintf "/guilds/%d/integrations" -let guild_integration = sprintf "/guilds/%d/integrations/%d" -let guild_integration_sync = sprintf "/guilds/%d/integrations/%d/sync" -let guild_embed = sprintf "/guilds/%d/embed" -let guild_emojis = sprintf "/guilds/%d/emojis" -let guild_emoji = sprintf "/guilds/%d/emojis/%d" -let webhooks_guild = sprintf "/guilds/%d/webhooks" -let webhooks_channel = sprintf "/channels/%d/webhooks" -let webhook = sprintf "/webhooks/%d" -let webhook_token = sprintf "/webhooks/%d/%s" -let webhook_git = sprintf "/webhooks/%d/%s/github" -let webhook_slack = sprintf "/webhooks/%d/%s/slack" -let user = sprintf "/users/%d" -let me = "/users/@me" -let me_guilds = "/users/@me/guilds" -let me_guild = sprintf "/users/@me/guilds/%d" -let me_channels = "/users/@me/channels" -let me_connections = "/users/@me/connections" -let invite = sprintf "/invites/%s" -let regions = "/voice/regions" -let application_information = "/oauth2/applications/@me" -let group_recipient = sprintf "/channels/%d/recipients/%d" -let guild_me_nick = sprintf "/guilds/%d/members/@me/nick" -let guild_vanity_url = sprintf "/guilds/%d/vanity-url" -let guild_audit_logs = sprintf "/guilds/%d/audit-logs" -let cdn_embed_avatar = sprintf "/embed/avatars/%s.png" -let cdn_emoji = sprintf "/emojis/%s.%s" -let cdn_icon = sprintf "/icons/%d/%s.%s" -let cdn_avatar = sprintf "/avatars/%d/%s.%s" -let cdn_default_avatar = sprintf "/embed/avatars/%d" \ No newline at end of file diff --git a/lib/endpoints.mli b/lib/endpoints.mli deleted file mode 100644 index 2abe01d..0000000 --- a/lib/endpoints.mli +++ /dev/null @@ -1,63 +0,0 @@ -(** Endpoint formatters used internally. *) - -val gateway : string -val gateway_bot : string -val channel : int -> string -val channel_messages : int -> string -val channel_message : int -> int -> string -val channel_reaction_me : int -> int -> string -> string -val channel_reaction : int -> int -> string -> int -> string -val channel_reactions_get : int -> int -> string -> string -val channel_reactions_delete : int -> int -> string -val channel_bulk_delete : int -> string -val channel_permission : int -> int -> string -val channel_permissions : int -> string -val channels : string -val channel_call_ring : int -> string -val channel_invites : int -> string -val channel_typing : int -> string -val channel_pins : int -> string -val channel_pin : int -> int -> string -val guilds : string -val guild : int -> string -val guild_channels : int -> string -val guild_members : int -> string -val guild_member : int -> int -> string -val guild_member_role : int -> int -> int -> string -val guild_bans : int -> string -val guild_ban : int -> int -> string -val guild_roles : int -> string -val guild_role : int -> int -> string -val guild_prune : int -> string -val guild_voice_regions : int -> string -val guild_invites : int -> string -val guild_integrations : int -> string -val guild_integration : int -> int -> string -val guild_integration_sync : int -> int -> string -val guild_embed : int -> string -val guild_emojis : int -> string -val guild_emoji : int -> int -> string -val webhooks_guild : int -> string -val webhooks_channel : int -> string -val webhook : int -> string -val webhook_token : int -> string -> string -val webhook_git : int -> string -> string -val webhook_slack : int -> string -> string -val user : int -> string -val me : string -val me_guilds : string -val me_guild : int -> string -val me_channels : string -val me_connections : string -val invite : string -> string -val regions : string -val application_information : string -val group_recipient : int -> int -> string -val guild_me_nick : int -> string -val guild_vanity_url : int -> string -val guild_audit_logs : int -> string -val cdn_embed_avatar : string -> string -val cdn_emoji : string -> string -> string -val cdn_icon : int -> string -> string -> string -val cdn_avatar : int -> string -> string -> string -val cdn_default_avatar : int -> string \ No newline at end of file diff --git a/lib/event.ml b/lib/event.ml deleted file mode 100644 index 2e02249..0000000 --- a/lib/event.ml +++ /dev/null @@ -1,114 +0,0 @@ -open Core -open Event_models - -type t = -| READY of Ready.t -| RESUMED of Resumed.t -| CHANNEL_CREATE of ChannelCreate.t -| CHANNEL_UPDATE of ChannelUpdate.t -| CHANNEL_DELETE of ChannelDelete.t -| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t -| GUILD_CREATE of GuildCreate.t -| GUILD_UPDATE of GuildUpdate.t -| GUILD_DELETE of GuildDelete.t -| GUILD_BAN_ADD of GuildBanAdd.t -| GUILD_BAN_REMOVE of GuildBanRemove.t -| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t -(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.t *) -| GUILD_MEMBER_ADD of GuildMemberAdd.t -| GUILD_MEMBER_REMOVE of GuildMemberRemove.t -| GUILD_MEMBER_UPDATE of GuildMemberUpdate.t -| GUILD_MEMBERS_CHUNK of GuildMembersChunk.t -| GUILD_ROLE_CREATE of GuildRoleCreate.t -| GUILD_ROLE_UPDATE of GuildRoleUpdate.t -| GUILD_ROLE_DELETE of GuildRoleDelete.t -| MESSAGE_CREATE of MessageCreate.t -| MESSAGE_UPDATE of MessageUpdate.t -| MESSAGE_DELETE of MessageDelete.t -| MESSAGE_DELETE_BULK of MessageDeleteBulk.t -| REACTION_ADD of ReactionAdd.t -| REACTION_REMOVE of ReactionRemove.t -| REACTION_REMOVE_ALL of ReactionRemoveAll.t -| PRESENCE_UPDATE of PresenceUpdate.t -| TYPING_START of TypingStart.t -| USER_UPDATE of UserUpdate.t -(* | VOICE_STATE_UPDATE of Yojson.Safe.t *) -(* | VOICE_SERVER_UPDATE of Yojson.Safe.t *) -| WEBHOOK_UPDATE of WebhookUpdate.t -| UNKNOWN of Unknown.t - -let event_of_yojson ~contents = function - | "READY" -> READY Ready.(deserialize contents) - | "RESUMED" -> RESUMED Resumed.(deserialize contents) - | "CHANNEL_CREATE" -> CHANNEL_CREATE ChannelCreate.(deserialize contents) - | "CHANNEL_UPDATE" -> CHANNEL_UPDATE ChannelUpdate.(deserialize contents) - | "CHANNEL_DELETE" -> CHANNEL_DELETE ChannelDelete.(deserialize contents) - | "CHANNEL_PINS_UPDATE" -> CHANNEL_PINS_UPDATE ChannelPinsUpdate.(deserialize contents) - | "GUILD_CREATE" -> GUILD_CREATE GuildCreate.(deserialize contents) - | "GUILD_UPDATE" -> GUILD_UPDATE GuildUpdate.(deserialize contents) - | "GUILD_DELETE" -> GUILD_DELETE GuildDelete.(deserialize contents) - | "GUILD_BAN_ADD" -> GUILD_BAN_ADD GuildBanAdd.(deserialize contents) - | "GUILD_BAN_REMOVE" -> GUILD_BAN_REMOVE GuildBanRemove.(deserialize contents) - | "GUILD_EMOJIS_UPDATE" -> GUILD_EMOJIS_UPDATE GuildEmojisUpdate.(deserialize contents) - (* | "GUILD_INTEGRATIONS_UPDATE" -> GUILD_INTEGRATIONS_UPDATE contents *) - | "GUILD_MEMBER_ADD" -> GUILD_MEMBER_ADD GuildMemberAdd.(deserialize contents) - | "GUILD_MEMBER_REMOVE" -> GUILD_MEMBER_REMOVE GuildMemberRemove.(deserialize contents) - | "GUILD_MEMBER_UPDATE" -> GUILD_MEMBER_UPDATE GuildMemberUpdate.(deserialize contents) - | "GUILD_MEMBERS_CHUNK" -> GUILD_MEMBERS_CHUNK GuildMembersChunk.(deserialize contents) - | "GUILD_ROLE_CREATE" -> GUILD_ROLE_CREATE GuildRoleCreate.(deserialize contents) - | "GUILD_ROLE_UPDATE" -> GUILD_ROLE_UPDATE GuildRoleUpdate.(deserialize contents) - | "GUILD_ROLE_DELETE" -> GUILD_ROLE_DELETE GuildRoleDelete.(deserialize contents) - | "MESSAGE_CREATE" -> MESSAGE_CREATE MessageCreate.(deserialize contents) - | "MESSAGE_UPDATE" -> MESSAGE_UPDATE MessageUpdate.(deserialize contents) - | "MESSAGE_DELETE" -> MESSAGE_DELETE MessageDelete.(deserialize contents) - | "MESSAGE_DELETE_BULK" -> MESSAGE_DELETE_BULK MessageDeleteBulk.(deserialize contents) - | "MESSAGE_REACTION_ADD" -> REACTION_ADD ReactionAdd.(deserialize contents) - | "MESSAGE_REACTION_REMOVE" -> REACTION_REMOVE ReactionRemove.(deserialize contents) - | "MESSAGE_REACTION_REMOVE_ALL" -> REACTION_REMOVE_ALL ReactionRemoveAll.(deserialize contents) - | "PRESENCE_UPDATE" -> PRESENCE_UPDATE PresenceUpdate.(deserialize contents) - | "TYPING_START" -> TYPING_START TypingStart.(deserialize contents) - | "USER_UPDATE" -> USER_UPDATE UserUpdate.(deserialize contents) - (* | "VOICE_STATE_UPDATE" -> VOICE_STATE_UPDATE contents *) - (* | "VOICE_SERVER_UPDATE" -> VOICE_SERVER_UPDATE contents *) - | "WEBHOOK_UPDATE" -> WEBHOOK_UPDATE WebhookUpdate.(deserialize contents) - | s -> UNKNOWN Unknown.(deserialize s contents) - -let dispatch = function - | READY d -> !Dispatch.ready d - | RESUMED d -> !Dispatch.resumed d - | CHANNEL_CREATE d -> !Dispatch.channel_create d - | CHANNEL_UPDATE d -> !Dispatch.channel_update d - | CHANNEL_DELETE d -> !Dispatch.channel_delete d - | CHANNEL_PINS_UPDATE d -> !Dispatch.channel_pins_update d - | GUILD_CREATE d -> !Dispatch.guild_create d - | GUILD_UPDATE d -> !Dispatch.guild_update d - | GUILD_DELETE d -> !Dispatch.guild_delete d - | GUILD_BAN_ADD d -> !Dispatch.member_ban d - | GUILD_BAN_REMOVE d -> !Dispatch.member_unban d - | GUILD_EMOJIS_UPDATE d -> !Dispatch.guild_emojis_update d - (* | GUILD_INTEGRATIONS_UPDATE d -> !Dispatch.integrations_update d *) - | GUILD_MEMBER_ADD d -> !Dispatch.member_join d - | GUILD_MEMBER_REMOVE d -> !Dispatch.member_leave d - | GUILD_MEMBER_UPDATE d -> !Dispatch.member_update d - | GUILD_MEMBERS_CHUNK d -> !Dispatch.members_chunk d - | GUILD_ROLE_CREATE d -> !Dispatch.role_create d - | GUILD_ROLE_UPDATE d -> !Dispatch.role_update d - | GUILD_ROLE_DELETE d -> !Dispatch.role_delete d - | MESSAGE_CREATE d -> !Dispatch.message_create d - | MESSAGE_UPDATE d -> !Dispatch.message_update d - | MESSAGE_DELETE d -> !Dispatch.message_delete d - | MESSAGE_DELETE_BULK d -> !Dispatch.message_delete_bulk d - | REACTION_ADD d -> !Dispatch.reaction_add d - | REACTION_REMOVE d -> !Dispatch.reaction_remove d - | REACTION_REMOVE_ALL d -> !Dispatch.reaction_remove_all d - | PRESENCE_UPDATE d -> !Dispatch.presence_update d - | TYPING_START d -> !Dispatch.typing_start d - | USER_UPDATE d -> !Dispatch.user_update d - (* | VOICE_STATE_UPDATE d -> !Dispatch.voice_state_update d *) - (* | VOICE_SERVER_UPDATE d -> !Dispatch.voice_server_update d *) - | WEBHOOK_UPDATE d -> !Dispatch.webhook_update d - | UNKNOWN d -> !Dispatch.unknown d - -let handle_event ~ev contents = - event_of_yojson ~contents ev - |> dispatch \ No newline at end of file diff --git a/lib/event.mli b/lib/event.mli deleted file mode 100644 index 4db3c84..0000000 --- a/lib/event.mli +++ /dev/null @@ -1,49 +0,0 @@ -(** Barebones of event dispatching. Most users will have no reason to look here. *) - -open Event_models - -(** Event dispatch type wrapper. Used internally. *) -type t = -| READY of Ready.t -| RESUMED of Resumed.t -| CHANNEL_CREATE of ChannelCreate.t -| CHANNEL_UPDATE of ChannelUpdate.t -| CHANNEL_DELETE of ChannelDelete.t -| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t -| GUILD_CREATE of GuildCreate.t -| GUILD_UPDATE of GuildUpdate.t -| GUILD_DELETE of GuildDelete.t -| GUILD_BAN_ADD of GuildBanAdd.t -| GUILD_BAN_REMOVE of GuildBanRemove.t -| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t -(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.t *) -| GUILD_MEMBER_ADD of GuildMemberAdd.t -| GUILD_MEMBER_REMOVE of GuildMemberRemove.t -| GUILD_MEMBER_UPDATE of GuildMemberUpdate.t -| GUILD_MEMBERS_CHUNK of GuildMembersChunk.t -| GUILD_ROLE_CREATE of GuildRoleCreate.t -| GUILD_ROLE_UPDATE of GuildRoleUpdate.t -| GUILD_ROLE_DELETE of GuildRoleDelete.t -| MESSAGE_CREATE of MessageCreate.t -| MESSAGE_UPDATE of MessageUpdate.t -| MESSAGE_DELETE of MessageDelete.t -| MESSAGE_DELETE_BULK of MessageDeleteBulk.t -| REACTION_ADD of ReactionAdd.t -| REACTION_REMOVE of ReactionRemove.t -| REACTION_REMOVE_ALL of ReactionRemoveAll.t -| PRESENCE_UPDATE of PresenceUpdate.t -| TYPING_START of TypingStart.t -| USER_UPDATE of UserUpdate.t -(* | VOICE_STATE_UPDATE of Yojson.Safe.t *) -(* | VOICE_SERVER_UPDATE of Yojson.Safe.t *) -| WEBHOOK_UPDATE of WebhookUpdate.t -| UNKNOWN of Unknown.t - -(** Used to convert an event string and payload into a t wrapper type. *) -val event_of_yojson : contents:Yojson.Safe.t -> string -> t - -(** Sends the event to the registered handler. *) -val dispatch : t -> unit - -(** Wrapper to other functions. This is called from the shards. *) -val handle_event : ev:string -> Yojson.Safe.t -> unit \ No newline at end of file diff --git a/lib/gateway/dispatch.ml b/lib/gateway/dispatch.ml new file mode 100644 index 0000000..b4fc9d2 --- /dev/null +++ b/lib/gateway/dispatch.ml @@ -0,0 +1,36 @@ +open Event_models + +let ready = ref (fun (_:Ready.t) -> ()) +let resumed = ref (fun (_:Resumed.t) -> ()) +let channel_create = ref (fun (_:ChannelCreate.t) -> ()) +let channel_update = ref (fun (_:ChannelUpdate.t) -> ()) +let channel_delete = ref (fun (_:ChannelDelete.t) -> ()) +let channel_pins_update = ref (fun (_:ChannelPinsUpdate.t) -> ()) +let guild_create = ref (fun (_:GuildCreate.t) -> ()) +let guild_update = ref (fun (_:GuildUpdate.t) -> ()) +let guild_delete = ref (fun (_:GuildDelete.t) -> ()) +let member_ban = ref (fun (_:GuildBanAdd.t) -> ()) +let member_unban = ref (fun (_:GuildBanRemove.t) -> ()) +let guild_emojis_update = ref (fun (_:GuildEmojisUpdate.t) -> ()) +(* let integrations_update = ref (fun (_:Yojson.Safe.t) -> ()) *) +let member_join = ref (fun (_:GuildMemberAdd.t) -> ()) +let member_leave = ref (fun (_:GuildMemberRemove.t) -> ()) +let member_update = ref (fun (_:GuildMemberUpdate.t) -> ()) +let members_chunk = ref (fun (_:GuildMembersChunk.t) -> ()) +let role_create = ref (fun (_:GuildRoleCreate.t) -> ()) +let role_update = ref (fun (_:GuildRoleUpdate.t) -> ()) +let role_delete = ref (fun (_:GuildRoleDelete.t) -> ()) +let message_create = ref (fun (_:MessageCreate.t) -> ()) +let message_update = ref (fun (_:MessageUpdate.t) -> ()) +let message_delete = ref (fun (_:MessageDelete.t) -> ()) +let message_delete_bulk = ref (fun (_:MessageDeleteBulk.t) -> ()) +let reaction_add = ref (fun (_:ReactionAdd.t) -> ()) +let reaction_remove = ref (fun (_:ReactionRemove.t) -> ()) +let reaction_remove_all = ref (fun (_:ReactionRemoveAll.t) -> ()) +let presence_update = ref (fun (_:PresenceUpdate.t) -> ()) +let typing_start = ref (fun (_:TypingStart.t) -> ()) +let user_update = ref (fun (_:UserUpdate.t) -> ()) +(* let voice_state_update = ref (fun (_:Yojson.Safe.t) -> ()) *) +(* let voice_server_update = ref (fun (_:Yojson.Safe.t) -> ()) *) +let webhook_update = ref (fun (_:WebhookUpdate.t) -> ()) +let unknown = ref (fun (_:Unknown.t) -> ()) \ No newline at end of file diff --git a/lib/gateway/dispatch.mli b/lib/gateway/dispatch.mli new file mode 100644 index 0000000..18b9261 --- /dev/null +++ b/lib/gateway/dispatch.mli @@ -0,0 +1,120 @@ +(** Used to store dispatch callbacks. Each event can only have one callback registered at a time. + These should be accessed through their re-export in {!Client}. + {3 Examples} + [Client.ready := (fun _ -> print_endline "Shard is Ready!")] + + [Client.guild_create := (fun guild -> print_endline guild.name)] + + {[ + open Core + open Disml + + let check_command (msg : Message.t) = + if String.is_prefix ~prefix:"!ping" msg.content then + Message.reply msg "Pong!" >>> ignore + + Client.message_create := check_command + ]} +*) + +open Event_models + +(** Dispatched when each shard receives READY from discord after identifying on the gateway. Other event dispatch is received after this. *) +val ready : (Ready.t -> unit) ref + +(** Dispatched when successfully reconnecting to the gateway. *) +val resumed : (Resumed.t -> unit) ref + +(** Dispatched when a channel is created which is visible to the bot. *) +val channel_create : (ChannelCreate.t -> unit) ref + +(** Dispatched when a channel visible to the bot is changed. *) +val channel_update : (ChannelUpdate.t -> unit) ref + +(** Dispatched when a channel visible to the bot is deleted. *) +val channel_delete : (ChannelDelete.t -> unit) ref + +(** Dispatched when messages are pinned or unpinned from a a channel. *) +val channel_pins_update : (ChannelPinsUpdate.t -> unit) ref + +(** Dispatched when the bot joins a guild, and during startup. *) +val guild_create : (GuildCreate.t -> unit) ref + +(** Dispatched when a guild the bot is in is edited. *) +val guild_update : (GuildUpdate.t -> unit) ref + +(** Dispatched when the bot is removed from a guild. *) +val guild_delete : (GuildDelete.t -> unit) ref + +(** Dispatched when a member is banned. *) +val member_ban : (GuildBanAdd.t -> unit) ref + +(** Dispatched when a member is unbanned. *) +val member_unban : (GuildBanRemove.t -> unit) ref + +(** Dispatched when emojis are added or removed from a guild. *) +val guild_emojis_update : (GuildEmojisUpdate.t -> unit) ref + +(** Dispatched when a guild's integrations are updated. *) +(* val integrations_update : (Yojson.Safe.t -> unit) ref *) + +(** Dispatched when a member joins a guild. *) +val member_join : (GuildMemberAdd.t -> unit) ref + +(** Dispatched when a member leaves a guild. Is Dispatched alongside {!Client.member_ban} when a user is banned. *) +val member_leave : (GuildMemberRemove.t -> unit) ref + +(** Dispatched when a member object is updated. *) +val member_update : (GuildMemberUpdate.t -> unit) ref + +(** Dispatched when requesting guild members through {!Client.request_guild_members} *) +val members_chunk : (GuildMembersChunk.t -> unit) ref + +(** Dispatched when a role is created. *) +val role_create : (GuildRoleCreate.t -> unit) ref + +(** Dispatched when a role is edited. *) +val role_update : (GuildRoleUpdate.t -> unit) ref + +(** Dispatched when a role is deleted. *) +val role_delete : (GuildRoleDelete.t -> unit) ref + +(** Dispatched when a message is sent. *) +val message_create : (MessageCreate.t -> unit) ref + +(** Dispatched when a message is edited. This does not necessarily mean the content changed. *) +val message_update : (MessageUpdate.t -> unit) ref + +(** Dispatched when a message is deleted. *) +val message_delete : (MessageDelete.t -> unit) ref + +(** Dispatched when messages are bulk deleted. *) +val message_delete_bulk : (MessageDeleteBulk.t -> unit) ref + +(** Dispatched when a rection is added to a message. *) +val reaction_add : (ReactionAdd.t -> unit) ref + +(** Dispatched when a reaction is removed from a message. *) +val reaction_remove : (ReactionRemove.t -> unit) ref + +(** Dispatched when all reactions are cleared from a message. *) +val reaction_remove_all : (ReactionRemoveAll.t -> unit) ref + +(** Dispatched when a user updates their presence. *) +val presence_update : (PresenceUpdate.t -> unit) ref + +(** Dispatched when a typing indicator is displayed. *) +val typing_start : (TypingStart.t -> unit) ref + +(** Dispatched when the current user is updated. You most likely want {!Client.member_update} or {!Client.presence_update} instead. *) +val user_update : (UserUpdate.t -> unit) ref + +(** Dispatched when a webhook is updated. *) +val webhook_update : (WebhookUpdate.t -> unit) ref + +(** Dispatched as a fallback for unknown events. *) +val unknown : (Unknown.t -> unit) ref + +(**/**) +(* val voice_state_update : (Yojson.Safe.t -> unit) ref *) +(* val voice_server_update : (Yojson.Safe.t -> unit) ref *) \ No newline at end of file diff --git a/lib/gateway/event.ml b/lib/gateway/event.ml new file mode 100644 index 0000000..88dd50d --- /dev/null +++ b/lib/gateway/event.ml @@ -0,0 +1,176 @@ +open Async +open Core +open Event_models + +type t = +| READY of Ready.t +| RESUMED of Resumed.t +| CHANNEL_CREATE of ChannelCreate.t +| CHANNEL_UPDATE of ChannelUpdate.t +| CHANNEL_DELETE of ChannelDelete.t +| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t +| GUILD_CREATE of GuildCreate.t +| GUILD_UPDATE of GuildUpdate.t +| GUILD_DELETE of GuildDelete.t +| GUILD_BAN_ADD of GuildBanAdd.t +| GUILD_BAN_REMOVE of GuildBanRemove.t +| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t +(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.t *) +| GUILD_MEMBER_ADD of GuildMemberAdd.t +| GUILD_MEMBER_REMOVE of GuildMemberRemove.t +| GUILD_MEMBER_UPDATE of GuildMemberUpdate.t +| GUILD_MEMBERS_CHUNK of GuildMembersChunk.t +| GUILD_ROLE_CREATE of GuildRoleCreate.t +| GUILD_ROLE_UPDATE of GuildRoleUpdate.t +| GUILD_ROLE_DELETE of GuildRoleDelete.t +| MESSAGE_CREATE of MessageCreate.t +| MESSAGE_UPDATE of MessageUpdate.t +| MESSAGE_DELETE of MessageDelete.t +| MESSAGE_DELETE_BULK of MessageDeleteBulk.t +| REACTION_ADD of ReactionAdd.t +| REACTION_REMOVE of ReactionRemove.t +| REACTION_REMOVE_ALL of ReactionRemoveAll.t +| PRESENCE_UPDATE of PresenceUpdate.t +| TYPING_START of TypingStart.t +| USER_UPDATE of UserUpdate.t +(* | VOICE_STATE_UPDATE of Yojson.Safe.t *) +(* | VOICE_SERVER_UPDATE of Yojson.Safe.t *) +| WEBHOOK_UPDATE of WebhookUpdate.t +| UNKNOWN of Unknown.t + +let event_of_yojson ~contents = function + | "READY" -> READY Ready.(deserialize contents) + | "RESUMED" -> RESUMED Resumed.(deserialize contents) + | "CHANNEL_CREATE" -> CHANNEL_CREATE ChannelCreate.(deserialize contents) + | "CHANNEL_UPDATE" -> CHANNEL_UPDATE ChannelUpdate.(deserialize contents) + | "CHANNEL_DELETE" -> CHANNEL_DELETE ChannelDelete.(deserialize contents) + | "CHANNEL_PINS_UPDATE" -> CHANNEL_PINS_UPDATE ChannelPinsUpdate.(deserialize contents) + | "GUILD_CREATE" -> GUILD_CREATE GuildCreate.(deserialize contents) + | "GUILD_UPDATE" -> GUILD_UPDATE GuildUpdate.(deserialize contents) + | "GUILD_DELETE" -> GUILD_DELETE GuildDelete.(deserialize contents) + | "GUILD_BAN_ADD" -> GUILD_BAN_ADD GuildBanAdd.(deserialize contents) + | "GUILD_BAN_REMOVE" -> GUILD_BAN_REMOVE GuildBanRemove.(deserialize contents) + | "GUILD_EMOJIS_UPDATE" -> GUILD_EMOJIS_UPDATE GuildEmojisUpdate.(deserialize contents) + (* | "GUILD_INTEGRATIONS_UPDATE" -> GUILD_INTEGRATIONS_UPDATE contents *) + | "GUILD_MEMBER_ADD" -> GUILD_MEMBER_ADD GuildMemberAdd.(deserialize contents) + | "GUILD_MEMBER_REMOVE" -> GUILD_MEMBER_REMOVE GuildMemberRemove.(deserialize contents) + | "GUILD_MEMBER_UPDATE" -> GUILD_MEMBER_UPDATE GuildMemberUpdate.(deserialize contents) + | "GUILD_MEMBERS_CHUNK" -> GUILD_MEMBERS_CHUNK GuildMembersChunk.(deserialize contents) + | "GUILD_ROLE_CREATE" -> GUILD_ROLE_CREATE GuildRoleCreate.(deserialize contents) + | "GUILD_ROLE_UPDATE" -> GUILD_ROLE_UPDATE GuildRoleUpdate.(deserialize contents) + | "GUILD_ROLE_DELETE" -> GUILD_ROLE_DELETE GuildRoleDelete.(deserialize contents) + | "MESSAGE_CREATE" -> MESSAGE_CREATE MessageCreate.(deserialize contents) + | "MESSAGE_UPDATE" -> MESSAGE_UPDATE MessageUpdate.(deserialize contents) + | "MESSAGE_DELETE" -> MESSAGE_DELETE MessageDelete.(deserialize contents) + | "MESSAGE_DELETE_BULK" -> MESSAGE_DELETE_BULK MessageDeleteBulk.(deserialize contents) + | "MESSAGE_REACTION_ADD" -> REACTION_ADD ReactionAdd.(deserialize contents) + | "MESSAGE_REACTION_REMOVE" -> REACTION_REMOVE ReactionRemove.(deserialize contents) + | "MESSAGE_REACTION_REMOVE_ALL" -> REACTION_REMOVE_ALL ReactionRemoveAll.(deserialize contents) + | "PRESENCE_UPDATE" -> PRESENCE_UPDATE PresenceUpdate.(deserialize contents) + | "TYPING_START" -> TYPING_START TypingStart.(deserialize contents) + | "USER_UPDATE" -> USER_UPDATE UserUpdate.(deserialize contents) + (* | "VOICE_STATE_UPDATE" -> VOICE_STATE_UPDATE contents *) + (* | "VOICE_SERVER_UPDATE" -> VOICE_SERVER_UPDATE contents *) + | "WEBHOOK_UPDATE" -> WEBHOOK_UPDATE WebhookUpdate.(deserialize contents) + | s -> UNKNOWN Unknown.(deserialize s contents) + +let dispatch ev = + match ev with + | READY d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> Ready.update_cache cache d); + !Dispatch.ready d + | RESUMED d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> Resumed.update_cache cache d); + !Dispatch.resumed d + | CHANNEL_CREATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ChannelCreate.update_cache cache d); + !Dispatch.channel_create d + | CHANNEL_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ChannelUpdate.update_cache cache d); + !Dispatch.channel_update d + | CHANNEL_DELETE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ChannelDelete.update_cache cache d); + !Dispatch.channel_delete d + | CHANNEL_PINS_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ChannelPinsUpdate.update_cache cache d); + !Dispatch.channel_pins_update d + | GUILD_CREATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildCreate.update_cache cache d); + !Dispatch.guild_create d + | GUILD_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildUpdate.update_cache cache d); + !Dispatch.guild_update d + | GUILD_DELETE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildDelete.update_cache cache d); + !Dispatch.guild_delete d + | GUILD_BAN_ADD d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildBanAdd.update_cache cache d); + !Dispatch.member_ban d + | GUILD_BAN_REMOVE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildBanRemove.update_cache cache d); + !Dispatch.member_unban d + | GUILD_EMOJIS_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildEmojisUpdate.update_cache cache d); + !Dispatch.guild_emojis_update d + (* | GUILD_INTEGRATIONS_UPDATE d -> !Dispatch.integrations_update d *) + | GUILD_MEMBER_ADD d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildMemberAdd.update_cache cache d); + !Dispatch.member_join d + | GUILD_MEMBER_REMOVE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildMemberRemove.update_cache cache d); + !Dispatch.member_leave d + | GUILD_MEMBER_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildMemberUpdate.update_cache cache d); + !Dispatch.member_update d + | GUILD_MEMBERS_CHUNK d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildMembersChunk.update_cache cache d); + !Dispatch.members_chunk d + | GUILD_ROLE_CREATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildRoleCreate.update_cache cache d); + !Dispatch.role_create d + | GUILD_ROLE_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildRoleUpdate.update_cache cache d); + !Dispatch.role_update d + | GUILD_ROLE_DELETE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> GuildRoleDelete.update_cache cache d); + !Dispatch.role_delete d + | MESSAGE_CREATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> MessageCreate.update_cache cache d); + !Dispatch.message_create d + | MESSAGE_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> MessageUpdate.update_cache cache d); + !Dispatch.message_update d + | MESSAGE_DELETE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> MessageDelete.update_cache cache d); + !Dispatch.message_delete d + | MESSAGE_DELETE_BULK d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> MessageDeleteBulk.update_cache cache d); + !Dispatch.message_delete_bulk d + | REACTION_ADD d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ReactionAdd.update_cache cache d); + !Dispatch.reaction_add d + | REACTION_REMOVE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ReactionRemove.update_cache cache d); + !Dispatch.reaction_remove d + | REACTION_REMOVE_ALL d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> ReactionRemoveAll.update_cache cache d); + !Dispatch.reaction_remove_all d + | PRESENCE_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> PresenceUpdate.update_cache cache d); + !Dispatch.presence_update d + | TYPING_START d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> TypingStart.update_cache cache d); + !Dispatch.typing_start d + | USER_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> UserUpdate.update_cache cache d); + !Dispatch.user_update d + (* | VOICE_STATE_UPDATE d -> !Dispatch.voice_state_update d *) + (* | VOICE_SERVER_UPDATE d -> !Dispatch.voice_server_update d *) + | WEBHOOK_UPDATE d -> + Mvar.update_exn Cache.cache ~f:(fun cache -> WebhookUpdate.update_cache cache d); + !Dispatch.webhook_update d + | UNKNOWN d -> !Dispatch.unknown d + +let handle_event ~ev contents = + event_of_yojson ~contents ev + |> dispatch \ No newline at end of file diff --git a/lib/gateway/event.mli b/lib/gateway/event.mli new file mode 100644 index 0000000..4db3c84 --- /dev/null +++ b/lib/gateway/event.mli @@ -0,0 +1,49 @@ +(** Barebones of event dispatching. Most users will have no reason to look here. *) + +open Event_models + +(** Event dispatch type wrapper. Used internally. *) +type t = +| READY of Ready.t +| RESUMED of Resumed.t +| CHANNEL_CREATE of ChannelCreate.t +| CHANNEL_UPDATE of ChannelUpdate.t +| CHANNEL_DELETE of ChannelDelete.t +| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t +| GUILD_CREATE of GuildCreate.t +| GUILD_UPDATE of GuildUpdate.t +| GUILD_DELETE of GuildDelete.t +| GUILD_BAN_ADD of GuildBanAdd.t +| GUILD_BAN_REMOVE of GuildBanRemove.t +| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t +(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.t *) +| GUILD_MEMBER_ADD of GuildMemberAdd.t +| GUILD_MEMBER_REMOVE of GuildMemberRemove.t +| GUILD_MEMBER_UPDATE of GuildMemberUpdate.t +| GUILD_MEMBERS_CHUNK of GuildMembersChunk.t +| GUILD_ROLE_CREATE of GuildRoleCreate.t +| GUILD_ROLE_UPDATE of GuildRoleUpdate.t +| GUILD_ROLE_DELETE of GuildRoleDelete.t +| MESSAGE_CREATE of MessageCreate.t +| MESSAGE_UPDATE of MessageUpdate.t +| MESSAGE_DELETE of MessageDelete.t +| MESSAGE_DELETE_BULK of MessageDeleteBulk.t +| REACTION_ADD of ReactionAdd.t +| REACTION_REMOVE of ReactionRemove.t +| REACTION_REMOVE_ALL of ReactionRemoveAll.t +| PRESENCE_UPDATE of PresenceUpdate.t +| TYPING_START of TypingStart.t +| USER_UPDATE of UserUpdate.t +(* | VOICE_STATE_UPDATE of Yojson.Safe.t *) +(* | VOICE_SERVER_UPDATE of Yojson.Safe.t *) +| WEBHOOK_UPDATE of WebhookUpdate.t +| UNKNOWN of Unknown.t + +(** Used to convert an event string and payload into a t wrapper type. *) +val event_of_yojson : contents:Yojson.Safe.t -> string -> t + +(** Sends the event to the registered handler. *) +val dispatch : t -> unit + +(** Wrapper to other functions. This is called from the shards. *) +val handle_event : ev:string -> Yojson.Safe.t -> unit \ No newline at end of file diff --git a/lib/gateway/opcode.ml b/lib/gateway/opcode.ml new file mode 100644 index 0000000..32ab5b4 --- /dev/null +++ b/lib/gateway/opcode.ml @@ -0,0 +1,54 @@ +type t = + | DISPATCH + | HEARTBEAT + | IDENTIFY + | STATUS_UPDATE + | VOICE_STATE_UPDATE + | RESUME + | RECONNECT + | REQUEST_GUILD_MEMBERS + | INVALID_SESSION + | HELLO + | HEARTBEAT_ACK + +exception Invalid_Opcode of int + +let to_int = function + | DISPATCH -> 0 + | HEARTBEAT -> 1 + | IDENTIFY -> 2 + | STATUS_UPDATE -> 3 + | VOICE_STATE_UPDATE -> 4 + | RESUME -> 6 + | RECONNECT -> 7 + | REQUEST_GUILD_MEMBERS -> 8 + | INVALID_SESSION -> 9 + | HELLO -> 10 + | HEARTBEAT_ACK -> 11 + +let from_int = function + | 0 -> DISPATCH + | 1 -> HEARTBEAT + | 2 -> IDENTIFY + | 3 -> STATUS_UPDATE + | 4 -> VOICE_STATE_UPDATE + | 6 -> RESUME + | 7 -> RECONNECT + | 8 -> REQUEST_GUILD_MEMBERS + | 9 -> INVALID_SESSION + | 10 -> HELLO + | 11 -> HEARTBEAT_ACK + | op -> raise (Invalid_Opcode op) + +let to_string = function + | DISPATCH -> "DISPATCH" + | HEARTBEAT -> "HEARTBEAT" + | IDENTIFY -> "IDENTIFY" + | STATUS_UPDATE -> "STATUS_UPDATE" + | VOICE_STATE_UPDATE -> "VOICE_STATE_UPDATE" + | RESUME -> "RESUME" + | RECONNECT -> "RECONNECT" + | REQUEST_GUILD_MEMBERS -> "REQUEST_GUILD_MEMBER" + | INVALID_SESSION -> "INVALID_SESSION" + | HELLO -> "HELLO" + | HEARTBEAT_ACK -> "HEARTBEAT_ACK" \ No newline at end of file diff --git a/lib/gateway/opcode.mli b/lib/gateway/opcode.mli new file mode 100644 index 0000000..9fa5b96 --- /dev/null +++ b/lib/gateway/opcode.mli @@ -0,0 +1,29 @@ +(** Internal Opcode abstractions. *) + +(** Type of known opcodes. *) +type t = +| DISPATCH +| HEARTBEAT +| IDENTIFY +| STATUS_UPDATE +| VOICE_STATE_UPDATE +| RESUME +| RECONNECT +| REQUEST_GUILD_MEMBERS +| INVALID_SESSION +| HELLO +| HEARTBEAT_ACK + +(** Raised when receiving an invalid opcode. This should never occur. *) +exception Invalid_Opcode of int + +(** Converts an opcode to its integer form for outgoing frames. *) +val to_int : t -> int + +(** Converts an integer to an opcode for incoming frames. + Raise {!Invalid_Opcode} Raised when an unkown opcode is received. +*) +val from_int : int -> t + +(** Converts and opcode to a human-readable string. Used for logging purposes. *) +val to_string : t -> string \ No newline at end of file diff --git a/lib/gateway/sharder.ml b/lib/gateway/sharder.ml new file mode 100644 index 0000000..9fcb10d --- /dev/null +++ b/lib/gateway/sharder.ml @@ -0,0 +1,393 @@ +open Async +open Core +open Decompress +open Websocket_async + +exception Invalid_Payload +exception Failure_to_Establish_Heartbeat +exception Inflate_error of Zlib_inflate.error + +let window = Window.create ~witness:B.bytes + +let decompress src = + let in_buf = Bytes.create 0xFFFF in + let out_buf = Bytes.create 0xFFFF in + let window = Window.reset window in + let pos = ref 0 in + let src_len = String.length src in + let res = Buffer.create (src_len) in + Zlib_inflate.bytes in_buf out_buf + (fun dst -> + let len = min 0xFFFF (src_len - !pos) in + Caml.Bytes.blit_string src !pos dst 0 len; + pos := !pos + len; + len) + (fun obuf len -> + Buffer.add_subbytes res obuf 0 len; 0xFFFF) + (Zlib_inflate.default ~witness:B.bytes window) + |> function + | Ok _ -> Buffer.contents res + | Error exn -> raise (Inflate_error exn) + +module Shard = struct + type shard = + { compress: bool + ; id: int * int + ; hb_interval: Time.Span.t Ivar.t + ; hb_stopper: unit Ivar.t + ; large_threshold: int + ; pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t + ; ready: unit Ivar.t + ; seq: int + ; session: string option + ; url: string + ; _internal: Reader.t * Writer.t + } + + type 'a t = + { mutable state: 'a + ; mutable stopped: bool + ; mutable can_resume: bool + } + + let identify_lock = Mvar.create () + let _ = Mvar.set identify_lock () + + let parse ~compress (frame:[`Ok of Frame.t | `Eof]) = + match frame with + | `Ok s -> begin + let open Frame.Opcode in + match s.opcode with + | Text -> `Ok (Yojson.Safe.from_string s.content) + | Binary -> + if compress then `Ok (decompress s.content |> Yojson.Safe.from_string) + else `Error "Failed to decompress" + | Close -> `Close s.extension + | op -> + let op = Frame.Opcode.to_string op in + `Error ("Unexpected opcode " ^ op) + end + | `Eof -> `Eof + + let push_frame ?payload ~ev shard = + let content = match payload with + | None -> "" + | Some p -> + Yojson.Safe.to_string @@ `Assoc [ + "op", `Int (Opcode.to_int ev); + "d", p; + ] + in + let (_, write) = shard.pipe in + Pipe.write_if_open write @@ Frame.create ~content () + >>| fun () -> + shard + + let heartbeat shard = + match shard.seq with + | 0 -> return shard + | i -> + Logs.debug (fun m -> m "Heartbeating - Shard: [%d, %d] - Seq: %d" (fst shard.id) (snd shard.id) (shard.seq)); + push_frame ~payload:(`Int i) ~ev:HEARTBEAT shard + + let dispatch ~payload shard = + let module J = Yojson.Safe.Util in + let seq = J.(member "s" payload |> to_int) in + let t = J.(member "t" payload |> to_string) in + let data = J.member "d" payload in + let session = if t = "READY" then begin + Ivar.fill_if_empty shard.ready (); + Clock.after (Core.Time.Span.create ~sec:5 ()) + >>> (fun _ -> Mvar.put identify_lock () >>> ignore); + J.(member "session_id" data |> to_string_option) + end else None in + Event.handle_event ~ev:t data; + return + { shard with seq = seq + ; session = session + } + + let set_status ~(status:Yojson.Safe.t) shard = + let payload = match status with + | `Assoc ["name", `String name; "type", `Int t] + | `Assoc ["type", `Int t; "name", `String name] -> + `Assoc [ + "status", `String "online"; + "afk", `Bool false; + "since", `Null; + "game", `Assoc [ + "name", `String name; + "type", `Int t; + ] + ] + | `String name -> + `Assoc [ + "status", `String "online"; + "afk", `Bool false; + "since", `Null; + "game", `Assoc [ + "name", `String name; + "type", `Int 0 + ] + ] + | _ -> raise Invalid_Payload + in + Ivar.read shard.ready >>= fun _ -> + push_frame ~payload ~ev:STATUS_UPDATE shard + + let request_guild_members ?(query="") ?(limit=0) ~guild shard = + let payload = `Assoc [ + "guild_id", `String (Int.to_string guild); + "query", `String query; + "limit", `Int limit; + ] in + Ivar.read shard.ready >>= fun _ -> + push_frame ~payload ~ev:REQUEST_GUILD_MEMBERS shard + + let initialize ?data shard = + let module J = Yojson.Safe.Util in + let _ = match data with + | Some data -> Ivar.fill_if_empty shard.hb_interval (Time.Span.create ~ms:J.(member "heartbeat_interval" data |> to_int) ()) + | None -> raise Failure_to_Establish_Heartbeat + in + let shards = [`Int (fst shard.id); `Int (snd shard.id)] in + match shard.session with + | None -> begin + Mvar.take identify_lock >>= fun () -> + Logs.debug (fun m -> m "Identifying shard [%d, %d]" (fst shard.id) (snd shard.id)); + let payload = `Assoc + [ "token", `String !Client_options.token + ; "properties", `Assoc + [ "$os", `String Sys.os_type + ; "$device", `String "dis.ml" + ; "$browser", `String "dis.ml" + ] + ; "compress", `Bool shard.compress + ; "large_threshold", `Int shard.large_threshold + ; "shard", `List shards + ] + in + push_frame ~payload ~ev:IDENTIFY shard + >>| fun s -> s + end + | Some s -> + let payload = `Assoc + [ "token", `String !Client_options.token + ; "session_id", `String s + ; "seq", `Int shard.seq + ] + in + push_frame ~payload ~ev:RESUME shard + + let handle_frame ~f shard = + let module J = Yojson.Safe.Util in + let op = J.(member "op" f |> to_int) |> Opcode.from_int in + match op with + | DISPATCH -> dispatch ~payload:f shard + | HEARTBEAT -> heartbeat shard + | INVALID_SESSION -> begin + Logs.err (fun m -> m "Invalid Session on Shard [%d, %d]: %s" (fst shard.id) (snd shard.id) (Yojson.Safe.pretty_to_string f)); + if J.(member "d" f |> to_bool) then + initialize shard + else begin + initialize { shard with session = None; } + end + end + | RECONNECT -> initialize shard + | HELLO -> initialize ~data:(J.member "d" f) shard + | HEARTBEAT_ACK -> return shard + | opcode -> + Logs.warn (fun m -> m "Invalid Opcode: %s" (Opcode.to_string opcode)); + return shard + + let rec make_client + ~initialized + ~extra_headers + ~app_to_ws + ~ws_to_app + ~net_to_ws + ~ws_to_net + ?(ms=500) + uri = + client + ~initialized + ~extra_headers + ~app_to_ws + ~ws_to_app + ~net_to_ws + ~ws_to_net + uri + >>> fun res -> + match res with + | Ok () -> () + | Error _ -> + let backoff = Time.Span.create ~ms () in + Clock.after backoff >>> (fun () -> + make_client + ~initialized + ~extra_headers + ~app_to_ws + ~ws_to_app + ~net_to_ws + ~ws_to_net + ~ms:(min 60_000 (ms * 2)) + uri) + + + let create ~url ~shards ?(compress=true) ?(large_threshold=100) () = + let open Core in + let uri = (url ^ "?v=6&encoding=json") |> Uri.of_string in + let extra_headers = Http.Base.process_request_headers () in + let host = Option.value_exn ~message:"no host in uri" Uri.(host uri) in + let port = + match Uri.port uri, Uri_services.tcp_port_of_uri uri with + | Some p, _ -> p + | None, Some p -> p + | _ -> 443 in + let scheme = Option.value_exn ~message:"no scheme in uri" Uri.(scheme uri) in + let tcp_fun (net_to_ws, ws_to_net) = + let (app_to_ws, write) = Pipe.create () in + let (read, ws_to_app) = Pipe.create () in + let initialized = Ivar.create () in + make_client + ~initialized + ~extra_headers + ~app_to_ws + ~ws_to_app + ~net_to_ws + ~ws_to_net + uri; + Ivar.read initialized >>| fun () -> + { pipe = (read, write) + ; ready = Ivar.create () + ; hb_interval = Ivar.create () + ; hb_stopper = Ivar.create () + ; seq = 0 + ; id = shards + ; session = None + ; url + ; large_threshold + ; compress + ; _internal = (net_to_ws, ws_to_net) + } + in + match Unix.getaddrinfo host (string_of_int port) [] with + | [] -> failwithf "DNS resolution failed for %s" host () + | { ai_addr; _ } :: _ -> + let addr = + match scheme, ai_addr with + | _, ADDR_UNIX path -> `Unix_domain_socket path + | "https", ADDR_INET (h, p) + | "wss", ADDR_INET (h, p) -> + let h = Ipaddr_unix.of_inet_addr h in + `OpenSSL (h, p, Conduit_async.V2.Ssl.Config.create ()) + | _, ADDR_INET (h, p) -> + let h = Ipaddr_unix.of_inet_addr h in + `TCP (h, p) + in + Conduit_async.V2.connect addr >>= tcp_fun + + let shutdown ?(clean=false) ?(restart=true) t = + let _ = clean in + t.can_resume <- restart; + t.stopped <- true; + Logs.debug (fun m -> m "Performing shutdown. Shard [%d, %d]" (fst t.state.id) (snd t.state.id)); + Pipe.write_if_open (snd t.state.pipe) (Frame.close 1001) + >>= fun () -> + Ivar.fill_if_empty t.state.hb_stopper (); + Pipe.close_read (fst t.state.pipe); + Writer.close (snd t.state._internal) +end + +type t = { shards: (Shard.shard Shard.t) list } + +let start ?count ?compress ?large_threshold () = + let module J = Yojson.Safe.Util in + Http.get_gateway_bot () >>= fun data -> + let data = match data with + | Ok d -> d + | Error e -> Error.raise e + in + let url = J.(member "url" data |> to_string) in + let count = match count with + | Some c -> c + | None -> J.(member "shards" data |> to_int) + in + let shard_list = (0, count) in + Logs.info (fun m -> m "Connecting to %s" url); + let rec ev_loop (t:Shard.shard Shard.t) = + let step (t:Shard.shard Shard.t) = + Pipe.read (fst t.state.pipe) >>= fun frame -> + begin match Shard.parse ~compress:t.state.compress frame with + | `Ok f -> + Shard.handle_frame ~f t.state >>| fun s -> + t.state <- s + | `Close c -> + Logs.warn (fun m -> m "Close frame received. Code: %d" c); + Shard.shutdown t + | `Error e -> + Logs.warn (fun m -> m "Websocket soft error: %s" e); + return () + | `Eof -> + Logs.warn (fun m -> m "Websocket closed unexpectedly"); + Shard.shutdown t + end >>| fun () -> t + in + if t.stopped then return () + else step t >>= ev_loop + in + let rec gen_shards l a = + match l with + | (id, total) when id >= total -> return a + | (id, total) -> + let wrap ?(reuse:Shard.shard Shard.t option) state = match reuse with + | Some t -> + t.state <- state; + t.stopped <- false; + return t + | None -> + return Shard.{ state + ; stopped = false + ; can_resume = true + } + in + let create () = + Shard.create ~url ~shards:(id, total) ?compress ?large_threshold () + in + let rec bind (t:Shard.shard Shard.t) = + let _ = Ivar.read t.state.hb_interval >>> fun hb -> + Clock.every' + ~stop:(Ivar.read t.state.hb_stopper) + ~continue_on_error:true + hb (fun () -> Shard.heartbeat t.state >>| ignore) in + ev_loop t >>> (fun () -> Logs.debug (fun m -> m "Event loop stopped.")); + Pipe.closed (fst t.state.pipe) >>> (fun () -> if t.can_resume then + create () >>= wrap ~reuse:t >>= bind >>> ignore); + return t + in + create () >>= wrap >>= bind >>= fun t -> + gen_shards (id+1, total) (t :: a) + in + gen_shards shard_list [] + >>| fun shards -> + { shards } + +let set_status ~status sharder = + Deferred.all @@ List.map ~f:(fun t -> + Shard.set_status ~status t.state + ) sharder.shards + +let set_status_with ~f sharder = + Deferred.all @@ List.map ~f:(fun t -> + Shard.set_status ~status:(f t.state) t.state + ) sharder.shards + +let request_guild_members ?query ?limit ~guild sharder = + Deferred.all @@ List.map ~f:(fun t -> + Shard.request_guild_members ~guild ?query ?limit t.state + ) sharder.shards + +let shutdown_all ?restart sharder = + Deferred.all @@ List.map ~f:(fun t -> + Shard.shutdown ~clean:true ?restart t + ) sharder.shards \ No newline at end of file diff --git a/lib/gateway/sharder.mli b/lib/gateway/sharder.mli new file mode 100644 index 0000000..a5f18e6 --- /dev/null +++ b/lib/gateway/sharder.mli @@ -0,0 +1,102 @@ +(** Internal sharding manager. Most of this is accessed through {!Client}. *) + +open Core +open Async +open Websocket_async + +exception Invalid_Payload +exception Failure_to_Establish_Heartbeat + +type t + +(** Start the Sharder. This is called by {!Client.start}. *) +val start : + ?count:int -> + ?compress:bool -> + ?large_threshold:int -> + unit -> + t Deferred.t + +(** Module representing a single shard. *) +module Shard : sig + (** Representation of the state of a shard. *) + type shard = { + compress: bool; (** Whether to compress payloads. *) + id: int * int; (** A tuple as expected by Discord. First element is the current shard index, second element is the total shard count. *) + hb_interval: Time.Span.t Ivar.t; (** Time span between heartbeats, wrapped in an Ivar. *) + hb_stopper: unit Ivar.t; (** Stops the heartbeat sequencer when filled. *) + large_threshold: int; (** Minimum number of members needed for a guild to be considered large. *) + pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; (** Raw frame IO pipe used for websocket communications. *) + ready: unit Ivar.t; (** A simple Ivar indicating if the shard has received READY. *) + seq: int; (** Current sequence number *) + session: string option; (** Session id, if one exists. *) + url: string; (** The websocket URL in use. *) + _internal: Reader.t * Writer.t; + } + + (** Wrapper around an internal state, used to wrap {!shard}. *) + type 'a t = { + mutable state: 'a; + mutable stopped: bool; + mutable can_resume: bool; + } + + (** Send a heartbeat to Discord. This is handled automatically. *) + val heartbeat : + shard -> + shard Deferred.t + + (** Set the status of the shard. *) + val set_status : + status:Yojson.Safe.t -> + shard -> + shard Deferred.t + + (** Request guild members for the shard's guild. Causes dispatch of multiple {{!Dispatch.members_chunk}member chunk} events. *) + val request_guild_members : + ?query:string -> + ?limit:int -> + guild:Snowflake.t -> + shard -> + shard Deferred.t + + (** Create a new shard *) + val create : + url:string -> + shards:int * int -> + ?compress:bool -> + ?large_threshold:int -> + unit -> + shard Deferred.t + + val shutdown : + ?clean:bool -> + ?restart:bool -> + shard t -> + unit Deferred.t +end + +(** Calls {!Shard.set_status} for each shard registered with the sharder. *) +val set_status : + status:Yojson.Safe.t -> + t -> + Shard.shard list Deferred.t + +(** Like {!set_status} but takes a function with a {{!Shard.shard}shard} as its parameter and {{!Yojson.Safe.t}json} for its return. *) +val set_status_with : + f:(Shard.shard -> Yojson.Safe.t) -> + t -> + Shard.shard list Deferred.t + +(** Calls {!Shard.request_guild_members} for each shard registered with the sharder. *) +val request_guild_members : + ?query:string -> + ?limit:int -> + guild:Snowflake.t -> + t -> + Shard.shard list Deferred.t + +val shutdown_all : + ?restart:bool -> + t -> + unit list Deferred.t diff --git a/lib/http.ml b/lib/http.ml deleted file mode 100644 index 283ab69..0000000 --- a/lib/http.ml +++ /dev/null @@ -1,359 +0,0 @@ -open Core -open Async -open Cohttp - -module Base = struct - exception Invalid_Method - - let rl = ref Rl.empty - - let base_url = "https://discordapp.com/api/v7" - - let process_url path = - Uri.of_string (base_url ^ path) - - let process_request_body body = - body - |> Yojson.Safe.to_string - |> Cohttp_async.Body.of_string - - let process_request_headers () = - let h = Header.init () in - Header.add_list h [ - "User-Agent", "Dis.ml v0.1.0"; - "Authorization", ("Bot " ^ !Client_options.token); - "Content-Type", "application/json"; - "Connection", "keep-alive"; - ] - - let process_response path ((resp:Response.t), body) = - (match Response.headers resp - |> Rl.rl_of_header with - | Some r -> Mvar.put (Rl.find_exn !rl path) r - | None -> return ()) - >>= fun () -> - match resp |> Response.status |> Code.code_of_status with - | code when Code.is_success code -> body |> Cohttp_async.Body.to_string >>| Yojson.Safe.from_string >>= Deferred.Or_error.return - | code -> - body |> Cohttp_async.Body.to_string >>= fun body -> - let headers = Response.sexp_of_t resp |> Sexp.to_string_hum in - Logs.warn (fun m -> m "[Unsuccessful Response] [Code: %d]\n%s\n%s" code body headers); - Deferred.Or_error.errorf "Unsuccessful response received: %d - %s" code body - - let request ?(body=`Null) ?(query=[]) m path = - rl := Rl.update ~f:(function - | None -> - let r = Mvar.create () in - Mvar.set r Rl.default; - r - | Some r -> r - ) !rl path; - let limit = Rl.find_exn !rl path in - Mvar.take limit >>= fun limit -> - let process () = - let uri = Uri.add_query_params' (process_url path) query in - let headers = process_request_headers () in - let body = process_request_body body in - (match m with - | `DELETE -> Cohttp_async.Client.delete ~headers ~body uri - | `GET -> Cohttp_async.Client.get ~headers uri - | `PATCH -> Cohttp_async.Client.patch ~headers ~body uri - | `POST -> Cohttp_async.Client.post ~headers ~body uri - | `PUT -> Cohttp_async.Client.put ~headers ~body uri - | _ -> raise Invalid_Method) - >>= process_response path - in if limit.remaining > 0 then process () - else Clock.at (Core.Time.(Span.of_int_sec limit.reset |> of_span_since_epoch)) >>= process -end - -let get_gateway () = - Base.request `GET Endpoints.gateway - -let get_gateway_bot () = - Base.request `GET Endpoints.gateway_bot - -let get_channel channel_id = - Base.request `GET (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let modify_channel channel_id body = - Base.request ~body `PATCH (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let delete_channel channel_id = - Base.request `DELETE (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let get_messages channel_id limit (kind, id) = - Base.request ~query:[(kind, string_of_int id); ("limit", string_of_int limit)] `GET (Endpoints.channel_messages channel_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) - -let get_message channel_id message_id = - Base.request `GET (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let create_message channel_id body = - Base.request ~body:body `POST (Endpoints.channel_messages channel_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let create_reaction channel_id message_id emoji = - Base.request `PUT (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore - -let delete_own_reaction channel_id message_id emoji = - Base.request `DELETE (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore - -let delete_reaction channel_id message_id emoji user_id = - Base.request `DELETE (Endpoints.channel_reaction channel_id message_id emoji user_id) >>| Result.map ~f:ignore - -let get_reactions channel_id message_id emoji = - Base.request `GET (Endpoints.channel_reactions_get channel_id message_id emoji) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:User_t.of_yojson_exn) - -let delete_reactions channel_id message_id = - Base.request `DELETE (Endpoints.channel_reactions_delete channel_id message_id) >>| Result.map ~f:ignore - -let edit_message channel_id message_id body = - Base.request ~body `PATCH (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let delete_message channel_id message_id = - Base.request `DELETE (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:ignore - -let bulk_delete channel_id body = - Base.request ~body `POST (Endpoints.channel_bulk_delete channel_id) >>| Result.map ~f:ignore - -let edit_channel_permissions channel_id overwrite_id body = - Base.request ~body `PUT (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore - -let get_channel_invites channel_id = - Base.request `GET (Endpoints.channel_invites channel_id) - -let create_channel_invite channel_id body = - Base.request ~body `POST (Endpoints.channel_invites channel_id) - -let delete_channel_permission channel_id overwrite_id = - Base.request `DELETE (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore - -let broadcast_typing channel_id = - Base.request `POST (Endpoints.channel_typing channel_id) >>| Result.map ~f:ignore - -let get_pinned_messages channel_id = - Base.request `GET (Endpoints.channel_pins channel_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) - -let pin_message channel_id message_id = - Base.request `PUT (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore - -let unpin_message channel_id message_id = - Base.request `DELETE (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore - -let group_recipient_add channel_id user_id = - Base.request `PUT (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore - -let group_recipient_remove channel_id user_id = - Base.request `DELETE (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore - -let get_emojis guild_id = - Base.request `GET (Endpoints.guild_emojis guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Emoji.of_yojson_exn) - -let get_emoji guild_id emoji_id = - Base.request `GET (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let create_emoji guild_id body = - Base.request ~body `POST (Endpoints.guild_emojis guild_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let edit_emoji guild_id emoji_id body = - Base.request ~body `PATCH (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let delete_emoji guild_id emoji_id = - Base.request `DELETE (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:ignore - -let create_guild body = - Base.request ~body `POST Endpoints.guilds >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let get_guild guild_id = - Base.request `GET (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let edit_guild guild_id body = - Base.request ~body `PATCH (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let delete_guild guild_id = - Base.request `DELETE (Endpoints.guild guild_id) >>| Result.map ~f:ignore - -let get_guild_channels guild_id = - Base.request `GET (Endpoints.guild_channels guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Channel_t.(channel_wrapper_of_yojson_exn g |> wrap))) - -let create_guild_channel guild_id body = - Base.request ~body `POST (Endpoints.guild_channels guild_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let modify_guild_channel_positions guild_id body = - Base.request ~body `PATCH (Endpoints.guild_channels guild_id) >>| Result.map ~f:ignore - -let get_member guild_id user_id = - Base.request `GET (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) - -let get_members guild_id = - Base.request `GET (Endpoints.guild_members guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id))) - -let add_member guild_id user_id body = - Base.request ~body `PUT (Endpoints.guild_member guild_id user_id) - >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) - -let edit_member guild_id user_id body = - Base.request ~body `PATCH (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore - -let remove_member guild_id user_id body = - Base.request ~body `DELETE (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore - -let change_nickname guild_id body = - Base.request ~body `PATCH (Endpoints.guild_me_nick guild_id) - -let add_member_role guild_id user_id role_id = - Base.request `PUT (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore - -let remove_member_role guild_id user_id role_id = - Base.request `DELETE (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore - -let get_bans guild_id = - Base.request `GET (Endpoints.guild_bans guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Ban_t.of_yojson_exn) - -let get_ban guild_id user_id = - Base.request `GET (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:Ban_t.of_yojson_exn - -let guild_ban_add guild_id user_id body = - Base.request ~body `PUT (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore - -let guild_ban_remove guild_id user_id body = - Base.request ~body `DELETE (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore - -let get_roles guild_id = - Base.request `GET (Endpoints.guild_roles guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) - -let guild_role_add guild_id body = - Base.request ~body `POST (Endpoints.guild_roles guild_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) - -let guild_roles_edit guild_id body = - Base.request ~body `PATCH (Endpoints.guild_roles guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) - -let guild_role_edit guild_id role_id body = - Base.request ~body `PATCH (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) - -let guild_role_remove guild_id role_id = - Base.request `DELETE (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:ignore - -let guild_prune_count guild_id days = - Base.request ~query:[("days", Int.to_string days)] `GET (Endpoints.guild_prune guild_id) - >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) - -let guild_prune_start guild_id days = - Base.request ~query:[("days", Int.to_string days)] `POST (Endpoints.guild_prune guild_id) - >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) - -let get_guild_voice_regions guild_id = - Base.request `GET (Endpoints.guild_voice_regions guild_id) - -let get_guild_invites guild_id = - Base.request `GET (Endpoints.guild_invites guild_id) - -let get_integrations guild_id = - Base.request `GET (Endpoints.guild_integrations guild_id) - -let add_integration guild_id body = - Base.request ~body `POST (Endpoints.guild_integrations guild_id) >>| Result.map ~f:ignore - -let edit_integration guild_id integration_id body = - Base.request ~body `POST (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore - -let delete_integration guild_id integration_id = - Base.request `DELETE (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore - -let sync_integration guild_id integration_id = - Base.request `POST (Endpoints.guild_integration_sync guild_id integration_id) >>| Result.map ~f:ignore - -let get_guild_embed guild_id = - Base.request `GET (Endpoints.guild_embed guild_id) - -let edit_guild_embed guild_id body = - Base.request ~body `PATCH (Endpoints.guild_embed guild_id) - -let get_vanity_url guild_id = - Base.request `GET (Endpoints.guild_vanity_url guild_id) - -let get_invite invite_code = - Base.request `GET (Endpoints.invite invite_code) - -let delete_invite invite_code = - Base.request `DELETE (Endpoints.invite invite_code) - -let get_current_user () = - Base.request `GET Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn - -let edit_current_user body = - Base.request ~body `PATCH Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn - -let get_guilds () = - Base.request `GET Endpoints.me_guilds - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))) - -let leave_guild guild_id = - Base.request `DELETE (Endpoints.me_guild guild_id) >>| Result.map ~f:ignore - -let get_private_channels () = - Base.request `GET Endpoints.me_channels - -let create_dm body = - Base.request ~body `POST Endpoints.me_channels - -let create_group_dm body = - Base.request ~body `POST Endpoints.me_channels - -let get_connections () = - Base.request `GET Endpoints.me_connections - -let get_user user_id = - Base.request `GET (Endpoints.user user_id) >>| Result.map ~f:User_t.of_yojson_exn - -let get_voice_regions () = - Base.request `GET Endpoints.regions - -let create_webhook channel_id body = - Base.request ~body `POST (Endpoints.webhooks_channel channel_id) - -let get_channel_webhooks channel_id = - Base.request `GET (Endpoints.webhooks_channel channel_id) - -let get_guild_webhooks guild_id = - Base.request `GET (Endpoints.webhooks_guild guild_id) - -let get_webhook webhook_id = - Base.request `GET (Endpoints.webhook webhook_id) - -let get_webhook_with_token webhook_id token = - Base.request `GET (Endpoints.webhook_token webhook_id token) - -let edit_webhook webhook_id body = - Base.request ~body `PATCH (Endpoints.webhook webhook_id) - -let edit_webhook_with_token webhook_id token body = - Base.request ~body `PATCH (Endpoints.webhook_token webhook_id token) - -let delete_webhook webhook_id = - Base.request `DELETE (Endpoints.webhook webhook_id) >>| Result.map ~f:ignore - -let delete_webhook_with_token webhook_id token = - Base.request `DELETE (Endpoints.webhook_token webhook_id token) >>| Result.map ~f:ignore - -let execute_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_token webhook_id token) - -let execute_slack_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_slack webhook_id token) - -let execute_git_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_git webhook_id token) - -let get_audit_logs guild_id body = - Base.request ~body `GET (Endpoints.guild_audit_logs guild_id) - -let get_application_info () = - Base.request `GET (Endpoints.application_information) \ No newline at end of file diff --git a/lib/http.mli b/lib/http.mli deleted file mode 100644 index 0092d9b..0000000 --- a/lib/http.mli +++ /dev/null @@ -1,185 +0,0 @@ -open Async - -module Base : sig - exception Invalid_Method - - val base_url : string - - val process_url : string -> Uri.t - val process_request_body : Yojson.Safe.t -> Cohttp_async.Body.t - val process_request_headers : unit -> Cohttp.Header.t - - val process_response : - string -> - Cohttp_async.Response.t * Cohttp_async.Body.t -> - Yojson.Safe.t Deferred.Or_error.t - - val request : - ?body:Yojson.Safe.t -> - ?query:(string * string) list -> - [> `DELETE | `GET | `PATCH | `POST | `PUT ] -> - string -> - Yojson.Safe.t Deferred.Or_error.t -end - -val get_gateway : unit -> Yojson.Safe.t Deferred.Or_error.t -val get_gateway_bot : unit -> Yojson.Safe.t Deferred.Or_error.t -val get_channel : int -> Channel_t.t Deferred.Or_error.t -val modify_channel : - int -> Yojson.Safe.t -> Channel_t.t Deferred.Or_error.t -val delete_channel : int -> Channel_t.t Deferred.Or_error.t -val get_messages : int -> int -> string * int -> Message_t.t list Deferred.Or_error.t -val get_message : int -> int -> Message_t.t Deferred.Or_error.t -val create_message : - int -> Yojson.Safe.t -> Message_t.t Deferred.Or_error.t -val create_reaction : - int -> int -> string -> unit Deferred.Or_error.t -val delete_own_reaction : - int -> int -> string -> unit Deferred.Or_error.t -val delete_reaction : - int -> int -> string -> int -> unit Deferred.Or_error.t -val get_reactions : - int -> int -> string -> User_t.t list Deferred.Or_error.t -val delete_reactions : - int -> int -> unit Deferred.Or_error.t -val edit_message : - int -> - int -> Yojson.Safe.t -> Message_t.t Deferred.Or_error.t -val delete_message : - int -> int -> unit Deferred.Or_error.t -val bulk_delete : - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val edit_channel_permissions : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val get_channel_invites : int -> Yojson.Safe.t Deferred.Or_error.t -val create_channel_invite : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val delete_channel_permission : - int -> int -> unit Deferred.Or_error.t -val broadcast_typing : int -> unit Deferred.Or_error.t -val get_pinned_messages : int -> Message_t.t list Deferred.Or_error.t -val pin_message : int -> int -> unit Deferred.Or_error.t -val unpin_message : int -> int -> unit Deferred.Or_error.t -val group_recipient_add : - int -> int -> unit Deferred.Or_error.t -val group_recipient_remove : - int -> int -> unit Deferred.Or_error.t -val get_emojis : int -> Emoji.t list Deferred.Or_error.t -val get_emoji : int -> int -> Emoji.t Deferred.Or_error.t -val create_emoji : - int -> Yojson.Safe.t -> Emoji.t Deferred.Or_error.t -val edit_emoji : - int -> - int -> Yojson.Safe.t -> Emoji.t Deferred.Or_error.t -val delete_emoji : int -> int -> unit Deferred.Or_error.t -val create_guild : - Yojson.Safe.t -> Guild_t.t Deferred.Or_error.t -val get_guild : int -> Guild_t.t Deferred.Or_error.t -val edit_guild : - int -> Yojson.Safe.t -> Guild_t.t Deferred.Or_error.t -val delete_guild : int -> unit Deferred.Or_error.t -val get_guild_channels : int -> Channel_t.t list Deferred.Or_error.t -val create_guild_channel : - int -> Yojson.Safe.t -> Channel_t.t Deferred.Or_error.t -val modify_guild_channel_positions : - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val get_member : int -> int -> Member.t Deferred.Or_error.t -val get_members : int -> Member.t list Deferred.Or_error.t -val add_member : - int -> - int -> Yojson.Safe.t -> Member.t Deferred.Or_error.t -val edit_member : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val remove_member : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val change_nickname : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val add_member_role : - int -> int -> int -> unit Deferred.Or_error.t -val remove_member_role : - int -> int -> int -> unit Deferred.Or_error.t -val get_bans : int -> Ban.t list Deferred.Or_error.t -val get_ban : int -> int -> Ban.t Deferred.Or_error.t -val guild_ban_add : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val guild_ban_remove : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val get_roles : int -> Role_t.t list Deferred.Or_error.t -val guild_role_add : - int -> Yojson.Safe.t -> Role_t.t Deferred.Or_error.t -val guild_roles_edit : - int -> Yojson.Safe.t -> Role_t.t list Deferred.Or_error.t -val guild_role_edit : - int -> - int -> Yojson.Safe.t -> Role_t.t Deferred.Or_error.t -val guild_role_remove : - int -> int -> unit Deferred.Or_error.t -val guild_prune_count : - int -> int -> int Deferred.Or_error.t -val guild_prune_start : - int -> int -> int Deferred.Or_error.t -val get_guild_voice_regions : - int -> Yojson.Safe.t Deferred.Or_error.t -val get_guild_invites : int -> Yojson.Safe.t Deferred.Or_error.t -val get_integrations : int -> Yojson.Safe.t Deferred.Or_error.t -val add_integration : - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val edit_integration : - int -> - int -> Yojson.Safe.t -> unit Deferred.Or_error.t -val delete_integration : - int -> int -> unit Deferred.Or_error.t -val sync_integration : - int -> int -> unit Deferred.Or_error.t -val get_guild_embed : int -> Yojson.Safe.t Deferred.Or_error.t -val edit_guild_embed : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val get_vanity_url : int -> Yojson.Safe.t Deferred.Or_error.t -val get_invite : string -> Yojson.Safe.t Deferred.Or_error.t -val delete_invite : string -> Yojson.Safe.t Deferred.Or_error.t -val get_current_user : unit -> User_t.t Deferred.Or_error.t -val edit_current_user : - Yojson.Safe.t -> User_t.t Deferred.Or_error.t -val get_guilds : unit -> Guild_t.t list Deferred.Or_error.t -val leave_guild : int -> unit Deferred.Or_error.t -val get_private_channels : - unit -> Yojson.Safe.t Deferred.Or_error.t -val create_dm : - Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val create_group_dm : - Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val get_connections : unit -> Yojson.Safe.t Deferred.Or_error.t -val get_user : int -> User_t.t Deferred.Or_error.t -val get_voice_regions : unit -> Yojson.Safe.t Deferred.Or_error.t -val create_webhook : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val get_channel_webhooks : int -> Yojson.Safe.t Deferred.Or_error.t -val get_guild_webhooks : int -> Yojson.Safe.t Deferred.Or_error.t -val get_webhook : int -> Yojson.Safe.t Deferred.Or_error.t -val get_webhook_with_token : - int -> string -> Yojson.Safe.t Deferred.Or_error.t -val edit_webhook : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val edit_webhook_with_token : - int -> - string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val delete_webhook : int -> unit Deferred.Or_error.t -val delete_webhook_with_token : - int -> string -> unit Deferred.Or_error.t -val execute_webhook : - int -> - string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val execute_slack_webhook : - int -> - string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val execute_git_webhook : - int -> - string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val get_audit_logs : - int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t -val get_application_info : unit -> Yojson.Safe.t Deferred.Or_error.t \ No newline at end of file diff --git a/lib/http/endpoints.ml b/lib/http/endpoints.ml new file mode 100644 index 0000000..9263207 --- /dev/null +++ b/lib/http/endpoints.ml @@ -0,0 +1,63 @@ +open Printf + +let gateway = "/gateway" +let gateway_bot = "/gateway/bot" +let channel = sprintf "/channels/%d" +let channel_messages = sprintf "/channels/%d/messages" +let channel_message = sprintf "/channels/%d/messages/%d" +let channel_reaction_me = sprintf "/channels/%d/messages/%d/reactions/%s/@me" +let channel_reaction = sprintf "/channels/%d/messages/%d/reactions/%s/%d" +let channel_reactions_get = sprintf "/channels/%d/messages/%d/reactions/%s" +let channel_reactions_delete = sprintf "/channels/%d/messages/%d/reactions" +let channel_bulk_delete = sprintf "/channels/%d" +let channel_permission = sprintf "/channels/%d/permissions/%d" +let channel_permissions = sprintf "/channels/%d/permissions" +let channels = "/channels" +let channel_call_ring = sprintf "/channels/%d/call/ring" +let channel_invites = sprintf "/channels/%d/invites" +let channel_typing = sprintf "/channels/%d/typing" +let channel_pins = sprintf "/channels/%d/pins" +let channel_pin = sprintf "/channels/%d/pins/%d" +let guilds = "/guilds" +let guild = sprintf "/guilds/%d" +let guild_channels = sprintf "/guilds/%d/channels" +let guild_members = sprintf "/guilds/%d/members" +let guild_member = sprintf "/guilds/%d/members/%d" +let guild_member_role = sprintf "/guilds/%d/members/%d/roles/%d" +let guild_bans = sprintf "/guilds/%d/bans" +let guild_ban = sprintf "/guilds/%d/bans/%d" +let guild_roles = sprintf "/guilds/%d/roles" +let guild_role = sprintf "/guilds/%d/roles/%d" +let guild_prune = sprintf "/guilds/%d/prune" +let guild_voice_regions = sprintf "/guilds/%d/regions" +let guild_invites = sprintf "/guilds/%d/invites" +let guild_integrations = sprintf "/guilds/%d/integrations" +let guild_integration = sprintf "/guilds/%d/integrations/%d" +let guild_integration_sync = sprintf "/guilds/%d/integrations/%d/sync" +let guild_embed = sprintf "/guilds/%d/embed" +let guild_emojis = sprintf "/guilds/%d/emojis" +let guild_emoji = sprintf "/guilds/%d/emojis/%d" +let webhooks_guild = sprintf "/guilds/%d/webhooks" +let webhooks_channel = sprintf "/channels/%d/webhooks" +let webhook = sprintf "/webhooks/%d" +let webhook_token = sprintf "/webhooks/%d/%s" +let webhook_git = sprintf "/webhooks/%d/%s/github" +let webhook_slack = sprintf "/webhooks/%d/%s/slack" +let user = sprintf "/users/%d" +let me = "/users/@me" +let me_guilds = "/users/@me/guilds" +let me_guild = sprintf "/users/@me/guilds/%d" +let me_channels = "/users/@me/channels" +let me_connections = "/users/@me/connections" +let invite = sprintf "/invites/%s" +let regions = "/voice/regions" +let application_information = "/oauth2/applications/@me" +let group_recipient = sprintf "/channels/%d/recipients/%d" +let guild_me_nick = sprintf "/guilds/%d/members/@me/nick" +let guild_vanity_url = sprintf "/guilds/%d/vanity-url" +let guild_audit_logs = sprintf "/guilds/%d/audit-logs" +let cdn_embed_avatar = sprintf "/embed/avatars/%s.png" +let cdn_emoji = sprintf "/emojis/%s.%s" +let cdn_icon = sprintf "/icons/%d/%s.%s" +let cdn_avatar = sprintf "/avatars/%d/%s.%s" +let cdn_default_avatar = sprintf "/embed/avatars/%d" \ No newline at end of file diff --git a/lib/http/endpoints.mli b/lib/http/endpoints.mli new file mode 100644 index 0000000..33e2ea5 --- /dev/null +++ b/lib/http/endpoints.mli @@ -0,0 +1,63 @@ +(** Endpoint formatters used internally. *) + +val gateway : string +val gateway_bot : string +val channel : int -> string +val channel_messages : int -> string +val channel_message : int -> int -> string +val channel_reaction_me : int -> int -> string -> string +val channel_reaction : int -> int -> string -> int -> string +val channel_reactions_get : int -> int -> string -> string +val channel_reactions_delete : int -> int -> string +val channel_bulk_delete : int -> string +val channel_permission : int -> int -> string +val channel_permissions : int -> string +val channels : string +val channel_call_ring : int -> string +val channel_invites : int -> string +val channel_typing : int -> string +val channel_pins : int -> string +val channel_pin : int -> int -> string +val guilds : string +val guild : int -> string +val guild_channels : int -> string +val guild_members : int -> string +val guild_member : int -> int -> string +val guild_member_role : int -> int -> int -> string +val guild_bans : int -> string +val guild_ban : int -> int -> string +val guild_roles : int -> string +val guild_role : int -> int -> string +val guild_prune : int -> string +val guild_voice_regions : int -> string +val guild_invites : int -> string +val guild_integrations : int -> string +val guild_integration : int -> int -> string +val guild_integration_sync : int -> int -> string +val guild_embed : int -> string +val guild_emojis : int -> string +val guild_emoji : int -> int -> string +val webhooks_guild : int -> string +val webhooks_channel : int -> string +val webhook : int -> string +val webhook_token : int -> string -> string +val webhook_git : int -> string -> string +val webhook_slack : int -> string -> string +val user : int -> string +val me : string +val me_guilds : string +val me_guild : int -> string +val me_channels : string +val me_connections : string +val invite : string -> string +val regions : string +val application_information : string +val group_recipient : int -> int -> string +val guild_me_nick : int -> string +val guild_vanity_url : int -> string +val guild_audit_logs : int -> string +val cdn_embed_avatar : string -> string +val cdn_emoji : string -> string -> string +val cdn_icon : int -> string -> string -> string +val cdn_avatar : int -> string -> string -> string +val cdn_default_avatar : int -> string \ No newline at end of file diff --git a/lib/http/http.ml b/lib/http/http.ml new file mode 100644 index 0000000..e1b2998 --- /dev/null +++ b/lib/http/http.ml @@ -0,0 +1,360 @@ +open Core +open Async +open Cohttp + +module Base = struct + exception Invalid_Method + + let rl = ref Rl.empty + + let base_url = "https://discordapp.com/api/v7" + + let process_url path = + Uri.of_string (base_url ^ path) + + let process_request_body body = + body + |> Yojson.Safe.to_string + |> Cohttp_async.Body.of_string + + let process_request_headers () = + let h = Header.init () in + Header.add_list h [ + "User-Agent", "Dis.ml (https://gitlab.com/Mishio595/disml, v0.2.3)"; + "Authorization", ("Bot " ^ !Client_options.token); + "Content-Type", "application/json"; + "Connection", "keep-alive"; + ] + + let process_response path ((resp:Response.t), body) = + (match Response.headers resp + |> Rl.rl_of_header with + | Some r -> Mvar.put (Rl.find_exn !rl path) r + | None -> return ()) + >>= fun () -> + match resp |> Response.status |> Code.code_of_status with + | 204 -> Deferred.Or_error.return `Null + | code when Code.is_success code -> body |> Cohttp_async.Body.to_string >>| Yojson.Safe.from_string >>= Deferred.Or_error.return + | code -> + body |> Cohttp_async.Body.to_string >>= fun body -> + let headers = Response.sexp_of_t resp |> Sexp.to_string_hum in + Logs.warn (fun m -> m "[Unsuccessful Response] [Code: %d]\n%s\n%s" code body headers); + Deferred.Or_error.errorf "Unsuccessful response received: %d - %s" code body + + let request ?(body=`Null) ?(query=[]) m path = + rl := Rl.update ~f:(function + | None -> + let r = Mvar.create () in + Mvar.set r Rl.default; + r + | Some r -> r + ) !rl path; + let limit = Rl.find_exn !rl path in + Mvar.take limit >>= fun limit -> + let process () = + let uri = Uri.add_query_params' (process_url path) query in + let headers = process_request_headers () in + let body = process_request_body body in + (match m with + | `DELETE -> Cohttp_async.Client.delete ~headers ~body uri + | `GET -> Cohttp_async.Client.get ~headers uri + | `PATCH -> Cohttp_async.Client.patch ~headers ~body uri + | `POST -> Cohttp_async.Client.post ~headers ~body uri + | `PUT -> Cohttp_async.Client.put ~headers ~body uri + | _ -> raise Invalid_Method) + >>= process_response path + in if limit.remaining > 0 then process () + else Clock.at (Core.Time.(Span.of_int_sec limit.reset |> of_span_since_epoch)) >>= process +end + +let get_gateway () = + Base.request `GET Endpoints.gateway + +let get_gateway_bot () = + Base.request `GET Endpoints.gateway_bot + +let get_channel channel_id = + Base.request `GET (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) + +let modify_channel channel_id body = + Base.request ~body `PATCH (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) + +let delete_channel channel_id = + Base.request `DELETE (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) + +let get_messages channel_id limit (kind, id) = + Base.request ~query:[(kind, string_of_int id); ("limit", string_of_int limit)] `GET (Endpoints.channel_messages channel_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) + +let get_message channel_id message_id = + Base.request `GET (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn + +let create_message channel_id body = + Base.request ~body:body `POST (Endpoints.channel_messages channel_id) >>| Result.map ~f:Message_t.of_yojson_exn + +let create_reaction channel_id message_id emoji = + Base.request `PUT (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore + +let delete_own_reaction channel_id message_id emoji = + Base.request `DELETE (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore + +let delete_reaction channel_id message_id emoji user_id = + Base.request `DELETE (Endpoints.channel_reaction channel_id message_id emoji user_id) >>| Result.map ~f:ignore + +let get_reactions channel_id message_id emoji = + Base.request `GET (Endpoints.channel_reactions_get channel_id message_id emoji) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:User_t.of_yojson_exn) + +let delete_reactions channel_id message_id = + Base.request `DELETE (Endpoints.channel_reactions_delete channel_id message_id) >>| Result.map ~f:ignore + +let edit_message channel_id message_id body = + Base.request ~body `PATCH (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn + +let delete_message channel_id message_id = + Base.request `DELETE (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:ignore + +let bulk_delete channel_id body = + Base.request ~body `POST (Endpoints.channel_bulk_delete channel_id) >>| Result.map ~f:ignore + +let edit_channel_permissions channel_id overwrite_id body = + Base.request ~body `PUT (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore + +let get_channel_invites channel_id = + Base.request `GET (Endpoints.channel_invites channel_id) + +let create_channel_invite channel_id body = + Base.request ~body `POST (Endpoints.channel_invites channel_id) + +let delete_channel_permission channel_id overwrite_id = + Base.request `DELETE (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore + +let broadcast_typing channel_id = + Base.request `POST (Endpoints.channel_typing channel_id) >>| Result.map ~f:ignore + +let get_pinned_messages channel_id = + Base.request `GET (Endpoints.channel_pins channel_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) + +let pin_message channel_id message_id = + Base.request `PUT (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore + +let unpin_message channel_id message_id = + Base.request `DELETE (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore + +let group_recipient_add channel_id user_id = + Base.request `PUT (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore + +let group_recipient_remove channel_id user_id = + Base.request `DELETE (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore + +let get_emojis guild_id = + Base.request `GET (Endpoints.guild_emojis guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Emoji.of_yojson_exn) + +let get_emoji guild_id emoji_id = + Base.request `GET (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn + +let create_emoji guild_id body = + Base.request ~body `POST (Endpoints.guild_emojis guild_id) >>| Result.map ~f:Emoji.of_yojson_exn + +let edit_emoji guild_id emoji_id body = + Base.request ~body `PATCH (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn + +let delete_emoji guild_id emoji_id = + Base.request `DELETE (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:ignore + +let create_guild body = + Base.request ~body `POST Endpoints.guilds >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) + +let get_guild guild_id = + Base.request `GET (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) + +let edit_guild guild_id body = + Base.request ~body `PATCH (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) + +let delete_guild guild_id = + Base.request `DELETE (Endpoints.guild guild_id) >>| Result.map ~f:ignore + +let get_guild_channels guild_id = + Base.request `GET (Endpoints.guild_channels guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Channel_t.(channel_wrapper_of_yojson_exn g |> wrap))) + +let create_guild_channel guild_id body = + Base.request ~body `POST (Endpoints.guild_channels guild_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) + +let modify_guild_channel_positions guild_id body = + Base.request ~body `PATCH (Endpoints.guild_channels guild_id) >>| Result.map ~f:ignore + +let get_member guild_id user_id = + Base.request `GET (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) + +let get_members guild_id = + Base.request `GET (Endpoints.guild_members guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id))) + +let add_member guild_id user_id body = + Base.request ~body `PUT (Endpoints.guild_member guild_id user_id) + >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) + +let edit_member guild_id user_id body = + Base.request ~body `PATCH (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore + +let remove_member guild_id user_id body = + Base.request ~body `DELETE (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore + +let change_nickname guild_id body = + Base.request ~body `PATCH (Endpoints.guild_me_nick guild_id) + +let add_member_role guild_id user_id role_id = + Base.request `PUT (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore + +let remove_member_role guild_id user_id role_id = + Base.request `DELETE (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore + +let get_bans guild_id = + Base.request `GET (Endpoints.guild_bans guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Ban_t.of_yojson_exn) + +let get_ban guild_id user_id = + Base.request `GET (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:Ban_t.of_yojson_exn + +let guild_ban_add guild_id user_id body = + Base.request ~body `PUT (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore + +let guild_ban_remove guild_id user_id body = + Base.request ~body `DELETE (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore + +let get_roles guild_id = + Base.request `GET (Endpoints.guild_roles guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) + +let guild_role_add guild_id body = + Base.request ~body `POST (Endpoints.guild_roles guild_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) + +let guild_roles_edit guild_id body = + Base.request ~body `PATCH (Endpoints.guild_roles guild_id) + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) + +let guild_role_edit guild_id role_id body = + Base.request ~body `PATCH (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) + +let guild_role_remove guild_id role_id = + Base.request `DELETE (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:ignore + +let guild_prune_count guild_id days = + Base.request ~query:[("days", Int.to_string days)] `GET (Endpoints.guild_prune guild_id) + >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) + +let guild_prune_start guild_id days = + Base.request ~query:[("days", Int.to_string days)] `POST (Endpoints.guild_prune guild_id) + >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) + +let get_guild_voice_regions guild_id = + Base.request `GET (Endpoints.guild_voice_regions guild_id) + +let get_guild_invites guild_id = + Base.request `GET (Endpoints.guild_invites guild_id) + +let get_integrations guild_id = + Base.request `GET (Endpoints.guild_integrations guild_id) + +let add_integration guild_id body = + Base.request ~body `POST (Endpoints.guild_integrations guild_id) >>| Result.map ~f:ignore + +let edit_integration guild_id integration_id body = + Base.request ~body `POST (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore + +let delete_integration guild_id integration_id = + Base.request `DELETE (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore + +let sync_integration guild_id integration_id = + Base.request `POST (Endpoints.guild_integration_sync guild_id integration_id) >>| Result.map ~f:ignore + +let get_guild_embed guild_id = + Base.request `GET (Endpoints.guild_embed guild_id) + +let edit_guild_embed guild_id body = + Base.request ~body `PATCH (Endpoints.guild_embed guild_id) + +let get_vanity_url guild_id = + Base.request `GET (Endpoints.guild_vanity_url guild_id) + +let get_invite invite_code = + Base.request `GET (Endpoints.invite invite_code) + +let delete_invite invite_code = + Base.request `DELETE (Endpoints.invite invite_code) + +let get_current_user () = + Base.request `GET Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn + +let edit_current_user body = + Base.request ~body `PATCH Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn + +let get_guilds () = + Base.request `GET Endpoints.me_guilds + >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))) + +let leave_guild guild_id = + Base.request `DELETE (Endpoints.me_guild guild_id) >>| Result.map ~f:ignore + +let get_private_channels () = + Base.request `GET Endpoints.me_channels + +let create_dm body = + Base.request ~body `POST Endpoints.me_channels + +let create_group_dm body = + Base.request ~body `POST Endpoints.me_channels + +let get_connections () = + Base.request `GET Endpoints.me_connections + +let get_user user_id = + Base.request `GET (Endpoints.user user_id) >>| Result.map ~f:User_t.of_yojson_exn + +let get_voice_regions () = + Base.request `GET Endpoints.regions + +let create_webhook channel_id body = + Base.request ~body `POST (Endpoints.webhooks_channel channel_id) + +let get_channel_webhooks channel_id = + Base.request `GET (Endpoints.webhooks_channel channel_id) + +let get_guild_webhooks guild_id = + Base.request `GET (Endpoints.webhooks_guild guild_id) + +let get_webhook webhook_id = + Base.request `GET (Endpoints.webhook webhook_id) + +let get_webhook_with_token webhook_id token = + Base.request `GET (Endpoints.webhook_token webhook_id token) + +let edit_webhook webhook_id body = + Base.request ~body `PATCH (Endpoints.webhook webhook_id) + +let edit_webhook_with_token webhook_id token body = + Base.request ~body `PATCH (Endpoints.webhook_token webhook_id token) + +let delete_webhook webhook_id = + Base.request `DELETE (Endpoints.webhook webhook_id) >>| Result.map ~f:ignore + +let delete_webhook_with_token webhook_id token = + Base.request `DELETE (Endpoints.webhook_token webhook_id token) >>| Result.map ~f:ignore + +let execute_webhook webhook_id token body = + Base.request ~body `POST (Endpoints.webhook_token webhook_id token) + +let execute_slack_webhook webhook_id token body = + Base.request ~body `POST (Endpoints.webhook_slack webhook_id token) + +let execute_git_webhook webhook_id token body = + Base.request ~body `POST (Endpoints.webhook_git webhook_id token) + +let get_audit_logs guild_id body = + Base.request ~body `GET (Endpoints.guild_audit_logs guild_id) + +let get_application_info () = + Base.request `GET (Endpoints.application_information) \ No newline at end of file diff --git a/lib/http/http.mli b/lib/http/http.mli new file mode 100644 index 0000000..fe587c7 --- /dev/null +++ b/lib/http/http.mli @@ -0,0 +1,185 @@ +open Async + +module Base : sig + exception Invalid_Method + + val base_url : string + + val process_url : string -> Uri.t + val process_request_body : Yojson.Safe.t -> Cohttp_async.Body.t + val process_request_headers : unit -> Cohttp.Header.t + + val process_response : + string -> + Cohttp_async.Response.t * Cohttp_async.Body.t -> + Yojson.Safe.t Deferred.Or_error.t + + val request : + ?body:Yojson.Safe.t -> + ?query:(string * string) list -> + [> `DELETE | `GET | `PATCH | `POST | `PUT ] -> + string -> + Yojson.Safe.t Deferred.Or_error.t +end + +val get_gateway : unit -> Yojson.Safe.t Deferred.Or_error.t +val get_gateway_bot : unit -> Yojson.Safe.t Deferred.Or_error.t +val get_channel : int -> Channel_t.t Deferred.Or_error.t +val modify_channel : + int -> Yojson.Safe.t -> Channel_t.t Deferred.Or_error.t +val delete_channel : int -> Channel_t.t Deferred.Or_error.t +val get_messages : int -> int -> string * int -> Message_t.t list Deferred.Or_error.t +val get_message : int -> int -> Message_t.t Deferred.Or_error.t +val create_message : + int -> Yojson.Safe.t -> Message_t.t Deferred.Or_error.t +val create_reaction : + int -> int -> string -> unit Deferred.Or_error.t +val delete_own_reaction : + int -> int -> string -> unit Deferred.Or_error.t +val delete_reaction : + int -> int -> string -> int -> unit Deferred.Or_error.t +val get_reactions : + int -> int -> string -> User_t.t list Deferred.Or_error.t +val delete_reactions : + int -> int -> unit Deferred.Or_error.t +val edit_message : + int -> + int -> Yojson.Safe.t -> Message_t.t Deferred.Or_error.t +val delete_message : + int -> int -> unit Deferred.Or_error.t +val bulk_delete : + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val edit_channel_permissions : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val get_channel_invites : int -> Yojson.Safe.t Deferred.Or_error.t +val create_channel_invite : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val delete_channel_permission : + int -> int -> unit Deferred.Or_error.t +val broadcast_typing : int -> unit Deferred.Or_error.t +val get_pinned_messages : int -> Message_t.t list Deferred.Or_error.t +val pin_message : int -> int -> unit Deferred.Or_error.t +val unpin_message : int -> int -> unit Deferred.Or_error.t +val group_recipient_add : + int -> int -> unit Deferred.Or_error.t +val group_recipient_remove : + int -> int -> unit Deferred.Or_error.t +val get_emojis : int -> Emoji.t list Deferred.Or_error.t +val get_emoji : int -> int -> Emoji.t Deferred.Or_error.t +val create_emoji : + int -> Yojson.Safe.t -> Emoji.t Deferred.Or_error.t +val edit_emoji : + int -> + int -> Yojson.Safe.t -> Emoji.t Deferred.Or_error.t +val delete_emoji : int -> int -> unit Deferred.Or_error.t +val create_guild : + Yojson.Safe.t -> Guild_t.t Deferred.Or_error.t +val get_guild : int -> Guild_t.t Deferred.Or_error.t +val edit_guild : + int -> Yojson.Safe.t -> Guild_t.t Deferred.Or_error.t +val delete_guild : int -> unit Deferred.Or_error.t +val get_guild_channels : int -> Channel_t.t list Deferred.Or_error.t +val create_guild_channel : + int -> Yojson.Safe.t -> Channel_t.t Deferred.Or_error.t +val modify_guild_channel_positions : + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val get_member : int -> int -> Member.t Deferred.Or_error.t +val get_members : int -> Member.t list Deferred.Or_error.t +val add_member : + int -> + int -> Yojson.Safe.t -> Member.t Deferred.Or_error.t +val edit_member : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val remove_member : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val change_nickname : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val add_member_role : + int -> int -> int -> unit Deferred.Or_error.t +val remove_member_role : + int -> int -> int -> unit Deferred.Or_error.t +val get_bans : int -> Ban.t list Deferred.Or_error.t +val get_ban : int -> int -> Ban.t Deferred.Or_error.t +val guild_ban_add : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val guild_ban_remove : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val get_roles : int -> Role_t.t list Deferred.Or_error.t +val guild_role_add : + int -> Yojson.Safe.t -> Role_t.t Deferred.Or_error.t +val guild_roles_edit : + int -> Yojson.Safe.t -> Role_t.t list Deferred.Or_error.t +val guild_role_edit : + int -> + int -> Yojson.Safe.t -> Role_t.t Deferred.Or_error.t +val guild_role_remove : + int -> int -> unit Deferred.Or_error.t +val guild_prune_count : + int -> int -> int Deferred.Or_error.t +val guild_prune_start : + int -> int -> int Deferred.Or_error.t +val get_guild_voice_regions : + int -> Yojson.Safe.t Deferred.Or_error.t +val get_guild_invites : int -> Yojson.Safe.t Deferred.Or_error.t +val get_integrations : int -> Yojson.Safe.t Deferred.Or_error.t +val add_integration : + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val edit_integration : + int -> + int -> Yojson.Safe.t -> unit Deferred.Or_error.t +val delete_integration : + int -> int -> unit Deferred.Or_error.t +val sync_integration : + int -> int -> unit Deferred.Or_error.t +val get_guild_embed : int -> Yojson.Safe.t Deferred.Or_error.t +val edit_guild_embed : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val get_vanity_url : int -> Yojson.Safe.t Deferred.Or_error.t +val get_invite : string -> Yojson.Safe.t Deferred.Or_error.t +val delete_invite : string -> Yojson.Safe.t Deferred.Or_error.t +val get_current_user : unit -> User_t.t Deferred.Or_error.t +val edit_current_user : + Yojson.Safe.t -> User_t.t Deferred.Or_error.t +val get_guilds : unit -> Guild_t.t list Deferred.Or_error.t +val leave_guild : int -> unit Deferred.Or_error.t +val get_private_channels : + unit -> Yojson.Safe.t Deferred.Or_error.t +val create_dm : + Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val create_group_dm : + Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val get_connections : unit -> Yojson.Safe.t Deferred.Or_error.t +val get_user : int -> User_t.t Deferred.Or_error.t +val get_voice_regions : unit -> Yojson.Safe.t Deferred.Or_error.t +val create_webhook : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val get_channel_webhooks : int -> Yojson.Safe.t Deferred.Or_error.t +val get_guild_webhooks : int -> Yojson.Safe.t Deferred.Or_error.t +val get_webhook : int -> Yojson.Safe.t Deferred.Or_error.t +val get_webhook_with_token : + int -> string -> Yojson.Safe.t Deferred.Or_error.t +val edit_webhook : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val edit_webhook_with_token : + int -> + string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val delete_webhook : int -> unit Deferred.Or_error.t +val delete_webhook_with_token : + int -> string -> unit Deferred.Or_error.t +val execute_webhook : + int -> + string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val execute_slack_webhook : + int -> + string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val execute_git_webhook : + int -> + string -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val get_audit_logs : + int -> Yojson.Safe.t -> Yojson.Safe.t Deferred.Or_error.t +val get_application_info : unit -> Yojson.Safe.t Deferred.Or_error.t \ No newline at end of file diff --git a/lib/impl.ml b/lib/impl.ml deleted file mode 100644 index ae092d3..0000000 --- a/lib/impl.ml +++ /dev/null @@ -1,168 +0,0 @@ -module Channel(T : S.HasSnowflake) : S.ChannelImpl with type t := T.t = struct - open Core - include T - - exception Invalid_message - exception No_message_found - - let send_message ?embed ?content ?file ?(tts=false) ch = - let embed = match embed with - | Some e -> Embed.to_yojson e - | None -> `Null in - let content = match content with - | Some c -> `String c - | None -> `Null in - let file = match file with - | Some f -> `String f - | None -> `Null in - let () = match embed, content with - | `Null, `Null -> raise Invalid_message - | _ -> () in - Http.create_message (get_id ch) (`Assoc [ - ("embed", embed); - ("content", content); - ("file", file); - ("tts", `Bool tts); - ]) - - let say content ch = - send_message ~content ch - - let delete ch = - Http.delete_channel (get_id ch) - - let get_message ~id ch = - Http.get_message (get_id ch) id - - let get_messages ?(mode=`Around) ?id ?(limit=50) ch = - let kind = match mode with - | `Around -> "around", limit - | `Before -> "before", limit - | `After -> "after", limit - in - let id = match id with - | Some id -> id - | None -> raise No_message_found in - Http.get_messages (get_id ch) id kind - - let broadcast_typing ch = - Http.broadcast_typing (get_id ch) - - let get_pins ch = - Http.get_pinned_messages (get_id ch) - - let bulk_delete msgs ch = - let msgs = `List (List.map ~f:(fun id -> `Int id) msgs) in - Http.bulk_delete (get_id ch) msgs -end - -module Guild(T : S.HasSnowflake) : S.GuildImpl with type t := T.t = struct - include T - - let ban_user ~id ?(reason="") ?(days=0) guild = - Http.guild_ban_add (get_id guild) id (`Assoc [ - ("delete-message-days", `Int days); - ("reason", `String reason); - ]) - - let create_emoji ~name ~image guild = - Http.create_emoji (get_id guild) (`Assoc [ - ("name", `String name); - ("image", `String image); - ("roles", `List []); - ]) - - let create_role ~name ?colour ?permissions ?hoist ?mentionable guild = - let payload = ("name", `String name) :: [] in - let payload = match permissions with - | Some p -> ("permissions", `Int p) :: payload - | None -> payload - in let payload = match colour with - | Some c -> ("color", `Int c) :: payload - | None -> payload - in let payload = match hoist with - | Some h -> ("hoist", `Bool h) :: payload - | None -> payload - in let payload = match mentionable with - | Some m -> ("mentionable", `Bool m) :: payload - | None -> payload - in Http.guild_role_add (get_id guild) (`Assoc payload) - - let create_channel ~mode ~name guild = - let kind = match mode with - | `Text -> 0 - | `Voice -> 2 - | `Category -> 4 - in Http.create_guild_channel (get_id guild) (`Assoc [ - ("name", `String name); - ("type", `Int kind); - ]) - - let delete guild = - Http.delete_guild (get_id guild) - - let get_ban ~id guild = - Http.get_ban (get_id guild) id - - let get_bans guild = - Http.get_bans (get_id guild) - - let get_emoji ~id guild = - Http.get_emoji (get_id guild) id - - (* TODO add invite abstraction? *) - let get_invites guild = - Http.get_guild_invites (get_id guild) - - let get_prune_count ~days guild = - Http.guild_prune_count (get_id guild) days - - (* TODO add webhook abstraction? *) - let get_webhooks guild = - Http.get_guild_webhooks (get_id guild) - - let kick_user ~id ?reason guild = - let payload = match reason with - | Some r -> `Assoc [("reason", `String r)] - | None -> `Null - in Http.remove_member (get_id guild) id payload - - let leave guild = - Http.leave_guild (get_id guild) - - (* TODO Voice region abstractions? *) - let list_voice_regions guild = - Http.get_guild_voice_regions (get_id guild) - - let prune ~days guild = - Http.guild_prune_start (get_id guild) days - - let request_members guild = - Http.get_members (get_id guild) - - let set_afk_channel ~id guild = Http.edit_guild (get_id guild) (`Assoc [ - ("afk_channel_id", `Int id); - ]) - - let set_afk_timeout ~timeout guild = Http.edit_guild (get_id guild) (`Assoc [ - ("afk_timeout", `Int timeout); - ]) - - let set_name ~name guild = Http.edit_guild (get_id guild) (`Assoc [ - ("name", `String name); - ]) - - let set_icon ~icon guild = Http.edit_guild (get_id guild) (`Assoc [ - ("icon", `String icon); - ]) - - let unban_user ~id ?reason guild = - let payload = match reason with - | Some r -> `Assoc [("reason", `String r)] - | None -> `Null - in Http.guild_ban_remove (get_id guild) id payload -end - -module User(T : S.HasSnowflake) : S.UserImpl with type t := T.t = struct - include T -end \ No newline at end of file diff --git a/lib/models/channel/channel.ml b/lib/models/channel/channel.ml index 6ccc66d..47cf500 100644 --- a/lib/models/channel/channel.ml +++ b/lib/models/channel/channel.ml @@ -1,3 +1,55 @@ +open Core include Channel_t -include Impl.Channel(Channel_t) \ No newline at end of file +exception Invalid_message +exception No_message_found + +let send_message ?embed ?content ?file ?(tts=false) ch = + let embed = match embed with + | Some e -> Embed.to_yojson e + | None -> `Null in + let content = match content with + | Some c -> `String c + | None -> `Null in + let file = match file with + | Some f -> `String f + | None -> `Null in + let () = match embed, content with + | `Null, `Null -> raise Invalid_message + | _ -> () in + Http.create_message (get_id ch) (`Assoc [ + ("embed", embed); + ("content", content); + ("file", file); + ("tts", `Bool tts); + ]) + +let say content ch = + send_message ~content ch + +let delete ch = + Http.delete_channel (get_id ch) + +let get_message ~id ch = + Http.get_message (get_id ch) id + +let get_messages ?(mode=`Around) ?id ?(limit=50) ch = + let kind = match mode with + | `Around -> "around", limit + | `Before -> "before", limit + | `After -> "after", limit + in + let id = match id with + | Some id -> id + | None -> raise No_message_found in + Http.get_messages (get_id ch) id kind + +let broadcast_typing ch = + Http.broadcast_typing (get_id ch) + +let get_pins ch = + Http.get_pinned_messages (get_id ch) + +let bulk_delete msgs ch = + let msgs = `List (List.map ~f:(fun id -> `Int id) msgs) in + Http.bulk_delete (get_id ch) msgs \ No newline at end of file diff --git a/lib/models/channel/channel.mli b/lib/models/channel/channel.mli index 3eece7d..9e981ae 100644 --- a/lib/models/channel/channel.mli +++ b/lib/models/channel/channel.mli @@ -1,3 +1,46 @@ +open Async include module type of Channel_t -include S.ChannelImpl with - type t := Channel_t.t \ No newline at end of file + +exception Invalid_message +exception No_message_found + +(** Advanced message sending. + + Raises {!Invalid_message} if one of content or embed is not set. + + {3 Examples} + {[ + open Core + open Disml + + let check_command (msg : Message.t) = + if String.is_prefix ~prefix:"!hello" msg.content then + let embed = Embed.(default |> title "Hello World!") in + Channel_id.send_message ~embed msg.channel_id >>> ignore + + Client.message_create := check_command + ]} +*) +val send_message : + ?embed:Embed.t -> + ?content:string -> + ?file:string -> + ?tts:bool -> + t -> + Message_t.t Deferred.Or_error.t + +(** [say str ch] is equivalent to [send_message ~content:str ch]. *) +val say : string -> t -> Message_t.t Deferred.Or_error.t + +val delete : t -> Channel_t.t Deferred.Or_error.t +val get_message : id:Snowflake.t -> t -> Message_t.t Deferred.Or_error.t +val get_messages : + ?mode:[ `Before | `After | `Around ] -> + ?id:Snowflake.t -> + ?limit:int -> + t -> + Message_t.t list Deferred.Or_error.t +val broadcast_typing : t -> unit Deferred.Or_error.t +val get_pins : t -> Message_t.t list Deferred.Or_error.t +val bulk_delete : Snowflake.t list -> t -> unit Deferred.Or_error.t +(* TODO more things related to guild channels *) \ No newline at end of file diff --git a/lib/models/channel/message/embed.ml b/lib/models/channel/message/embed.ml index f66aa3f..0dd7343 100644 --- a/lib/models/channel/message/embed.ml +++ b/lib/models/channel/message/embed.ml @@ -4,38 +4,38 @@ type footer = { text: string; icon_url: string option [@default None]; proxy_icon_url: string option [@default None]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type image = { url: string option [@default None]; proxy_url: string option [@default None]; height: int option [@default None]; width: int option [@default None]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type video = { url: string option [@default None]; height: int option [@default None]; width: int option [@default None]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type provider = { name: string option [@default None]; url: string option [@default None]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type author = { name: string option [@default None]; url: string option [@default None]; icon_url: string option [@default None]; proxy_icon_url: string option [@default None]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type field = { name: string; value: string; inline: bool [@default false]; -} [@@deriving sexp, yojson { exn = true }] +} [@@deriving sexp, yojson { strict = false; exn = true }] type t = { title: string option [@default None]; diff --git a/lib/models/event_models.ml b/lib/models/event_models.ml index 2dba4a4..542572f 100644 --- a/lib/models/event_models.ml +++ b/lib/models/event_models.ml @@ -1,250 +1,523 @@ open Core module ChannelCreate = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] + type t = Channel_t.t let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } + Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) + + let update_cache (cache:Cache.t) t = + let open Channel_t in + let module C = Cache.ChannelMap in + match t with + | GuildText c -> + let text_channels = C.update cache.text_channels c.id ~f:(function + | Some _ | None -> c) in + { cache with text_channels } + | GuildVoice c -> + let voice_channels = C.update cache.voice_channels c.id ~f:(function + | Some _ | None -> c) in + { cache with voice_channels } + | Category c -> + let categories = C.update cache.categories c.id ~f:(function + | Some _ | None -> c) in + { cache with categories } + | Group c -> + let groups = C.update cache.groups c.id ~f:(function + | Some _ | None -> c) in + { cache with groups } + | Private c -> + let private_channels = C.update cache.private_channels c.id ~f:(function + | Some _ | None -> c) in + { cache with private_channels } end module ChannelDelete = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] + type t = Channel_t.t let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } + Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) + + let update_cache (cache:Cache.t) t = + let open Channel_t in + let module C = Cache.ChannelMap in + match t with + | GuildText c -> + let text_channels = C.remove cache.text_channels c.id in + { cache with text_channels } + | GuildVoice c -> + let voice_channels = C.remove cache.voice_channels c.id in + { cache with voice_channels } + | Category c -> + let categories = C.remove cache.categories c.id in + { cache with categories } + | Group c -> + let groups = C.remove cache.groups c.id in + { cache with groups } + | Private c -> + let private_channels = C.remove cache.private_channels c.id in + { cache with private_channels } end module ChannelUpdate = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] + type t = Channel_t.t let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } + Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) + + let update_cache (cache:Cache.t) t = + let open Channel_t in + let module C = Cache.ChannelMap in + match t with + | GuildText c -> + let text_channels = C.update cache.text_channels c.id ~f:(function + | Some _ -> c + | None -> c) in + { cache with text_channels } + | GuildVoice c -> + let voice_channels = C.update cache.voice_channels c.id ~f:(function + | Some _ -> c + | None -> c) in + { cache with voice_channels } + | Category c -> + let categories = C.update cache.categories c.id ~f:(function + | Some _ -> c + | None -> c) in + { cache with categories } + | Group c -> + let groups = C.update cache.groups c.id ~f:(function + | Some _ -> c + | None -> c) in + { cache with groups } + | Private c -> + let private_channels = C.update cache.private_channels c.id ~f:(function + | Some _ -> c + | None -> c) in + { cache with private_channels } end module ChannelPinsUpdate = struct - type t = { - channel_id: Channel_id.t; - last_pin_timestamp: string option [@default None]; + type t = + { channel_id: Channel_id.t + ; last_pin_timestamp: string option [@default None] } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn -end -module ChannelRecipientAdd = struct + let update_cache (cache:Cache.t) t = + let module C = Cache.ChannelMap in + if C.mem cache.private_channels t.channel_id then + let private_channels = match C.find cache.private_channels t.channel_id with + | Some c -> C.set cache.private_channels ~key:t.channel_id ~data:{ c with last_pin_timestamp = t.last_pin_timestamp } + | None -> cache.private_channels in + { cache with private_channels } + else if C.mem cache.text_channels t.channel_id then + let text_channels = match C.find cache.text_channels t.channel_id with + | Some c -> C.set cache.text_channels ~key:t.channel_id ~data:{ c with last_pin_timestamp = t.last_pin_timestamp } + | None -> cache.text_channels in + { cache with text_channels } + else if C.mem cache.groups t.channel_id then + let groups = match C.find cache.groups t.channel_id with + | Some c -> C.set cache.groups ~key:t.channel_id ~data:{ c with last_pin_timestamp = t.last_pin_timestamp } + | None -> cache.groups in + { cache with groups } + else cache +end + +(* Don't see where these would get used *) + +(* module ChannelRecipientAdd = struct type t = { channel_id: Channel_id.t; user: User_t.t; } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn -end -module ChannelRecipientRemove = struct + let update_cache (cache:Cache.t) t = () +end *) + +(* module ChannelRecipientRemove = struct type t = { channel_id: Channel_id.t; user: User_t.t; } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn -end + let update_cache (cache:Cache.t) t = () +end *) + +(* TODO decide on ban caching, if any *) module GuildBanAdd = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; + type t = + { guild_id: Guild_id.t + ; user: User_t.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module GuildBanRemove = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; + type t = + { guild_id: Guild_id.t + ; user: User_t.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module GuildCreate = struct - type t = { - guild: Guild_t.t; - } [@@deriving sexp] + type t = Guild_t.t let deserialize ev = - let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in - { guild; } + Guild_t.(pre_of_yojson_exn ev |> wrap) + + let update_cache (cache:Cache.t) (t:t) = + let open Channel_t in + let module C = Cache.ChannelMap in + let guilds = Cache.GuildMap.update cache.guilds t.id ~f:(function Some _ | None -> t) in + let unavailable_guilds = Cache.GuildMap.remove cache.unavailable_guilds t.id in + let text, voice, cat = ref [], ref [], ref [] in + List.iter t.channels ~f:(function + | GuildText c -> text := (c.id, c) :: !text + | GuildVoice c -> voice := (c.id, c) :: !voice + | Category c -> cat := (c.id, c) :: !cat + | _ -> ()); + let text_channels = match C.of_alist !text with + | `Ok m -> + C.merge m cache.text_channels ~f:(fun ~key -> function + | `Both (c, _) | `Left c | `Right c -> let _ = key in Some c) + | _ -> cache.text_channels in + let voice_channels = match C.of_alist !voice with + | `Ok m -> + C.merge m cache.voice_channels ~f:(fun ~key -> function + | `Both (c, _) | `Left c | `Right c -> let _ = key in Some c) + | _ -> cache.voice_channels in + let categories = match C.of_alist !cat with + | `Ok m -> + C.merge m cache.categories ~f:(fun ~key -> function + | `Both (c, _) | `Left c | `Right c -> let _ = key in Some c) + | _ -> cache.categories in + let users = List.map t.members ~f:(fun m -> m.user.id, m.user) in + let users = match Cache.UserMap.of_alist users with + | `Ok m -> + Cache.UserMap.merge m cache.users ~f:(fun ~key -> function + | `Both (u, _) | `Left u | `Right u -> let _ = key in Some u) + | _ -> cache.users in + { cache with guilds + ; unavailable_guilds + ; text_channels + ; voice_channels + ; categories + ; users + } end module GuildDelete = struct - type t = { - id: Guild_id.t; - } [@@deriving sexp, yojson { strict = false; exn = true }] - - let deserialize = of_yojson_exn + type t = Guild_t.unavailable = + { id: Guild_id_t.t + ; unavailable: bool + } + + let deserialize = Guild_t.unavailable_of_yojson_exn + + let update_cache (cache:Cache.t) (t:t) = + let open Channel_t in + let module G = Cache.GuildMap in + let module C = Cache.ChannelMap in + if t.unavailable then + let guilds = G.remove cache.guilds t.id in + let unavailable_guilds = G.update cache.unavailable_guilds t.id ~f:(function Some _ | None -> t) in + { cache with guilds + ; unavailable_guilds + } + else + match G.find cache.guilds t.id with + | Some g -> + let text_channels = ref cache.text_channels in + let voice_channels = ref cache.voice_channels in + let categories = ref cache.categories in + List.iter g.channels ~f:(function + | GuildText c -> text_channels := C.remove cache.text_channels c.id + | GuildVoice c -> voice_channels := C.remove cache.voice_channels c.id + | Category c -> categories := C.remove cache.categories c.id + | _ -> () + ); + let guilds = G.remove cache.guilds g.id in + let text_channels, voice_channels, categories = !text_channels, !voice_channels, !categories in + { cache with guilds + ; text_channels + ; voice_channels + ; categories + } + | None -> + let guilds = G.remove cache.guilds t.id in + { cache with guilds } end module GuildUpdate = struct - type t = { - guild: Guild_t.t; - } [@@deriving sexp] + type t = Guild_t.t let deserialize ev = - let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in - { guild; } + Guild_t.(pre_of_yojson_exn ev |> wrap) + + let update_cache (cache:Cache.t) t = + let open Guild_t in + let {id; _} = t in + let guilds = Cache.GuildMap.update cache.guilds id ~f:(function + | Some _ | None -> t) in + { cache with guilds } end module GuildEmojisUpdate = struct - type t = { - emojis: Emoji.t list; - guild_id: Guild_id.t + type t = + { emojis: Emoji.t list + ; guild_id: Guild_id.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data:{ g with emojis = t.emojis } + | None -> cache.guilds in + { cache with guilds } + else cache end (* TODO guild integrations *) module GuildMemberAdd = struct - include Member_t + type t = Member_t.t - let deserialize = of_yojson_exn + let deserialize = Member_t.of_yojson_exn + + let update_cache (cache:Cache.t) (t:t) = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let members = t :: g.members in + let data = { g with members } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module GuildMemberRemove = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; + type t = + { guild_id: Guild_id.t + ; user: User_t.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let members = List.filter g.members ~f:(fun m -> m.user.id <> t.user.id) in + let data = { g with members } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module GuildMemberUpdate = struct - type t = { - guild_id: Guild_id.t; - nick: string option; - roles: Role_id.t list; - user: User_t.t; + type t = + { guild_id: Guild_id.t + ; nick: string option + ; roles: Role_id.t list + ; user: User_t.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let members = List.map g.members ~f:(fun m -> + if m.user.id = t.user.id then + { m with nick = t.nick; roles = t.roles } + else m) in + let data = { g with members } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module GuildMembersChunk = struct - type t = { - guild_id: Guild_id.t; - members: (Snowflake.t * Member_t.t) list; + type t = + { guild_id: Guild_id.t + ; members: Member_t.member list } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + match Cache.GuildMap.find cache.guilds t.guild_id with + | None -> cache + | Some g -> + let `Guild_id guild_id = t.guild_id in + let users = List.map t.members ~f:(fun m -> m.user.id, m.user) in + let members = List.filter_map t.members ~f:(fun m -> + if List.exists g.members ~f:(fun m' -> m'.user.id <> m.user.id) then + Some (Member_t.wrap ~guild_id m) + else None) in + let guilds = Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data:{ g with members } in + let users = match Cache.UserMap.of_alist users with + | `Ok m -> + Cache.UserMap.merge m cache.users ~f:(fun ~key -> function + | `Both (u, _) | `Left u | `Right u -> let _ = key in Some u) + | _ -> cache.users in + { cache with guilds + ; users + } + end module GuildRoleCreate = struct - type t = { - guild_id: Guild_id.t; - role: Role_t.role; + type t = + { guild_id: Guild_id.t + ; role: Role_t.role } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let `Guild_id guild_id = t.guild_id in + let roles = Role_t.wrap ~guild_id t.role :: g.roles in + let data = { g with roles } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module GuildRoleDelete = struct - type t = { - guild_id: Guild_id.t; - role_id: Role_id.t; + type t = + { guild_id: Guild_id.t + ; role_id: Role_id.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let roles = List.filter g.roles ~f:(fun r -> r.id <> t.role_id) in + let data = { g with roles } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module GuildRoleUpdate = struct - type t = { - guild_id: Guild_id.t; - role: Role_t.role; + type t = + { guild_id: Guild_id.t + ; role: Role_t.role } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn -end -(* TODO figure out if this is necessary *) -module GuildUnavailable = struct - type t = { - guild_id: Guild_id.t; - } [@@deriving sexp, yojson { strict = false; exn = true }] - - let deserialize = of_yojson_exn + let update_cache (cache:Cache.t) t = + if Cache.GuildMap.mem cache.guilds t.guild_id then + let guilds = match Cache.GuildMap.find cache.guilds t.guild_id with + | Some g -> + let `Guild_id guild_id = t.guild_id in + let roles = List.map g.roles ~f:(fun r -> + if r.id = t.role.id then Role_t.wrap ~guild_id t.role else r) in + let data = { g with roles } in + Cache.GuildMap.set cache.guilds ~key:t.guild_id ~data + | None -> cache.guilds in + { cache with guilds } + else cache end module MessageCreate = struct - type t = { - message: Message_t.t; - } [@@deriving sexp] + type t = Message_t.t - let deserialize ev = - let message = Message_t.of_yojson_exn ev in - { message; } + let deserialize = + Message_t.of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module MessageDelete = struct - type t = { - id: Message_id.t; - channel_id: Channel_id.t; - guild_id: Guild_id.t option [@default None]; + type t = + { id: Message_id.t + ; channel_id: Channel_id.t + ; guild_id: Guild_id.t option [@default None] } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module MessageUpdate = struct - type t = { - id: Message_id.t; - author: User_t.t option [@default None]; - channel_id: Channel_id.t; - member: Member_t.partial_member option [@default None]; - guild_id: Guild_id.t option [@default None]; - content: string option [@default None]; - timestamp: string option [@default None]; - editedimestamp: string option [@default None]; - tts: bool option [@default None]; - mention_everyone: bool option [@default None]; - mentions: User_t.t list [@default []]; - role_mentions: Role_id.t list [@default []]; - attachments: Attachment.t list [@default []]; - embeds: Embed.t list [@default []]; - reactions: Reaction_t.t list [@default []]; - nonce: Snowflake.t option [@default None]; - pinned: bool option [@default None]; - webhook_id: Snowflake.t option [@default None]; - kind: int option [@default None][@key "type"]; + type t = + { id: Message_id.t + ; author: User_t.t option [@default None] + ; channel_id: Channel_id.t + ; member: Member_t.partial_member option [@default None] + ; guild_id: Guild_id.t option [@default None] + ; content: string option [@default None] + ; timestamp: string option [@default None] + ; editedimestamp: string option [@default None] + ; tts: bool option [@default None] + ; mention_everyone: bool option [@default None] + ; mentions: User_t.t list [@default []] + ; role_mentions: Role_id.t list [@default []] + ; attachments: Attachment.t list [@default []] + ; embeds: Embed.t list [@default []] + ; reactions: Reaction_t.t list [@default []] + ; nonce: Snowflake.t option [@default None] + ; pinned: bool option [@default None] + ; webhook_id: Snowflake.t option [@default None] + ; kind: int option [@default None][@key "type"] } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module MessageDeleteBulk = struct - type t = { - guild_id: Guild_id.t option [@default None]; - channel_id: Channel_id.t; - ids: Message_id.t list; + type t = + { guild_id: Guild_id.t option [@default None] + ; channel_id: Channel_id.t + ; ids: Message_id.t list } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module PresenceUpdate = struct - include Presence + type t = Presence.t - let deserialize = of_yojson_exn + let deserialize = Presence.of_yojson_exn + + let update_cache (cache:Cache.t) (t:t) = + let id = t.user.id in + let presences = Cache.UserMap.update cache.presences id ~f:(function Some _ | None -> t) in + { cache with presences } end (* module PresencesReplace = struct @@ -254,93 +527,115 @@ end end *) module ReactionAdd = struct - type t = { - user_id: User_id.t; - channel_id: Channel_id.t; - message_id: Message_id.t; - guild_id: Guild_id.t option [@default None]; - emoji: Emoji.partial_emoji; + type t = + { user_id: User_id.t + ; channel_id: Channel_id.t + ; message_id: Message_id.t + ; guild_id: Guild_id.t option [@default None] + ; emoji: Emoji.partial_emoji } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module ReactionRemove = struct - type t = { - user_id: User_id.t; - channel_id: Channel_id.t; - message_id: Message_id.t; - guild_id: Guild_id.t option [@default None]; - emoji: Emoji.partial_emoji; + type t = + { user_id: User_id.t + ; channel_id: Channel_id.t + ; message_id: Message_id.t + ; guild_id: Guild_id.t option [@default None] + ; emoji: Emoji.partial_emoji } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module ReactionRemoveAll = struct - type t = { - channel_id: Channel_id.t; - message_id: Message_id.t; - guild_id: Guild_id.t option [@default None]; + type t = + { channel_id: Channel_id.t + ; message_id: Message_id.t + ; guild_id: Guild_id.t option [@default None] } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module Ready = struct - type t = { - version: int [@key "v"]; - user: User_t.t; - private_channels: Channel_id.t list; - guilds: Guild_t.unavailable list; - session_id: string; + type t = + { version: int [@key "v"] + ; user: User_t.t + ; private_channels: Channel_id.t list + ; guilds: Guild_t.unavailable list + ; session_id: string } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) t = + let unavailable_guilds = match List.map t.guilds ~f:(fun g -> g.id, g) |> Cache.GuildMap.of_alist with + | `Ok m -> Cache.GuildMap.merge m cache.unavailable_guilds ~f:(fun ~key -> function + | ` Both (g, _) | `Left g | `Right g -> let _ = key in Some g) + | _ -> cache.unavailable_guilds + in + let user = Some t.user in + { cache with user + ; unavailable_guilds + } end module Resumed = struct - type t = { - trace: string option list [@key "_trace"]; - } [@@deriving sexp, yojson { strict = false; exn = true }] + type t = { trace: string option list [@key "_trace"] } + [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module TypingStart = struct - type t = { - channel_id: Channel_id.t; - guild_id: Guild_id.t option [@default None]; - timestamp: int; - user_id: User_id.t; + type t = + { channel_id: Channel_id.t + ; guild_id: Guild_id.t option [@default None] + ; timestamp: int + ; user_id: User_id.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module UserUpdate = struct - type t = { - user: User_t.t; - } [@@deriving sexp, yojson { strict = false; exn = true }] + type t = User_t.t - let deserialize ev = - let user = User_t.of_yojson_exn ev in - { user; } + let deserialize = User_t.of_yojson_exn + + let update_cache (cache:Cache.t) t = + let user = Some t in + { cache with user } end module WebhookUpdate = struct - type t = { - channel_id: Channel_id.t; - guild_id: Guild_id.t; + type t = + { channel_id: Channel_id.t + ; guild_id: Guild_id.t } [@@deriving sexp, yojson { strict = false; exn = true }] let deserialize = of_yojson_exn + + let update_cache (cache:Cache.t) _t = cache end module Unknown = struct - type t = { - kind: string; - value: Yojson.Safe.t; + type t = + { kind: string + ; value: Yojson.Safe.t } let deserialize kind value = { kind; value; } diff --git a/lib/models/guild/guild.ml b/lib/models/guild/guild.ml index b1e8bfe..bd3143e 100644 --- a/lib/models/guild/guild.ml +++ b/lib/models/guild/guild.ml @@ -2,7 +2,113 @@ open Core open Async include Guild_t -include Impl.Guild(Guild_t) + +let ban_user ~id ?(reason="") ?(days=0) guild = + Http.guild_ban_add (get_id guild) id (`Assoc [ + ("delete-message-days", `Int days); + ("reason", `String reason); + ]) + +let create data = + let data = `Assoc data in + Http.create_guild data + +let create_emoji ~name ~image guild = + Http.create_emoji (get_id guild) (`Assoc [ + ("name", `String name); + ("image", `String image); + ("roles", `List []); + ]) + +let create_role ~name ?colour ?permissions ?hoist ?mentionable guild = + let payload = ("name", `String name) :: [] in + let payload = match permissions with + | Some p -> ("permissions", `Int p) :: payload + | None -> payload + in let payload = match colour with + | Some c -> ("color", `Int c) :: payload + | None -> payload + in let payload = match hoist with + | Some h -> ("hoist", `Bool h) :: payload + | None -> payload + in let payload = match mentionable with + | Some m -> ("mentionable", `Bool m) :: payload + | None -> payload + in Http.guild_role_add (get_id guild) (`Assoc payload) + +let create_channel ~mode ~name guild = + let kind = match mode with + | `Text -> 0 + | `Voice -> 2 + | `Category -> 4 + in Http.create_guild_channel (get_id guild) (`Assoc [ + ("name", `String name); + ("type", `Int kind); + ]) + +let delete guild = + Http.delete_guild (get_id guild) + +let get_ban ~id guild = + Http.get_ban (get_id guild) id + +let get_bans guild = + Http.get_bans (get_id guild) + +let get_emoji ~id guild = + Http.get_emoji (get_id guild) id + +(* TODO add invite abstraction? *) +let get_invites guild = + Http.get_guild_invites (get_id guild) + +let get_prune_count ~days guild = + Http.guild_prune_count (get_id guild) days + +(* TODO add webhook abstraction? *) +let get_webhooks guild = + Http.get_guild_webhooks (get_id guild) + +let kick_user ~id ?reason guild = + let payload = match reason with + | Some r -> `Assoc [("reason", `String r)] + | None -> `Null + in Http.remove_member (get_id guild) id payload + +let leave guild = + Http.leave_guild (get_id guild) + +(* TODO Voice region abstractions? *) +let list_voice_regions guild = + Http.get_guild_voice_regions (get_id guild) + +let prune ~days guild = + Http.guild_prune_start (get_id guild) days + +let request_members guild = + Http.get_members (get_id guild) + +let set_afk_channel ~id guild = Http.edit_guild (get_id guild) (`Assoc [ + ("afk_channel_id", `Int id); + ]) + +let set_afk_timeout ~timeout guild = Http.edit_guild (get_id guild) (`Assoc [ + ("afk_timeout", `Int timeout); + ]) + +let set_name ~name guild = Http.edit_guild (get_id guild) (`Assoc [ + ("name", `String name); + ]) + +let set_icon ~icon guild = Http.edit_guild (get_id guild) (`Assoc [ + ("icon", `String icon); + ]) + +let unban_user ~id ?reason guild = + let payload = match reason with + | Some r -> `Assoc [("reason", `String r)] + | None -> `Null + in Http.guild_ban_remove (get_id guild) id payload let get_member ~(id:User_id_t.t) guild = match List.find ~f:(fun m -> m.user.id = id) guild.members with diff --git a/lib/models/guild/guild.mli b/lib/models/guild/guild.mli index be9300a..1fbcf55 100644 --- a/lib/models/guild/guild.mli +++ b/lib/models/guild/guild.mli @@ -1,8 +1,36 @@ open Async include module type of Guild_t -include S.GuildImpl with - type t := Guild_t.t + +val ban_user : id:Snowflake.t -> ?reason:string -> ?days:int -> t -> unit Deferred.Or_error.t +val create : (string * Yojson.Safe.t) list -> t Deferred.Or_error.t +val create_emoji : name:string -> image:string -> t -> Emoji.t Deferred.Or_error.t +val create_role : + name:string -> + ?colour:int -> + ?permissions:int -> + ?hoist:bool -> + ?mentionable:bool -> + t -> + Role_t.t Deferred.Or_error.t +val create_channel : mode:[ `Text | `Voice | `Category ] -> name:string -> t -> Channel_t.t Deferred.Or_error.t +val delete : t -> unit Deferred.Or_error.t +val get_ban : id:Snowflake.t -> t -> Ban_t.t Deferred.Or_error.t +val get_bans : t -> Ban_t.t list Deferred.Or_error.t +val get_emoji : id:Snowflake.t -> t -> Emoji.t Deferred.Or_error.t +val get_invites : t -> Yojson.Safe.t Deferred.Or_error.t +val get_prune_count : days:int -> t -> int Deferred.Or_error.t +val get_webhooks : t -> Yojson.Safe.t Deferred.Or_error.t +val kick_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t +val leave : t -> unit Deferred.Or_error.t +val list_voice_regions : t -> Yojson.Safe.t Deferred.Or_error.t +val prune : days:int -> t -> int Deferred.Or_error.t +val request_members : t -> Member_t.t list Deferred.Or_error.t +val set_afk_channel : id:Snowflake.t -> t -> Guild_t.t Deferred.Or_error.t +val set_afk_timeout : timeout:int -> t -> Guild_t.t Deferred.Or_error.t +val set_name : name:string -> t -> Guild_t.t Deferred.Or_error.t +val set_icon : icon:string -> t -> Guild_t.t Deferred.Or_error.t +val unban_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t (** Get a channel belonging to this guild. This does not make an HTTP request. *) val get_channel : id:Channel_id_t.t -> t -> Channel_t.t Deferred.Or_error.t diff --git a/lib/models/guild/guild_t.ml b/lib/models/guild/guild_t.ml index fa9673a..afe3d19 100644 --- a/lib/models/guild/guild_t.ml +++ b/lib/models/guild/guild_t.ml @@ -2,6 +2,7 @@ open Core type unavailable = { id: Guild_id_t.t; + unavailable: bool [@default false]; } [@@deriving sexp, yojson { strict = false; exn = true }] type pre = { @@ -26,11 +27,10 @@ type pre = { widget_enabled: bool [@default false]; widget_channel_id: Channel_id_t.t option [@default None]; system_channel_id: Channel_id_t.t option [@default None]; - large: bool; - unavailable: bool; + large: bool [@default false]; member_count: int option [@default None]; - members: Member_t.member list; - channels: Channel_t.channel_wrapper list; + members: Member_t.member list [@default []]; + channels: Channel_t.channel_wrapper list [@default []]; } [@@deriving sexp, yojson { strict = false; exn = true }] type t = { @@ -56,17 +56,16 @@ type t = { widget_channel_id: Channel_id_t.t option [@default None]; system_channel_id: Channel_id_t.t option [@default None]; large: bool; - unavailable: bool; member_count: int option [@default None]; members: Member_t.t list; channels: Channel_t.t list; } [@@deriving sexp, yojson { strict = false; exn = true }] -let wrap ({id;name;icon;splash;owner_id;region;afk_channel_id;afk_timeout;embed_enabled;embed_channel_id;verification_level;default_message_notifications;explicit_content_filter;roles;emojis;features;mfa_level;application_id;widget_enabled;widget_channel_id;system_channel_id;large;unavailable;member_count;members;channels}:pre) = +let wrap ({id;name;icon;splash;owner_id;region;afk_channel_id;afk_timeout;embed_enabled;embed_channel_id;verification_level;default_message_notifications;explicit_content_filter;roles;emojis;features;mfa_level;application_id;widget_enabled;widget_channel_id;system_channel_id;large;member_count;members;channels}:pre) = let `Guild_id id = id in let roles = List.map ~f:(Role_t.wrap ~guild_id:id) roles in let members = List.map ~f:(Member_t.wrap ~guild_id:id) members in let channels = List.map ~f:Channel_t.wrap channels in - {id = `Guild_id id;name;icon;splash;owner_id;region;afk_channel_id;afk_timeout;embed_enabled;embed_channel_id;verification_level;default_message_notifications;explicit_content_filter;roles;emojis;features;mfa_level;application_id;widget_enabled;widget_channel_id;system_channel_id;large;unavailable;member_count;members;channels} + {id = `Guild_id id;name;icon;splash;owner_id;region;afk_channel_id;afk_timeout;embed_enabled;embed_channel_id;verification_level;default_message_notifications;explicit_content_filter;roles;emojis;features;mfa_level;application_id;widget_enabled;widget_channel_id;system_channel_id;large;member_count;members;channels} let get_id guild = let `Guild_id id = guild.id in id \ No newline at end of file diff --git a/lib/models/guild/guild_t.mli b/lib/models/guild/guild_t.mli index 89cf9a2..7327be9 100644 --- a/lib/models/guild/guild_t.mli +++ b/lib/models/guild/guild_t.mli @@ -1,5 +1,6 @@ type unavailable = { id: Guild_id_t.t; + unavailable: bool; } [@@deriving sexp, yojson { exn = true }] (** Used internally. *) @@ -26,7 +27,6 @@ type pre = { widget_channel_id: Channel_id_t.t option; system_channel_id: Channel_id_t.t option; large: bool; - unavailable: bool; member_count: int option; members: Member_t.member list; channels: Channel_t.channel_wrapper list; @@ -56,7 +56,6 @@ type t = { widget_channel_id: Channel_id_t.t option; (** The channel ID for the widget, if enabled. *) system_channel_id: Channel_id_t.t option; (** The channel ID where system messages are sent. *) large: bool; (** Whether the guild exceeds the configured large threshold. *) - unavailable: bool; (** Whether the guild is unavailable or not. *) member_count: int option; (** Total number of members in the guild. *) members: Member_t.t list; (** List of guild members. *) channels: Channel_t.t list; (** List of guild channels. *) diff --git a/lib/models/id/channel_id.ml b/lib/models/id/channel_id.ml index be4bfab..1017ad1 100644 --- a/lib/models/id/channel_id.ml +++ b/lib/models/id/channel_id.ml @@ -1,2 +1,55 @@ +open Core include Channel_id_t -include Impl.Channel(Channel_id_t) \ No newline at end of file + +exception Invalid_message +exception No_message_found + +let send_message ?embed ?content ?file ?(tts=false) ch = + let embed = match embed with + | Some e -> Embed.to_yojson e + | None -> `Null in + let content = match content with + | Some c -> `String c + | None -> `Null in + let file = match file with + | Some f -> `String f + | None -> `Null in + let () = match embed, content with + | `Null, `Null -> raise Invalid_message + | _ -> () in + Http.create_message (get_id ch) (`Assoc [ + ("embed", embed); + ("content", content); + ("file", file); + ("tts", `Bool tts); + ]) + +let say content ch = + send_message ~content ch + +let delete ch = + Http.delete_channel (get_id ch) + +let get_message ~id ch = + Http.get_message (get_id ch) id + +let get_messages ?(mode=`Around) ?id ?(limit=50) ch = + let kind = match mode with + | `Around -> "around", limit + | `Before -> "before", limit + | `After -> "after", limit + in + let id = match id with + | Some id -> id + | None -> raise No_message_found in + Http.get_messages (get_id ch) id kind + +let broadcast_typing ch = + Http.broadcast_typing (get_id ch) + +let get_pins ch = + Http.get_pinned_messages (get_id ch) + +let bulk_delete msgs ch = + let msgs = `List (List.map ~f:(fun id -> `Int id) msgs) in + Http.bulk_delete (get_id ch) msgs \ No newline at end of file diff --git a/lib/models/id/channel_id.mli b/lib/models/id/channel_id.mli index 59b4d23..20987c5 100644 --- a/lib/models/id/channel_id.mli +++ b/lib/models/id/channel_id.mli @@ -1,3 +1,46 @@ +open Async include module type of Channel_id_t -include S.ChannelImpl with - type t := Channel_id_t.t \ No newline at end of file + +exception Invalid_message +exception No_message_found + +(** Advanced message sending. + + Raises {!Invalid_message} if one of content or embed is not set. + + {3 Examples} + {[ + open Core + open Disml + + let check_command (msg : Message.t) = + if String.is_prefix ~prefix:"!hello" msg.content then + let embed = Embed.(default |> title "Hello World!") in + Channel_id.send_message ~embed msg.channel_id >>> ignore + + Client.message_create := check_command + ]} +*) +val send_message : + ?embed:Embed.t -> + ?content:string -> + ?file:string -> + ?tts:bool -> + t -> + Message_t.t Deferred.Or_error.t + +(** [say str ch] is equivalent to [send_message ~content:str ch]. *) +val say : string -> t -> Message_t.t Deferred.Or_error.t + +val delete : t -> Channel_t.t Deferred.Or_error.t +val get_message : id:Snowflake.t -> t -> Message_t.t Deferred.Or_error.t +val get_messages : + ?mode:[ `Before | `After | `Around ] -> + ?id:Snowflake.t -> + ?limit:int -> + t -> + Message_t.t list Deferred.Or_error.t +val broadcast_typing : t -> unit Deferred.Or_error.t +val get_pins : t -> Message_t.t list Deferred.Or_error.t +val bulk_delete : Snowflake.t list -> t -> unit Deferred.Or_error.t +(* TODO more things related to guild channels *) \ No newline at end of file diff --git a/lib/models/id/channel_id_t.ml b/lib/models/id/channel_id_t.ml index e49beef..cea85e0 100644 --- a/lib/models/id/channel_id_t.ml +++ b/lib/models/id/channel_id_t.ml @@ -1,5 +1,9 @@ +open Core + type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp] +let compare (`Channel_id t) (`Channel_id t') = Int.compare t t' + let of_yojson a : (t, string) result = match Snowflake.of_yojson a with | Ok id -> Ok (`Channel_id id) diff --git a/lib/models/id/channel_id_t.mli b/lib/models/id/channel_id_t.mli index df0d518..72324a7 100644 --- a/lib/models/id/channel_id_t.mli +++ b/lib/models/id/channel_id_t.mli @@ -1,3 +1,4 @@ type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp, yojson { exn = true }] +val compare : t -> t -> int val get_id : t -> Snowflake.t \ No newline at end of file diff --git a/lib/models/id/guild_id.ml b/lib/models/id/guild_id.ml index 79b4323..6b3385c 100644 --- a/lib/models/id/guild_id.ml +++ b/lib/models/id/guild_id.ml @@ -1,2 +1,104 @@ include Guild_id_t -include Impl.Guild(Guild_id_t) \ No newline at end of file + +let ban_user ~id ?(reason="") ?(days=0) guild = + Http.guild_ban_add (get_id guild) id (`Assoc [ + ("delete-message-days", `Int days); + ("reason", `String reason); + ]) + +let create_emoji ~name ~image guild = + Http.create_emoji (get_id guild) (`Assoc [ + ("name", `String name); + ("image", `String image); + ("roles", `List []); + ]) + +let create_role ~name ?colour ?permissions ?hoist ?mentionable guild = + let payload = ("name", `String name) :: [] in + let payload = match permissions with + | Some p -> ("permissions", `Int p) :: payload + | None -> payload + in let payload = match colour with + | Some c -> ("color", `Int c) :: payload + | None -> payload + in let payload = match hoist with + | Some h -> ("hoist", `Bool h) :: payload + | None -> payload + in let payload = match mentionable with + | Some m -> ("mentionable", `Bool m) :: payload + | None -> payload + in Http.guild_role_add (get_id guild) (`Assoc payload) + +let create_channel ~mode ~name guild = + let kind = match mode with + | `Text -> 0 + | `Voice -> 2 + | `Category -> 4 + in Http.create_guild_channel (get_id guild) (`Assoc [ + ("name", `String name); + ("type", `Int kind); + ]) + +let delete guild = + Http.delete_guild (get_id guild) + +let get_ban ~id guild = + Http.get_ban (get_id guild) id + +let get_bans guild = + Http.get_bans (get_id guild) + +let get_emoji ~id guild = + Http.get_emoji (get_id guild) id + +(* TODO add invite abstraction? *) +let get_invites guild = + Http.get_guild_invites (get_id guild) + +let get_prune_count ~days guild = + Http.guild_prune_count (get_id guild) days + +(* TODO add webhook abstraction? *) +let get_webhooks guild = + Http.get_guild_webhooks (get_id guild) + +let kick_user ~id ?reason guild = + let payload = match reason with + | Some r -> `Assoc [("reason", `String r)] + | None -> `Null + in Http.remove_member (get_id guild) id payload + +let leave guild = + Http.leave_guild (get_id guild) + +(* TODO Voice region abstractions? *) +let list_voice_regions guild = + Http.get_guild_voice_regions (get_id guild) + +let prune ~days guild = + Http.guild_prune_start (get_id guild) days + +let request_members guild = + Http.get_members (get_id guild) + +let set_afk_channel ~id guild = Http.edit_guild (get_id guild) (`Assoc [ + ("afk_channel_id", `Int id); + ]) + +let set_afk_timeout ~timeout guild = Http.edit_guild (get_id guild) (`Assoc [ + ("afk_timeout", `Int timeout); + ]) + +let set_name ~name guild = Http.edit_guild (get_id guild) (`Assoc [ + ("name", `String name); + ]) + +let set_icon ~icon guild = Http.edit_guild (get_id guild) (`Assoc [ + ("icon", `String icon); + ]) + +let unban_user ~id ?reason guild = + let payload = match reason with + | Some r -> `Assoc [("reason", `String r)] + | None -> `Null + in Http.guild_ban_remove (get_id guild) id payload \ No newline at end of file diff --git a/lib/models/id/guild_id.mli b/lib/models/id/guild_id.mli index 88e9fa7..11f34f7 100644 --- a/lib/models/id/guild_id.mli +++ b/lib/models/id/guild_id.mli @@ -1,3 +1,31 @@ +open Async include module type of Guild_id_t -include S.GuildImpl with - type t := Guild_id_t.t \ No newline at end of file + +val ban_user : id:Snowflake.t -> ?reason:string -> ?days:int -> t -> unit Deferred.Or_error.t +val create_emoji : name:string -> image:string -> t -> Emoji.t Deferred.Or_error.t +val create_role : + name:string -> + ?colour:int -> + ?permissions:int -> + ?hoist:bool -> + ?mentionable:bool -> + t -> + Role_t.t Deferred.Or_error.t +val create_channel : mode:[ `Text | `Voice | `Category ] -> name:string -> t -> Channel_t.t Deferred.Or_error.t +val delete : t -> unit Deferred.Or_error.t +val get_ban : id:Snowflake.t -> t -> Ban_t.t Deferred.Or_error.t +val get_bans : t -> Ban_t.t list Deferred.Or_error.t +val get_emoji : id:Snowflake.t -> t -> Emoji.t Deferred.Or_error.t +val get_invites : t -> Yojson.Safe.t Deferred.Or_error.t +val get_prune_count : days:int -> t -> int Deferred.Or_error.t +val get_webhooks : t -> Yojson.Safe.t Deferred.Or_error.t +val kick_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t +val leave : t -> unit Deferred.Or_error.t +val list_voice_regions : t -> Yojson.Safe.t Deferred.Or_error.t +val prune : days:int -> t -> int Deferred.Or_error.t +val request_members : t -> Member_t.t list Deferred.Or_error.t +val set_afk_channel : id:Snowflake.t -> t -> Guild_t.t Deferred.Or_error.t +val set_afk_timeout : timeout:int -> t -> Guild_t.t Deferred.Or_error.t +val set_name : name:string -> t -> Guild_t.t Deferred.Or_error.t +val set_icon : icon:string -> t -> Guild_t.t Deferred.Or_error.t +val unban_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t \ No newline at end of file diff --git a/lib/models/id/guild_id_t.ml b/lib/models/id/guild_id_t.ml index cd8eb58..a39c07d 100644 --- a/lib/models/id/guild_id_t.ml +++ b/lib/models/id/guild_id_t.ml @@ -1,5 +1,9 @@ +open Core + type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp] +let compare (`Guild_id t) (`Guild_id t') = Int.compare t t' + let of_yojson a : (t, string) result = match Snowflake.of_yojson a with | Ok id -> Ok (`Guild_id id) diff --git a/lib/models/id/guild_id_t.mli b/lib/models/id/guild_id_t.mli index 4605d34..f4d415a 100644 --- a/lib/models/id/guild_id_t.mli +++ b/lib/models/id/guild_id_t.mli @@ -1,3 +1,4 @@ type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp, yojson { exn = true }] +val compare : t -> t -> int val get_id : t -> Snowflake.t \ No newline at end of file diff --git a/lib/models/id/user_id.ml b/lib/models/id/user_id.ml index cc71764..00d930f 100644 --- a/lib/models/id/user_id.ml +++ b/lib/models/id/user_id.ml @@ -1,2 +1 @@ -include User_id_t -include Impl.User(User_id_t) \ No newline at end of file +include User_id_t \ No newline at end of file diff --git a/lib/models/id/user_id.mli b/lib/models/id/user_id.mli index 574c4f0..f9506f7 100644 --- a/lib/models/id/user_id.mli +++ b/lib/models/id/user_id.mli @@ -1,3 +1 @@ -include module type of User_id_t -include S.UserImpl with - type t := User_id_t.t \ No newline at end of file +include module type of User_id_t \ No newline at end of file diff --git a/lib/models/id/user_id_t.ml b/lib/models/id/user_id_t.ml index f168daa..cf1634a 100644 --- a/lib/models/id/user_id_t.ml +++ b/lib/models/id/user_id_t.ml @@ -1,5 +1,9 @@ +open Core + type t = [ `User_id of Snowflake.t ] [@@deriving sexp] +let compare (`User_id t) (`User_id t') = Int.compare t t' + let of_yojson a : (t, string) result = match Snowflake.of_yojson a with | Ok id -> Ok (`User_id id) diff --git a/lib/models/id/user_id_t.mli b/lib/models/id/user_id_t.mli index 194951b..e728b00 100644 --- a/lib/models/id/user_id_t.mli +++ b/lib/models/id/user_id_t.mli @@ -1,3 +1,4 @@ type t = [ `User_id of Snowflake.t ] [@@deriving sexp, yojson { exn = true }] +val compare : t -> t -> int val get_id : t -> Snowflake.t \ No newline at end of file diff --git a/lib/models/user/presence.ml b/lib/models/user/presence.ml index 0b83000..d8683b7 100644 --- a/lib/models/user/presence.ml +++ b/lib/models/user/presence.ml @@ -2,9 +2,7 @@ open Core type t = { user: User_t.partial_user; - roles: Role_id.t list; game: Activity.t option [@default None]; - guild_id: Guild_id_t.t; status: string; activities: Activity.t list; } [@@deriving sexp, yojson { strict = false; exn = true }] \ No newline at end of file diff --git a/lib/models/user/presence.mli b/lib/models/user/presence.mli index 2df252b..ae01373 100644 --- a/lib/models/user/presence.mli +++ b/lib/models/user/presence.mli @@ -1,9 +1,7 @@ (** A user presence. *) type t = { user: User_t.partial_user; (** A partial user that this presence belongs to. *) - roles: Role_id.t list; (** A list of roles that the user has. *) game: Activity.t option; (** The current activity of the user, if any. *) - guild_id: Guild_id_t.t; (** The guild ID in which this presence exists. *) status: string; (** One of [online], [idle], [offline], or [dnd]. *) activities: Activity.t list; (** A list of all of the user's current activities. *) } [@@deriving sexp, yojson { exn = true }] \ No newline at end of file diff --git a/lib/models/user/user_t.ml b/lib/models/user/user_t.ml index f001e4a..b68808d 100644 --- a/lib/models/user/user_t.ml +++ b/lib/models/user/user_t.ml @@ -2,6 +2,10 @@ open Core type partial_user = { id: User_id_t.t; + username: string option [@default None]; + discriminator: string option [@default None]; + avatar: string option [@default None]; + bot: bool [@default false]; } [@@deriving sexp, yojson { strict = false; exn = true }] type t = { diff --git a/lib/models/user/user_t.mli b/lib/models/user/user_t.mli index 7b8f6b6..78f7a28 100644 --- a/lib/models/user/user_t.mli +++ b/lib/models/user/user_t.mli @@ -1,6 +1,10 @@ (** A partial user. Used internally. *) type partial_user = { id: User_id_t.t; + username: string option; + discriminator: string option; + avatar: string option; + bot: bool; } [@@deriving sexp, yojson { exn = true }] (** A user object. *) diff --git a/lib/opcode.ml b/lib/opcode.ml deleted file mode 100644 index 2462d05..0000000 --- a/lib/opcode.ml +++ /dev/null @@ -1,54 +0,0 @@ -type t = - | DISPATCH - | HEARTBEAT - | IDENTIFY - | STATUS_UPDATE - | VOICE_STATE_UPDATE - | RESUME - | RECONNECT - | REQUEST_GUILD_MEMBERS - | INVALID_SESSION - | HELLO - | HEARTBEAT_ACK - -exception Invalid_Opcode of int - -let to_int = function - | DISPATCH -> 0 - | HEARTBEAT -> 1 - | IDENTIFY -> 2 - | STATUS_UPDATE -> 3 - | VOICE_STATE_UPDATE -> 4 - | RESUME -> 6 - | RECONNECT -> 7 - | REQUEST_GUILD_MEMBERS -> 8 - | INVALID_SESSION -> 9 - | HELLO -> 10 - | HEARTBEAT_ACK -> 11 - -let from_int = function - | 0 -> DISPATCH - | 1 -> HEARTBEAT - | 2 -> IDENTIFY - | 3 -> STATUS_UPDATE - | 4 -> VOICE_STATE_UPDATE - | 6 -> RESUME - | 7 -> RECONNECT - | 8 -> REQUEST_GUILD_MEMBERS - | 9 -> INVALID_SESSION - | 10 -> HELLO - | 11 -> HEARTBEAT_ACK - | op -> raise (Invalid_Opcode op) - -let to_string = function - | DISPATCH -> "DISPATCH" - | HEARTBEAT -> "HEARTBEAT" - | IDENTIFY -> "IDENTIFY" - | STATUS_UPDATE -> "STATUS_UPDATE" - | VOICE_STATE_UPDATE -> "VOICE_STATE_UPDATE" - | RESUME -> "RESUME" - | RECONNECT -> "RECONNECT" - | REQUEST_GUILD_MEMBERS -> "REQUEST_GUILD_MEMBER" - | INVALID_SESSION -> "INVALID_SESSION" - | HELLO -> "HELLO" - | HEARTBEAT_ACK -> "HEARTBEAT_ACK" \ No newline at end of file diff --git a/lib/opcode.mli b/lib/opcode.mli deleted file mode 100644 index b0e7adb..0000000 --- a/lib/opcode.mli +++ /dev/null @@ -1,29 +0,0 @@ -(** Internal Opcode abstractions. *) - -(** Type of known opcodes. *) -type t = -| DISPATCH -| HEARTBEAT -| IDENTIFY -| STATUS_UPDATE -| VOICE_STATE_UPDATE -| RESUME -| RECONNECT -| REQUEST_GUILD_MEMBERS -| INVALID_SESSION -| HELLO -| HEARTBEAT_ACK - -(** Raised when receiving an invalid opcode. This should never occur. *) -exception Invalid_Opcode of int - -(** Converts an opcode to its integer form for outgoing frames. *) -val to_int : t -> int - -(** Converts an integer to an opcode for incoming frames. - Raise {!Invalid_Opcode} Raised when an unkown opcode is received. -*) -val from_int : int -> t - -(** Converts and opcode to a human-readable string. Used for logging purposes. *) -val to_string : t -> string \ No newline at end of file diff --git a/lib/s.ml b/lib/s.ml deleted file mode 100644 index 8deb334..0000000 --- a/lib/s.ml +++ /dev/null @@ -1,93 +0,0 @@ -open Async - -module type HasSnowflake = sig - type t [@@deriving sexp, yojson] - val get_id : t -> Snowflake.t -end - -module type ChannelImpl = sig - type t - exception Invalid_message - exception No_message_found - - (** Advanced message sending. - - Raises {!Invalid_message} if one of content or embed is not set. - - {3 Examples} - {[ - open Core - open Disml - - let check_command (msg : Message.t) = - if String.is_prefix ~prefix:"!hello" msg.content then - let embed = Embed.(default |> title "Hello World!") in - Channel_id.send_message ~embed msg.channel_id >>> ignore - - Client.message_create := check_command - ]} - *) - val send_message : - ?embed:Embed.t -> - ?content:string -> - ?file:string -> - ?tts:bool -> - t -> - Message_t.t Deferred.Or_error.t - - (** [say str ch] is equivalent to [send_message ~content:str ch]. *) - val say : string -> t -> Message_t.t Deferred.Or_error.t - - val delete : t -> Channel_t.t Deferred.Or_error.t - val get_message : id:Snowflake.t -> t -> Message_t.t Deferred.Or_error.t - val get_messages : - ?mode:[ `Before | `After | `Around ] -> - ?id:Snowflake.t -> - ?limit:int -> - t -> - Message_t.t list Deferred.Or_error.t - val broadcast_typing : t -> unit Deferred.Or_error.t - val get_pins : t -> Message_t.t list Deferred.Or_error.t - val bulk_delete : Snowflake.t list -> t -> unit Deferred.Or_error.t - (* TODO more things related to guild channels *) -end - -module type GuildImpl = sig - open Async - - type t - val ban_user : id:Snowflake.t -> ?reason:string -> ?days:int -> t -> unit Deferred.Or_error.t - val create_emoji : name:string -> image:string -> t -> Emoji.t Deferred.Or_error.t - val create_role : - name:string -> - ?colour:int -> - ?permissions:int -> - ?hoist:bool -> - ?mentionable:bool -> - t -> - Role_t.t Deferred.Or_error.t - val create_channel : mode:[ `Text | `Voice | `Category ] -> name:string -> t -> Channel_t.t Deferred.Or_error.t - val delete : t -> unit Deferred.Or_error.t - val get_ban : id:Snowflake.t -> t -> Ban_t.t Deferred.Or_error.t - val get_bans : t -> Ban_t.t list Deferred.Or_error.t - val get_emoji : id:Snowflake.t -> t -> Emoji.t Deferred.Or_error.t - val get_invites : t -> Yojson.Safe.t Deferred.Or_error.t - val get_prune_count : days:int -> t -> int Deferred.Or_error.t - val get_webhooks : t -> Yojson.Safe.t Deferred.Or_error.t - val kick_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t - val leave : t -> unit Deferred.Or_error.t - val list_voice_regions : t -> Yojson.Safe.t Deferred.Or_error.t - val prune : days:int -> t -> int Deferred.Or_error.t - val request_members : t -> Member_t.t list Deferred.Or_error.t - val set_afk_channel : id:Snowflake.t -> t -> Guild_t.t Deferred.Or_error.t - val set_afk_timeout : timeout:int -> t -> Guild_t.t Deferred.Or_error.t - val set_name : name:string -> t -> Guild_t.t Deferred.Or_error.t - val set_icon : icon:string -> t -> Guild_t.t Deferred.Or_error.t - val unban_user : id:Snowflake.t -> ?reason:string -> t -> unit Deferred.Or_error.t -end - -module type UserImpl = sig - type t - (* val private_channel : t -> Channel_t.t *) - (* val send : t -> Yojson.Safe.t Deferred.Or_error.t *) -end \ No newline at end of file diff --git a/lib/sharder.ml b/lib/sharder.ml deleted file mode 100644 index 8570a08..0000000 --- a/lib/sharder.ml +++ /dev/null @@ -1,376 +0,0 @@ -open Async -open Core -open Decompress -open Websocket_async - -exception Invalid_Payload -exception Failure_to_Establish_Heartbeat -exception Inflate_error of Zlib_inflate.error - -let window = Window.create ~witness:B.bytes - -let decompress src = - let in_buf = Bytes.create 0xFFFF in - let out_buf = Bytes.create 0xFFFF in - let window = Window.reset window in - let pos = ref 0 in - let src_len = String.length src in - let res = Buffer.create (src_len) in - Zlib_inflate.bytes in_buf out_buf - (fun dst -> - let len = min 0xFFFF (src_len - !pos) in - Caml.Bytes.blit_string src !pos dst 0 len; - pos := !pos + len; - len) - (fun obuf len -> - Buffer.add_subbytes res obuf 0 len; 0xFFFF) - (Zlib_inflate.default ~witness:B.bytes window) - |> function - | Ok _ -> Buffer.contents res - | Error exn -> raise (Inflate_error exn) - -module Shard = struct - type shard = { - compress: bool; - id: int * int; - hb_interval: Time.Span.t Ivar.t; - hb_stopper: unit Ivar.t; - large_threshold: int; - pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; - ready: unit Ivar.t; - seq: int; - session: string option; - url: string; - _internal: Reader.t * Writer.t; - } - - type 'a t = { - mutable state: 'a; - mutable stopped: bool; - } - - let identify_lock = Mvar.create () - let _ = Mvar.set identify_lock () - - let parse ~compress (frame:[`Ok of Frame.t | `Eof]) = - match frame with - | `Ok s -> begin - let open Frame.Opcode in - match s.opcode with - | Text -> Ok (Yojson.Safe.from_string s.content) - | Binary -> - if compress then Ok (decompress s.content |> Yojson.Safe.from_string) - else Error "Failed to decompress" - | _ -> Error "Unexpected opcode" - end - | `Eof -> Error "EOF" - - let push_frame ?payload ~ev shard = - let content = match payload with - | None -> "" - | Some p -> - Yojson.Safe.to_string @@ `Assoc [ - "op", `Int (Opcode.to_int ev); - "d", p; - ] - in - let (_, write) = shard.pipe in - Pipe.write_if_open write @@ Frame.create ~content () - >>| fun () -> - shard - - let heartbeat shard = - match shard.seq with - | 0 -> return shard - | i -> - Logs.debug (fun m -> m "Heartbeating - Shard: [%d, %d] - Seq: %d" (fst shard.id) (snd shard.id) (shard.seq)); - push_frame ~payload:(`Int i) ~ev:HEARTBEAT shard - - let dispatch ~payload shard = - let module J = Yojson.Safe.Util in - let seq = J.(member "s" payload |> to_int) in - let t = J.(member "t" payload |> to_string) in - let data = J.member "d" payload in - let session = if t = "READY" then begin - Ivar.fill_if_empty shard.ready (); - Clock.after (Core.Time.Span.create ~sec:5 ()) - >>> (fun _ -> Mvar.put identify_lock () >>> ignore); - J.(member "session_id" data |> to_string_option) - end else None in - Event.handle_event ~ev:t data; - return { shard with - seq = seq; - session = session; - } - - let set_status ~(status:Yojson.Safe.t) shard = - let payload = match status with - | `Assoc ["name", `String name; "type", `Int t] - | `Assoc ["type", `Int t; "name", `String name] -> - `Assoc [ - "status", `String "online"; - "afk", `Bool false; - "since", `Null; - "game", `Assoc [ - "name", `String name; - "type", `Int t; - ] - ] - | `String name -> - `Assoc [ - "status", `String "online"; - "afk", `Bool false; - "since", `Null; - "game", `Assoc [ - "name", `String name; - "type", `Int 0 - ] - ] - | _ -> raise Invalid_Payload - in - Ivar.read shard.ready >>= fun _ -> - push_frame ~payload ~ev:STATUS_UPDATE shard - - let request_guild_members ?(query="") ?(limit=0) ~guild shard = - let payload = `Assoc [ - "guild_id", `String (Int.to_string guild); - "query", `String query; - "limit", `Int limit; - ] in - Ivar.read shard.ready >>= fun _ -> - push_frame ~payload ~ev:REQUEST_GUILD_MEMBERS shard - - let initialize ?data shard = - let module J = Yojson.Safe.Util in - let _ = match data with - | Some data -> Ivar.fill_if_empty shard.hb_interval (Time.Span.create ~ms:J.(member "heartbeat_interval" data |> to_int) ()) - | None -> raise Failure_to_Establish_Heartbeat - in - let shards = [`Int (fst shard.id); `Int (snd shard.id)] in - match shard.session with - | None -> begin - Mvar.take identify_lock >>= fun () -> - Logs.debug (fun m -> m "Identifying shard [%d, %d]" (fst shard.id) (snd shard.id)); - let payload = `Assoc [ - "token", `String !Client_options.token; - "properties", `Assoc [ - "$os", `String Sys.os_type; - "$device", `String "dis.ml"; - "$browser", `String "dis.ml"; - ]; - "compress", `Bool shard.compress; - "large_threshold", `Int shard.large_threshold; - "shard", `List shards; - ] in - push_frame ~payload ~ev:IDENTIFY shard - >>| fun s -> s - end - | Some s -> - let payload = `Assoc [ - "token", `String !Client_options.token; - "session_id", `String s; - "seq", `Int shard.seq; - ] in - push_frame ~payload ~ev:RESUME shard - - let handle_frame ~f shard = - let module J = Yojson.Safe.Util in - let op = J.(member "op" f |> to_int) |> Opcode.from_int in - match op with - | DISPATCH -> dispatch ~payload:f shard - | HEARTBEAT -> heartbeat shard - | INVALID_SESSION -> begin - Logs.err (fun m -> m "Invalid Session on Shard [%d, %d]: %s" (fst shard.id) (snd shard.id) (Yojson.Safe.pretty_to_string f)); - if J.(member "d" f |> to_bool) then - initialize shard - else begin - initialize { shard with session = None; } - end - end - | RECONNECT -> initialize shard - | HELLO -> initialize ~data:(J.member "d" f) shard - | HEARTBEAT_ACK -> return shard - | opcode -> - Logs.warn (fun m -> m "Invalid Opcode: %s" (Opcode.to_string opcode)); - return shard - - let rec make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri = - client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri - >>> fun res -> - match res with - | Ok () -> () - | Error _ -> - let backoff = Time.Span.create ~ms:500 () in - Clock.after backoff >>> (fun () -> - make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri) - - - let create ~url ~shards ?(compress=true) ?(large_threshold=100) () = - let open Core in - let uri = (url ^ "?v=6&encoding=json") |> Uri.of_string in - let extra_headers = Http.Base.process_request_headers () in - let host = Option.value_exn ~message:"no host in uri" Uri.(host uri) in - let port = - match Uri.port uri, Uri_services.tcp_port_of_uri uri with - | Some p, _ -> p - | None, Some p -> p - | _ -> 443 in - let scheme = Option.value_exn ~message:"no scheme in uri" Uri.(scheme uri) in - let tcp_fun (net_to_ws, ws_to_net) = - let (app_to_ws, write) = Pipe.create () in - let (read, ws_to_app) = Pipe.create () in - let initialized = Ivar.create () in - make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri; - Ivar.read initialized >>| fun () -> - { - pipe = (read, write); - ready = Ivar.create (); - hb_interval = Ivar.create (); - hb_stopper = Ivar.create (); - seq = 0; - id = shards; - session = None; - url; - large_threshold; - compress; - _internal = (net_to_ws, ws_to_net); - } - in - match Unix.getaddrinfo host (string_of_int port) [] with - | [] -> failwithf "DNS resolution failed for %s" host () - | { ai_addr; _ } :: _ -> - let addr = - match scheme, ai_addr with - | _, ADDR_UNIX path -> `Unix_domain_socket path - | "https", ADDR_INET (h, p) - | "wss", ADDR_INET (h, p) -> - let h = Ipaddr_unix.of_inet_addr h in - `OpenSSL (h, p, Conduit_async.V2.Ssl.Config.create ()) - | _, ADDR_INET (h, p) -> - let h = Ipaddr_unix.of_inet_addr h in - `TCP (h, p) - in - Conduit_async.V2.connect addr >>= tcp_fun - - let shutdown ?(clean=false) ?(restart=true) t = - let _ = clean in - if not restart then t.stopped <- true; - Logs.debug (fun m -> m "Performing shutdown. Shard [%d, %d]" (fst t.state.id) (snd t.state.id)); - Pipe.write_if_open (snd t.state.pipe) (Frame.close 1001) - >>= fun () -> - Ivar.fill_if_empty t.state.hb_stopper (); - Pipe.close_read (fst t.state.pipe); - Writer.close (snd t.state._internal) -end - -type t = { - shards: (Shard.shard Shard.t) list; -} - -let start ?count ?compress ?large_threshold () = - let module J = Yojson.Safe.Util in - Http.get_gateway_bot () >>= fun data -> - let data = match data with - | Ok d -> d - | Error e -> Error.raise e - in - let url = J.(member "url" data |> to_string) in - let count = match count with - | Some c -> c - | None -> J.(member "shards" data |> to_int) - in - let shard_list = (0, count) in - Logs.info (fun m -> m "Connecting to %s" url); - let rec ev_loop (t:Shard.shard Shard.t) = - let step (t:Shard.shard Shard.t) = - Pipe.read (fst t.state.pipe) >>= fun frame -> - begin match Shard.parse ~compress:t.state.compress frame with - | Ok f -> - Shard.handle_frame ~f t.state >>| fun s -> - t.state <- s - | Error e -> - Logs.warn (fun m -> m "Websocket closed. Reason: %s" e); - Deferred.never () - end >>| fun () -> t - in - if t.stopped then return () - else step t >>= ev_loop - in - let rec gen_shards l a = - match l with - | (id, total) when id >= total -> return a - | (id, total) -> - let wrap ?(reuse:Shard.shard Shard.t option) state = match reuse with - | Some t -> t.state <- state; return t - | None -> return Shard.{ state; stopped = false } in - let create () = - Shard.create ~url ~shards:(id, total) ?compress ?large_threshold () - in - let rec bind (t:Shard.shard Shard.t) = - let _ = Ivar.read t.state.hb_interval >>> fun hb -> - Clock.every' - ~stop:(Ivar.read t.state.hb_stopper) - ~continue_on_error:true - hb (fun () -> Shard.heartbeat t.state >>| ignore) in - ev_loop t >>> ignore; - Pipe.closed (fst t.state.pipe) >>= (fun () -> - create () >>= wrap ~reuse:t >>= bind) >>> ignore; - return t - in - create () >>= wrap >>= bind >>= fun t -> - gen_shards (id+1, total) (t :: a) - in - gen_shards shard_list [] - >>| fun shards -> - (Http.get_current_user () >>> function - | Ok user -> Logs.info (fun m -> m "Logged in as %s" (User.tag user)) - | _ -> ()); - { shards; } - -let set_status ~status sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.set_status ~status t.state - ) sharder.shards - -let set_status_with ~f sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.set_status ~status:(f t.state) t.state - ) sharder.shards - -let request_guild_members ?query ?limit ~guild sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.request_guild_members ~guild ?query ?limit t.state - ) sharder.shards - -let shutdown_all ?restart sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.shutdown ~clean:true ?restart t - ) sharder.shards \ No newline at end of file diff --git a/lib/sharder.mli b/lib/sharder.mli deleted file mode 100644 index 7c9c90d..0000000 --- a/lib/sharder.mli +++ /dev/null @@ -1,101 +0,0 @@ -(** Internal sharding manager. Most of this is accessed through {!Client}. *) - -open Core -open Async -open Websocket_async - -exception Invalid_Payload -exception Failure_to_Establish_Heartbeat - -type t - -(** Start the Sharder. This is called by {!Client.start}. *) -val start : - ?count:int -> - ?compress:bool -> - ?large_threshold:int -> - unit -> - t Deferred.t - -(** Module representing a single shard. *) -module Shard : sig - (** Representation of the state of a shard. *) - type shard = { - compress: bool; (** Whether to compress payloads. *) - id: int * int; (** A tuple as expected by Discord. First element is the current shard index, second element is the total shard count. *) - hb_interval: Time.Span.t Ivar.t; (** Time span between heartbeats, wrapped in an Ivar. *) - hb_stopper: unit Ivar.t; (** Stops the heartbeat sequencer when filled. *) - large_threshold: int; (** Minimum number of members needed for a guild to be considered large. *) - pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; (** Raw frame IO pipe used for websocket communications. *) - ready: unit Ivar.t; (** A simple Ivar indicating if the shard has received READY. *) - seq: int; (** Current sequence number *) - session: string option; (** Session id, if one exists. *) - url: string; (** The websocket URL in use. *) - _internal: Reader.t * Writer.t; - } - - (** Wrapper around an internal state, used to wrap {!shard}. *) - type 'a t = { - mutable state: 'a; - mutable stopped: bool; - } - - (** Send a heartbeat to Discord. This is handled automatically. *) - val heartbeat : - shard -> - shard Deferred.t - - (** Set the status of the shard. *) - val set_status : - status:Yojson.Safe.t -> - shard -> - shard Deferred.t - - (** Request guild members for the shard's guild. Causes dispatch of multiple {{!Dispatch.members_chunk}member chunk} events. *) - val request_guild_members : - ?query:string -> - ?limit:int -> - guild:Snowflake.t -> - shard -> - shard Deferred.t - - (** Create a new shard *) - val create : - url:string -> - shards:int * int -> - ?compress:bool -> - ?large_threshold:int -> - unit -> - shard Deferred.t - - val shutdown : - ?clean:bool -> - ?restart:bool -> - shard t -> - unit Deferred.t -end - -(** Calls {!Shard.set_status} for each shard registered with the sharder. *) -val set_status : - status:Yojson.Safe.t -> - t -> - Shard.shard list Deferred.t - -(** Like {!set_status} but takes a function with a {{!Shard.shard}shard} as its parameter and {{!Yojson.Safe.t}json} for its return. *) -val set_status_with : - f:(Shard.shard -> Yojson.Safe.t) -> - t -> - Shard.shard list Deferred.t - -(** Calls {!Shard.request_guild_members} for each shard registered with the sharder. *) -val request_guild_members : - ?query:string -> - ?limit:int -> - guild:Snowflake.t -> - t -> - Shard.shard list Deferred.t - -val shutdown_all : - ?restart:bool -> - t -> - unit list Deferred.t -- cgit v1.2.3