diff options
| author | Adelyn Breedlove <[email protected]> | 2019-02-11 17:23:59 +0000 |
|---|---|---|
| committer | Adelyn Breedlove <[email protected]> | 2019-02-11 17:23:59 +0000 |
| commit | 7c9b809078b5cd53e3d54c0004c683da2ec679af (patch) | |
| tree | 5a1b165b597fc1ad4167115d9a23b12852a4636b /lib | |
| parent | Merge branch 'sharder_fixes' into 'master' (diff) | |
| download | disml-7c9b809078b5cd53e3d54c0004c683da2ec679af.tar.xz disml-7c9b809078b5cd53e3d54c0004c683da2ec679af.zip | |
Add a cache
Diffstat (limited to 'lib')
45 files changed, 1679 insertions, 1027 deletions
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
@@ -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/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/dispatch.ml b/lib/gateway/dispatch.ml index b4fc9d2..b4fc9d2 100644 --- a/lib/dispatch.ml +++ b/lib/gateway/dispatch.ml diff --git a/lib/dispatch.mli b/lib/gateway/dispatch.mli index 18b9261..18b9261 100644 --- a/lib/dispatch.mli +++ b/lib/gateway/dispatch.mli 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/event.mli b/lib/gateway/event.mli index 4db3c84..4db3c84 100644 --- a/lib/event.mli +++ b/lib/gateway/event.mli diff --git a/lib/opcode.ml b/lib/gateway/opcode.ml index 2462d05..32ab5b4 100644 --- a/lib/opcode.ml +++ b/lib/gateway/opcode.ml @@ -1,54 +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" +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/gateway/opcode.mli index b0e7adb..9fa5b96 100644 --- a/lib/opcode.mli +++ b/lib/gateway/opcode.mli @@ -1,29 +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. *) +(** 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/sharder.ml b/lib/gateway/sharder.ml index 8570a08..9fcb10d 100644 --- a/lib/sharder.ml +++ b/lib/gateway/sharder.ml @@ -30,23 +30,24 @@ let decompress src = | 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 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;
+ type 'a t =
+ { mutable state: 'a
+ ; mutable stopped: bool
+ ; mutable can_resume: bool
}
let identify_lock = Mvar.create ()
@@ -57,13 +58,16 @@ module Shard = struct | `Ok s -> begin
let open Frame.Opcode in
match s.opcode with
- | Text -> Ok (Yojson.Safe.from_string s.content)
+ | 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"
+ 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 -> Error "EOF"
+ | `Eof -> `Eof
let push_frame ?payload ~ev shard =
let content = match payload with
@@ -98,9 +102,9 @@ module Shard = struct 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;
+ return
+ { shard with seq = seq
+ ; session = session
}
let set_status ~(status:Yojson.Safe.t) shard =
@@ -151,26 +155,28 @@ module Shard = struct | 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
+ 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
+ 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 =
@@ -201,6 +207,7 @@ module Shard = struct ~ws_to_app
~net_to_ws
~ws_to_net
+ ?(ms=500)
uri =
client
~initialized
@@ -214,7 +221,7 @@ module Shard = struct match res with
| Ok () -> ()
| Error _ ->
- let backoff = Time.Span.create ~ms:500 () in
+ let backoff = Time.Span.create ~ms () in
Clock.after backoff >>> (fun () ->
make_client
~initialized
@@ -223,6 +230,7 @@ module Shard = struct ~ws_to_app
~net_to_ws
~ws_to_net
+ ~ms:(min 60_000 (ms * 2))
uri)
@@ -250,18 +258,17 @@ module Shard = struct ~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);
+ { 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
@@ -282,7 +289,8 @@ module Shard = struct let shutdown ?(clean=false) ?(restart=true) t =
let _ = clean in
- if not restart then t.stopped <- true;
+ 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 () ->
@@ -291,9 +299,7 @@ module Shard = struct Writer.close (snd t.state._internal)
end
-type t = {
- shards: (Shard.shard Shard.t) list;
-}
+type t = { shards: (Shard.shard Shard.t) list }
let start ?count ?compress ?large_threshold () =
let module J = Yojson.Safe.Util in
@@ -313,12 +319,18 @@ let start ?count ?compress ?large_threshold () = 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 ->
+ | `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 ()
+ | `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 ()
@@ -329,8 +341,16 @@ let start ?count ?compress ?large_threshold () = | (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
+ | 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
@@ -340,9 +360,9 @@ let start ?count ?compress ?large_threshold () = ~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;
+ 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 ->
@@ -350,10 +370,7 @@ let start ?count ?compress ?large_threshold () = 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; }
+ { shards }
let set_status ~status sharder =
Deferred.all @@ List.map ~f:(fun t ->
diff --git a/lib/sharder.mli b/lib/gateway/sharder.mli index 7c9c90d..a5f18e6 100644 --- a/lib/sharder.mli +++ b/lib/gateway/sharder.mli @@ -38,6 +38,7 @@ module Shard : sig type 'a t = {
mutable state: 'a;
mutable stopped: bool;
+ mutable can_resume: bool;
}
(** Send a heartbeat to Discord. This is handled automatically. *)
diff --git a/lib/endpoints.ml b/lib/http/endpoints.ml index c23ae88..9263207 100644 --- a/lib/endpoints.ml +++ b/lib/http/endpoints.ml @@ -1,63 +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" +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/http/endpoints.mli index 2abe01d..33e2ea5 100644 --- a/lib/endpoints.mli +++ b/lib/http/endpoints.mli @@ -1,63 +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 +(** 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.ml b/lib/http/http.ml index 283ab69..e1b2998 100644 --- a/lib/http.ml +++ b/lib/http/http.ml @@ -20,7 +20,7 @@ module Base = struct let process_request_headers () =
let h = Header.init () in
Header.add_list h [
- "User-Agent", "Dis.ml v0.1.0";
+ "User-Agent", "Dis.ml (https://gitlab.com/Mishio595/disml, v0.2.3)";
"Authorization", ("Bot " ^ !Client_options.token);
"Content-Type", "application/json";
"Connection", "keep-alive";
@@ -33,6 +33,7 @@ module Base = struct | 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 ->
diff --git a/lib/http.mli b/lib/http/http.mli index 0092d9b..fe587c7 100644 --- a/lib/http.mli +++ b/lib/http/http.mli @@ -1,185 +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 +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/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 |