diff options
| author | Adelyn Breedlove <[email protected]> | 2019-01-28 10:31:51 -0700 |
|---|---|---|
| committer | Adelyn Breedlove <[email protected]> | 2019-01-28 10:31:51 -0700 |
| commit | 8662e92987c437f59d09896a247ec2b5d82c4528 (patch) | |
| tree | f004cc14598351d4ad6b19d8e993d2f629c5e738 /lib | |
| parent | Add more docs (diff) | |
| download | disml-8662e92987c437f59d09896a247ec2b5d82c4528.tar.xz disml-8662e92987c437f59d09896a247ec2b5d82c4528.zip | |
Publish docs updates
Diffstat (limited to 'lib')
64 files changed, 3039 insertions, 3020 deletions
diff --git a/lib/client.ml b/lib/client.ml index 72be653..9fac420 100644 --- a/lib/client.ml +++ b/lib/client.ml @@ -1,22 +1,22 @@ -open Async -include Client_options -include Dispatch - -type t = { - sharder: Sharder.t; -} - -let start ?count token = - Client_options.token := token; - Sharder.start ?count () - >>| fun sharder -> - { sharder; } - -let set_status ~status client = - Sharder.set_status ~status client.sharder - -let set_status_with ~f client = - Sharder.set_status_with ~f client.sharder - -let request_guild_members ~guild ?query ?limit client = +open Async
+include Client_options
+include Dispatch
+
+type t = {
+ sharder: Sharder.t;
+}
+
+let start ?count token =
+ Client_options.token := token;
+ Sharder.start ?count ()
+ >>| fun sharder ->
+ { sharder; }
+
+let set_status ~status client =
+ Sharder.set_status ~status client.sharder
+
+let set_status_with ~f client =
+ Sharder.set_status_with ~f client.sharder
+
+let request_guild_members ~guild ?query ?limit client =
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 3e79a39..a05810b 100644 --- a/lib/client.mli +++ b/lib/client.mli @@ -1,37 +1,37 @@ -open Async - -include module type of Client_options -include module type of Dispatch - -(** Type of the Client, it isn't recommended to access the fields directly. *) -type t = { - sharder: Sharder.t; -} - -(** Start the Client. This begins shard connections to Discord and event handlers should be registered prior to calling this. - {3 Example} - {[ - open Async - open Disml - - let main () = - let token = "a valid bot token" in - Client.start ~count:5 token >>> print_endline "Client launched" - - let _ = - Scheduler.go_main ~main () - ]} - @param ?count Optional amount of shards to launch. Defaults to autosharding - @param string The token used for authentication - @return A deferred client object -*) -val start : ?count:int -> string -> t Deferred.t - -(** Same as {!Sharder.set_status} where [client.sharder] is passed. *) -val set_status : status:Yojson.Safe.json -> t -> Sharder.Shard.shard list Deferred.t - -(** Same as {!Sharder.set_status_with} where [client.sharder] is passed. *) -val set_status_with : f:(Sharder.Shard.shard -> Yojson.Safe.json) -> t -> Sharder.Shard.shard list Deferred.t - -(** Same as {!Sharder.request_guild_members} where [client.sharder] is passed. *) +open Async
+
+include module type of Client_options
+include module type of Dispatch
+
+(** Type of the Client, it isn't recommended to access the fields directly. *)
+type t = {
+ sharder: Sharder.t;
+}
+
+(** Start the Client. This begins shard connections to Discord and event handlers should be registered prior to calling this.
+ {3 Example}
+ {[
+ open Async
+ open Disml
+
+ let main () =
+ let token = "a valid bot token" in
+ Client.start ~count:5 token >>> print_endline "Client launched"
+
+ let _ =
+ Scheduler.go_main ~main ()
+ ]}
+ @param ?count Optional amount of shards to launch. Defaults to autosharding
+ @param string The token used for authentication
+ @return A deferred client object
+*)
+val start : ?count:int -> string -> t Deferred.t
+
+(** Same as {!Sharder.set_status} where [client.sharder] is passed. *)
+val set_status : status:Yojson.Safe.json -> t -> Sharder.Shard.shard list Deferred.t
+
+(** Same as {!Sharder.set_status_with} where [client.sharder] is passed. *)
+val set_status_with : f:(Sharder.Shard.shard -> Yojson.Safe.json) -> 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 diff --git a/lib/client_options.mli b/lib/client_options.mli index ee46aae..edf80e1 100644 --- a/lib/client_options.mli +++ b/lib/client_options.mli @@ -1,2 +1,2 @@ -(** Token that is set when using {!Client.start} *) +(** Token that is set when using {!Client.start} *)
val token : string ref
\ No newline at end of file diff --git a/lib/disml.ml b/lib/disml.ml index 021ceb0..c7c4c34 100644 --- a/lib/disml.ml +++ b/lib/disml.ml @@ -1,24 +1,24 @@ -module Client = Client -module Http = Http -module Sharder = Sharder - -module Models = struct - module Activity = Activity - module Attachment = Attachment - module Ban = Ban - module Channel = Channel - module Channel_id = Channel_id - module Embed = Embed - module Emoji = Emoji - module Guild = Guild - module Guild_id = Guild_id - module Member = Member - module Message = Message - module Presence = Presence - module Reaction = Reaction - module Role = Role - module Snowflake = Snowflake - module User = User - - module Event = Event_models +module Client = Client
+module Http = Http
+module Sharder = Sharder
+
+module Models = struct
+ module Activity = Activity
+ module Attachment = Attachment
+ module Ban = Ban
+ module Channel = Channel
+ module Channel_id = Channel_id
+ module Embed = Embed
+ module Emoji = Emoji
+ module Guild = Guild
+ module Guild_id = Guild_id
+ module Member = Member
+ module Message = Message
+ module Presence = Presence
+ module Reaction = Reaction
+ module Role = Role
+ module Snowflake = Snowflake
+ module User = User
+
+ module Event = Event_models
end
\ No newline at end of file diff --git a/lib/dispatch.ml b/lib/dispatch.ml index ef53442..3103285 100644 --- a/lib/dispatch.ml +++ b/lib/dispatch.ml @@ -1,36 +1,36 @@ -open Event_models - -let ready = ref (fun (_:Ready.t) -> ()) -let resumed = ref (fun (_:Resumed.t) -> ()) -let channel_create = ref (fun (_:ChannelCreate.t) -> ()) -let channel_update = ref (fun (_:ChannelUpdate.t) -> ()) -let channel_delete = ref (fun (_:ChannelDelete.t) -> ()) -let channel_pins_update = ref (fun (_:ChannelPinsUpdate.t) -> ()) -let guild_create = ref (fun (_:GuildCreate.t) -> ()) -let guild_update = ref (fun (_:GuildUpdate.t) -> ()) -let guild_delete = ref (fun (_:GuildDelete.t) -> ()) -let member_ban = ref (fun (_:GuildBanAdd.t) -> ()) -let member_unban = ref (fun (_:GuildBanRemove.t) -> ()) -let guild_emojis_update = ref (fun (_:GuildEmojisUpdate.t) -> ()) -(* let integrations_update = ref (fun (_:Yojson.Safe.json) -> ()) *) -let member_join = ref (fun (_:GuildMemberAdd.t) -> ()) -let member_leave = ref (fun (_:GuildMemberRemove.t) -> ()) -let member_update = ref (fun (_:GuildMemberUpdate.t) -> ()) -let members_chunk = ref (fun (_:GuildMembersChunk.t) -> ()) -let role_create = ref (fun (_:GuildRoleCreate.t) -> ()) -let role_update = ref (fun (_:GuildRoleUpdate.t) -> ()) -let role_delete = ref (fun (_:GuildRoleDelete.t) -> ()) -let message_create = ref (fun (_:MessageCreate.t) -> ()) -let message_update = ref (fun (_:MessageUpdate.t) -> ()) -let message_delete = ref (fun (_:MessageDelete.t) -> ()) -let message_delete_bulk = ref (fun (_:MessageDeleteBulk.t) -> ()) -let reaction_add = ref (fun (_:ReactionAdd.t) -> ()) -let reaction_remove = ref (fun (_:ReactionRemove.t) -> ()) -let reaction_remove_all = ref (fun (_:ReactionRemoveAll.t) -> ()) -let presence_update = ref (fun (_:PresenceUpdate.t) -> ()) -let typing_start = ref (fun (_:TypingStart.t) -> ()) -let user_update = ref (fun (_:UserUpdate.t) -> ()) -(* let voice_state_update = ref (fun (_:Yojson.Safe.json) -> ()) *) -(* let voice_server_update = ref (fun (_:Yojson.Safe.json) -> ()) *) -let webhook_update = ref (fun (_:WebhookUpdate.t) -> ()) +open Event_models
+
+let ready = ref (fun (_:Ready.t) -> ())
+let resumed = ref (fun (_:Resumed.t) -> ())
+let channel_create = ref (fun (_:ChannelCreate.t) -> ())
+let channel_update = ref (fun (_:ChannelUpdate.t) -> ())
+let channel_delete = ref (fun (_:ChannelDelete.t) -> ())
+let channel_pins_update = ref (fun (_:ChannelPinsUpdate.t) -> ())
+let guild_create = ref (fun (_:GuildCreate.t) -> ())
+let guild_update = ref (fun (_:GuildUpdate.t) -> ())
+let guild_delete = ref (fun (_:GuildDelete.t) -> ())
+let member_ban = ref (fun (_:GuildBanAdd.t) -> ())
+let member_unban = ref (fun (_:GuildBanRemove.t) -> ())
+let guild_emojis_update = ref (fun (_:GuildEmojisUpdate.t) -> ())
+(* let integrations_update = ref (fun (_:Yojson.Safe.json) -> ()) *)
+let member_join = ref (fun (_:GuildMemberAdd.t) -> ())
+let member_leave = ref (fun (_:GuildMemberRemove.t) -> ())
+let member_update = ref (fun (_:GuildMemberUpdate.t) -> ())
+let members_chunk = ref (fun (_:GuildMembersChunk.t) -> ())
+let role_create = ref (fun (_:GuildRoleCreate.t) -> ())
+let role_update = ref (fun (_:GuildRoleUpdate.t) -> ())
+let role_delete = ref (fun (_:GuildRoleDelete.t) -> ())
+let message_create = ref (fun (_:MessageCreate.t) -> ())
+let message_update = ref (fun (_:MessageUpdate.t) -> ())
+let message_delete = ref (fun (_:MessageDelete.t) -> ())
+let message_delete_bulk = ref (fun (_:MessageDeleteBulk.t) -> ())
+let reaction_add = ref (fun (_:ReactionAdd.t) -> ())
+let reaction_remove = ref (fun (_:ReactionRemove.t) -> ())
+let reaction_remove_all = ref (fun (_:ReactionRemoveAll.t) -> ())
+let presence_update = ref (fun (_:PresenceUpdate.t) -> ())
+let typing_start = ref (fun (_:TypingStart.t) -> ())
+let user_update = ref (fun (_:UserUpdate.t) -> ())
+(* let voice_state_update = ref (fun (_:Yojson.Safe.json) -> ()) *)
+(* let voice_server_update = ref (fun (_:Yojson.Safe.json) -> ()) *)
+let webhook_update = ref (fun (_:WebhookUpdate.t) -> ())
let unknown = ref (fun (_:Unknown.t) -> ())
\ No newline at end of file diff --git a/lib/dispatch.mli b/lib/dispatch.mli index 78126b7..36f3ece 100644 --- a/lib/dispatch.mli +++ b/lib/dispatch.mli @@ -1,120 +1,120 @@ -(** Used to store dispatch callbacks. Each event can only have one callback registered at a time. - These should be accessed through their re-export in {!Client}. - {3 Examples} - [Client.ready := (fun _ -> print_endline "Shard is Ready!")] - - [Client.guild_create := (fun guild -> print_endline guild.name)] - - {[ - open Core - open Disml - - let check_command (msg : Message.t) = - if String.is_prefix ~prefix:"!ping" msg.content then - Message.reply msg "Pong!" >>> ignore - - Client.message_create := check_command - ]} -*) - -open Event_models - -(** Dispatched when each shard receives READY from discord after identifying on the gateway. Other event dispatch is received after this. *) -val ready : (Ready.t -> unit) ref - -(** Dispatched when successfully reconnecting to the gateway. *) -val resumed : (Resumed.t -> unit) ref - -(** Dispatched when a channel is created which is visible to the bot. *) -val channel_create : (ChannelCreate.t -> unit) ref - -(** Dispatched when a channel visible to the bot is changed. *) -val channel_update : (ChannelUpdate.t -> unit) ref - -(** Dispatched when a channel visible to the bot is deleted. *) -val channel_delete : (ChannelDelete.t -> unit) ref - -(** Dispatched when messages are pinned or unpinned from a a channel. *) -val channel_pins_update : (ChannelPinsUpdate.t -> unit) ref - -(** Dispatched when the bot joins a guild, and during startup. *) -val guild_create : (GuildCreate.t -> unit) ref - -(** Dispatched when a guild the bot is in is edited. *) -val guild_update : (GuildUpdate.t -> unit) ref - -(** Dispatched when the bot is removed from a guild. *) -val guild_delete : (GuildDelete.t -> unit) ref - -(** Dispatched when a member is banned. *) -val member_ban : (GuildBanAdd.t -> unit) ref - -(** Dispatched when a member is unbanned. *) -val member_unban : (GuildBanRemove.t -> unit) ref - -(** Dispatched when emojis are added or removed from a guild. *) -val guild_emojis_update : (GuildEmojisUpdate.t -> unit) ref - -(** Dispatched when a guild's integrations are updated. *) -(* val integrations_update : (Yojson.Safe.json -> unit) ref *) - -(** Dispatched when a member joins a guild. *) -val member_join : (GuildMemberAdd.t -> unit) ref - -(** Dispatched when a member leaves a guild. Is Dispatched alongside {!Client.member_ban} when a user is banned. *) -val member_leave : (GuildMemberRemove.t -> unit) ref - -(** Dispatched when a member object is updated. *) -val member_update : (GuildMemberUpdate.t -> unit) ref - -(** Dispatched when requesting guild members through {!Client.request_guild_members} *) -val members_chunk : (GuildMembersChunk.t -> unit) ref - -(** Dispatched when a role is created. *) -val role_create : (GuildRoleCreate.t -> unit) ref - -(** Dispatched when a role is edited. *) -val role_update : (GuildRoleUpdate.t -> unit) ref - -(** Dispatched when a role is deleted. *) -val role_delete : (GuildRoleDelete.t -> unit) ref - -(** Dispatched when a message is sent. *) -val message_create : (MessageCreate.t -> unit) ref - -(** Dispatched when a message is edited. This does not necessarily mean the content changed. *) -val message_update : (MessageUpdate.t -> unit) ref - -(** Dispatched when a message is deleted. *) -val message_delete : (MessageDelete.t -> unit) ref - -(** Dispatched when messages are bulk deleted. *) -val message_delete_bulk : (MessageDeleteBulk.t -> unit) ref - -(** Dispatched when a rection is added to a message. *) -val reaction_add : (ReactionAdd.t -> unit) ref - -(** Dispatched when a reaction is removed from a message. *) -val reaction_remove : (ReactionRemove.t -> unit) ref - -(** Dispatched when all reactions are cleared from a message. *) -val reaction_remove_all : (ReactionRemoveAll.t -> unit) ref - -(** Dispatched when a user updates their presence. *) -val presence_update : (PresenceUpdate.t -> unit) ref - -(** Dispatched when a typing indicator is displayed. *) -val typing_start : (TypingStart.t -> unit) ref - -(** Dispatched when the current user is updated. You most likely want {!Client.member_update} or {!Client.presence_update} instead. *) -val user_update : (UserUpdate.t -> unit) ref - -(** Dispatched when a webhook is updated. *) -val webhook_update : (WebhookUpdate.t -> unit) ref - -(** Dispatched as a fallback for unknown events. *) -val unknown : (Unknown.t -> unit) ref - -(**/**) -(* val voice_state_update : (Yojson.Safe.json -> unit) ref *) +(** Used to store dispatch callbacks. Each event can only have one callback registered at a time.
+ These should be accessed through their re-export in {!Client}.
+ {3 Examples}
+ [Client.ready := (fun _ -> print_endline "Shard is Ready!")]
+
+ [Client.guild_create := (fun guild -> print_endline guild.name)]
+
+ {[
+ open Core
+ open Disml
+
+ let check_command (msg : Message.t) =
+ if String.is_prefix ~prefix:"!ping" msg.content then
+ Message.reply msg "Pong!" >>> ignore
+
+ Client.message_create := check_command
+ ]}
+*)
+
+open Event_models
+
+(** Dispatched when each shard receives READY from discord after identifying on the gateway. Other event dispatch is received after this. *)
+val ready : (Ready.t -> unit) ref
+
+(** Dispatched when successfully reconnecting to the gateway. *)
+val resumed : (Resumed.t -> unit) ref
+
+(** Dispatched when a channel is created which is visible to the bot. *)
+val channel_create : (ChannelCreate.t -> unit) ref
+
+(** Dispatched when a channel visible to the bot is changed. *)
+val channel_update : (ChannelUpdate.t -> unit) ref
+
+(** Dispatched when a channel visible to the bot is deleted. *)
+val channel_delete : (ChannelDelete.t -> unit) ref
+
+(** Dispatched when messages are pinned or unpinned from a a channel. *)
+val channel_pins_update : (ChannelPinsUpdate.t -> unit) ref
+
+(** Dispatched when the bot joins a guild, and during startup. *)
+val guild_create : (GuildCreate.t -> unit) ref
+
+(** Dispatched when a guild the bot is in is edited. *)
+val guild_update : (GuildUpdate.t -> unit) ref
+
+(** Dispatched when the bot is removed from a guild. *)
+val guild_delete : (GuildDelete.t -> unit) ref
+
+(** Dispatched when a member is banned. *)
+val member_ban : (GuildBanAdd.t -> unit) ref
+
+(** Dispatched when a member is unbanned. *)
+val member_unban : (GuildBanRemove.t -> unit) ref
+
+(** Dispatched when emojis are added or removed from a guild. *)
+val guild_emojis_update : (GuildEmojisUpdate.t -> unit) ref
+
+(** Dispatched when a guild's integrations are updated. *)
+(* val integrations_update : (Yojson.Safe.json -> unit) ref *)
+
+(** Dispatched when a member joins a guild. *)
+val member_join : (GuildMemberAdd.t -> unit) ref
+
+(** Dispatched when a member leaves a guild. Is Dispatched alongside {!Client.member_ban} when a user is banned. *)
+val member_leave : (GuildMemberRemove.t -> unit) ref
+
+(** Dispatched when a member object is updated. *)
+val member_update : (GuildMemberUpdate.t -> unit) ref
+
+(** Dispatched when requesting guild members through {!Client.request_guild_members} *)
+val members_chunk : (GuildMembersChunk.t -> unit) ref
+
+(** Dispatched when a role is created. *)
+val role_create : (GuildRoleCreate.t -> unit) ref
+
+(** Dispatched when a role is edited. *)
+val role_update : (GuildRoleUpdate.t -> unit) ref
+
+(** Dispatched when a role is deleted. *)
+val role_delete : (GuildRoleDelete.t -> unit) ref
+
+(** Dispatched when a message is sent. *)
+val message_create : (MessageCreate.t -> unit) ref
+
+(** Dispatched when a message is edited. This does not necessarily mean the content changed. *)
+val message_update : (MessageUpdate.t -> unit) ref
+
+(** Dispatched when a message is deleted. *)
+val message_delete : (MessageDelete.t -> unit) ref
+
+(** Dispatched when messages are bulk deleted. *)
+val message_delete_bulk : (MessageDeleteBulk.t -> unit) ref
+
+(** Dispatched when a rection is added to a message. *)
+val reaction_add : (ReactionAdd.t -> unit) ref
+
+(** Dispatched when a reaction is removed from a message. *)
+val reaction_remove : (ReactionRemove.t -> unit) ref
+
+(** Dispatched when all reactions are cleared from a message. *)
+val reaction_remove_all : (ReactionRemoveAll.t -> unit) ref
+
+(** Dispatched when a user updates their presence. *)
+val presence_update : (PresenceUpdate.t -> unit) ref
+
+(** Dispatched when a typing indicator is displayed. *)
+val typing_start : (TypingStart.t -> unit) ref
+
+(** Dispatched when the current user is updated. You most likely want {!Client.member_update} or {!Client.presence_update} instead. *)
+val user_update : (UserUpdate.t -> unit) ref
+
+(** Dispatched when a webhook is updated. *)
+val webhook_update : (WebhookUpdate.t -> unit) ref
+
+(** Dispatched as a fallback for unknown events. *)
+val unknown : (Unknown.t -> unit) ref
+
+(**/**)
+(* val voice_state_update : (Yojson.Safe.json -> unit) ref *)
(* val voice_server_update : (Yojson.Safe.json -> unit) ref *)
\ No newline at end of file @@ -1,27 +1,27 @@ -(library - (name disml) - (public_name disml) - (synopsis "An OCaml library for interfacing with the Discord API") - (modules - activity - attachment - ban ban_t - channel channel_t channel_id channel_id_t - embed - emoji - guild guild_t guild_id guild_id_t - member member_t - message message_t message_id - presence - reaction reaction_t - role role_t role_id - snowflake - user user_t user_id user_id_t - event_models - client client_options disml dispatch endpoints event http impl opcode rl s sharder - ) - (libraries core async_ssl cohttp-async logs yojson websocket-async zlib ppx_deriving_yojson.runtime) - (preprocess (pps ppx_jane ppx_deriving_yojson)) -) - -(include_subdirs unqualified) +(library
+ (name disml)
+ (public_name disml)
+ (synopsis "An OCaml library for interfacing with the Discord API")
+ (modules
+ activity
+ attachment
+ ban ban_t
+ channel channel_t channel_id channel_id_t
+ embed
+ emoji
+ guild guild_t guild_id guild_id_t
+ member member_t
+ message message_t message_id
+ presence
+ reaction reaction_t
+ role role_t role_id
+ snowflake
+ user user_t user_id user_id_t
+ event_models
+ client client_options disml dispatch endpoints event http impl opcode rl s sharder
+ )
+ (libraries core async_ssl cohttp-async logs yojson websocket-async zlib ppx_deriving_yojson.runtime)
+ (preprocess (pps ppx_jane ppx_deriving_yojson))
+)
+
+(include_subdirs unqualified)
diff --git a/lib/event.ml b/lib/event.ml index 468acc6..3f1fa9f 100644 --- a/lib/event.ml +++ b/lib/event.ml @@ -1,114 +1,114 @@ -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.json *) -| 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.json *) -(* | VOICE_SERVER_UPDATE of Yojson.Safe.json *) -| WEBHOOK_UPDATE of WebhookUpdate.t -| UNKNOWN of Unknown.t - -let event_of_yojson ~contents t = match t with - | "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 -> !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 +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.json *)
+| 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.json *)
+(* | VOICE_SERVER_UPDATE of Yojson.Safe.json *)
+| WEBHOOK_UPDATE of WebhookUpdate.t
+| UNKNOWN of Unknown.t
+
+let event_of_yojson ~contents t = match t with
+ | "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 -> !Dispatch.ready d
+ | RESUMED d -> !Dispatch.resumed d
+ | CHANNEL_CREATE d -> !Dispatch.channel_create d
+ | CHANNEL_UPDATE d -> !Dispatch.channel_update d
+ | CHANNEL_DELETE d -> !Dispatch.channel_delete d
+ | CHANNEL_PINS_UPDATE d -> !Dispatch.channel_pins_update d
+ | GUILD_CREATE d -> !Dispatch.guild_create d
+ | GUILD_UPDATE d -> !Dispatch.guild_update d
+ | GUILD_DELETE d -> !Dispatch.guild_delete d
+ | GUILD_BAN_ADD d -> !Dispatch.member_ban d
+ | GUILD_BAN_REMOVE d -> !Dispatch.member_unban d
+ | GUILD_EMOJIS_UPDATE d -> !Dispatch.guild_emojis_update d
+ (* | GUILD_INTEGRATIONS_UPDATE d -> !Dispatch.integrations_update d *)
+ | GUILD_MEMBER_ADD d -> !Dispatch.member_join d
+ | GUILD_MEMBER_REMOVE d -> !Dispatch.member_leave d
+ | GUILD_MEMBER_UPDATE d -> !Dispatch.member_update d
+ | GUILD_MEMBERS_CHUNK d -> !Dispatch.members_chunk d
+ | GUILD_ROLE_CREATE d -> !Dispatch.role_create d
+ | GUILD_ROLE_UPDATE d -> !Dispatch.role_update d
+ | GUILD_ROLE_DELETE d -> !Dispatch.role_delete d
+ | MESSAGE_CREATE d -> !Dispatch.message_create d
+ | MESSAGE_UPDATE d -> !Dispatch.message_update d
+ | MESSAGE_DELETE d -> !Dispatch.message_delete d
+ | MESSAGE_DELETE_BULK d -> !Dispatch.message_delete_bulk d
+ | REACTION_ADD d -> !Dispatch.reaction_add d
+ | REACTION_REMOVE d -> !Dispatch.reaction_remove d
+ | REACTION_REMOVE_ALL d -> !Dispatch.reaction_remove_all d
+ | PRESENCE_UPDATE d -> !Dispatch.presence_update d
+ | TYPING_START d -> !Dispatch.typing_start d
+ | USER_UPDATE d -> !Dispatch.user_update d
+ (* | VOICE_STATE_UPDATE d -> !Dispatch.voice_state_update d *)
+ (* | VOICE_SERVER_UPDATE d -> !Dispatch.voice_server_update d *)
+ | WEBHOOK_UPDATE d -> !Dispatch.webhook_update d
+ | UNKNOWN d -> !Dispatch.unknown d
+
+let handle_event ~ev contents =
+ event_of_yojson ~contents ev
|> dispatch
\ No newline at end of file diff --git a/lib/event.mli b/lib/event.mli index 9e05569..d4a539b 100644 --- a/lib/event.mli +++ b/lib/event.mli @@ -1,49 +1,49 @@ -(** Barebones of event dispatching. Most users will have no reason to look here. *) - -open Event_models - -(** Event dispatch type wrapper. Used internally. *) -type t = -| READY of Ready.t -| RESUMED of Resumed.t -| CHANNEL_CREATE of ChannelCreate.t -| CHANNEL_UPDATE of ChannelUpdate.t -| CHANNEL_DELETE of ChannelDelete.t -| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t -| GUILD_CREATE of GuildCreate.t -| GUILD_UPDATE of GuildUpdate.t -| GUILD_DELETE of GuildDelete.t -| GUILD_BAN_ADD of GuildBanAdd.t -| GUILD_BAN_REMOVE of GuildBanRemove.t -| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t -(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.json *) -| 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.json *) -(* | VOICE_SERVER_UPDATE of Yojson.Safe.json *) -| WEBHOOK_UPDATE of WebhookUpdate.t -| UNKNOWN of Unknown.t - -(** Used to convert an event string and payload into a t wrapper type. *) -val event_of_yojson : contents:Yojson.Safe.json -> string -> t - -(** Sends the event to the registered handler. *) -val dispatch : t -> unit - -(** Wrapper to other functions. This is called from the shards. *) +(** Barebones of event dispatching. Most users will have no reason to look here. *)
+
+open Event_models
+
+(** Event dispatch type wrapper. Used internally. *)
+type t =
+| READY of Ready.t
+| RESUMED of Resumed.t
+| CHANNEL_CREATE of ChannelCreate.t
+| CHANNEL_UPDATE of ChannelUpdate.t
+| CHANNEL_DELETE of ChannelDelete.t
+| CHANNEL_PINS_UPDATE of ChannelPinsUpdate.t
+| GUILD_CREATE of GuildCreate.t
+| GUILD_UPDATE of GuildUpdate.t
+| GUILD_DELETE of GuildDelete.t
+| GUILD_BAN_ADD of GuildBanAdd.t
+| GUILD_BAN_REMOVE of GuildBanRemove.t
+| GUILD_EMOJIS_UPDATE of GuildEmojisUpdate.t
+(* | GUILD_INTEGRATIONS_UPDATE of Yojson.Safe.json *)
+| 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.json *)
+(* | VOICE_SERVER_UPDATE of Yojson.Safe.json *)
+| WEBHOOK_UPDATE of WebhookUpdate.t
+| UNKNOWN of Unknown.t
+
+(** Used to convert an event string and payload into a t wrapper type. *)
+val event_of_yojson : contents:Yojson.Safe.json -> string -> t
+
+(** Sends the event to the registered handler. *)
+val dispatch : t -> unit
+
+(** Wrapper to other functions. This is called from the shards. *)
val handle_event : ev:string -> Yojson.Safe.json -> unit
\ No newline at end of file diff --git a/lib/http.ml b/lib/http.ml index 8927f47..9a47c65 100644 --- a/lib/http.ml +++ b/lib/http.ml @@ -1,356 +1,356 @@ -open Core -open Async -open Cohttp - -module Base = struct - exception Invalid_Method - - let rl = ref Rl.empty - - let base_url = "https://discordapp.com/api/v7" - - let process_url path = - Uri.of_string (base_url ^ path) - - let process_request_body body = - body - |> Yojson.Safe.to_string - |> Cohttp_async.Body.of_string - - let process_request_headers () = - let h = Header.init () in - Header.add_list h [ - "User-Agent", "Dis.ml v0.1.0"; - "Authorization", ("Bot " ^ !Client_options.token); - "Content-Type", "application/json"; - ] - - let process_response path ((resp:Response.t), body) = - (match Response.headers resp - |> Rl.rl_of_header with - | Some r -> Mvar.put (Rl.find_exn !rl path) r - | None -> return ()) - >>= fun () -> - match resp |> Response.status |> Code.code_of_status with - | 200 -> body |> Cohttp_async.Body.to_string >>| Yojson.Safe.from_string >>= Deferred.Or_error.return - | code -> - body |> Cohttp_async.Body.to_string >>= fun body -> - Deferred.Or_error.errorf "Unsuccessful response received: %d - %s" code body - - let request ?(body=`Null) ?(query=[]) m path = - rl := Rl.update ~f:(function - | None -> - let r = Mvar.create () in - Mvar.set r Rl.default; - r - | Some r -> r - ) !rl path; - let limit = Rl.find_exn !rl path in - Mvar.take limit >>= fun limit -> - let process () = - let uri = Uri.add_query_params' (process_url path) query in - let headers = process_request_headers () in - let body = process_request_body body in - (match m with - | `DELETE -> Cohttp_async.Client.delete ~headers ~body uri - | `GET -> Cohttp_async.Client.get ~headers uri - | `PATCH -> Cohttp_async.Client.patch ~headers ~body uri - | `POST -> Cohttp_async.Client.post ~headers ~body uri - | `PUT -> Cohttp_async.Client.put ~headers ~body uri - | _ -> raise Invalid_Method) - >>= process_response path - in if limit.remaining > 0 then process () - else Clock.at (Core.Time.(Span.of_int_sec limit.reset |> of_span_since_epoch)) >>= process -end - -let get_gateway () = - Base.request `GET Endpoints.gateway - -let get_gateway_bot () = - Base.request `GET Endpoints.gateway_bot - -let get_channel channel_id = - Base.request `GET (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let modify_channel channel_id body = - Base.request ~body `PATCH (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let delete_channel channel_id = - Base.request `DELETE (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let get_messages channel_id limit (kind, id) = - Base.request ~query:[(kind, string_of_int id); ("limit", string_of_int limit)] `GET (Endpoints.channel_messages channel_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) - -let get_message channel_id message_id = - Base.request `GET (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let create_message channel_id body = - Base.request ~body:body `POST (Endpoints.channel_messages channel_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let create_reaction channel_id message_id emoji = - Base.request `PUT (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore - -let delete_own_reaction channel_id message_id emoji = - Base.request `DELETE (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore - -let delete_reaction channel_id message_id emoji user_id = - Base.request `DELETE (Endpoints.channel_reaction channel_id message_id emoji user_id) >>| Result.map ~f:ignore - -let get_reactions channel_id message_id emoji = - Base.request `GET (Endpoints.channel_reactions_get channel_id message_id emoji) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:User_t.of_yojson_exn) - -let delete_reactions channel_id message_id = - Base.request `DELETE (Endpoints.channel_reactions_delete channel_id message_id) >>| Result.map ~f:ignore - -let edit_message channel_id message_id body = - Base.request ~body `PATCH (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn - -let delete_message channel_id message_id = - Base.request `DELETE (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:ignore - -let bulk_delete channel_id body = - Base.request ~body `POST (Endpoints.channel_bulk_delete channel_id) >>| Result.map ~f:ignore - -let edit_channel_permissions channel_id overwrite_id body = - Base.request ~body `PUT (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore - -let get_channel_invites channel_id = - Base.request `GET (Endpoints.channel_invites channel_id) - -let create_channel_invite channel_id body = - Base.request ~body `POST (Endpoints.channel_invites channel_id) - -let delete_channel_permission channel_id overwrite_id = - Base.request `DELETE (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore - -let broadcast_typing channel_id = - Base.request `POST (Endpoints.channel_typing channel_id) >>| Result.map ~f:ignore - -let get_pinned_messages channel_id = - Base.request `GET (Endpoints.channel_pins channel_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn) - -let pin_message channel_id message_id = - Base.request `PUT (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore - -let unpin_message channel_id message_id = - Base.request `DELETE (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore - -let group_recipient_add channel_id user_id = - Base.request `PUT (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore - -let group_recipient_remove channel_id user_id = - Base.request `DELETE (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore - -let get_emojis guild_id = - Base.request `GET (Endpoints.guild_emojis guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Emoji.of_yojson_exn) - -let get_emoji guild_id emoji_id = - Base.request `GET (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let create_emoji guild_id body = - Base.request ~body `POST (Endpoints.guild_emojis guild_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let edit_emoji guild_id emoji_id body = - Base.request ~body `PATCH (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn - -let delete_emoji guild_id emoji_id = - Base.request `DELETE (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:ignore - -let create_guild body = - Base.request ~body `POST Endpoints.guilds >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let get_guild guild_id = - Base.request `GET (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let edit_guild guild_id body = - Base.request ~body `PATCH (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)) - -let delete_guild guild_id = - Base.request `DELETE (Endpoints.guild guild_id) >>| Result.map ~f:ignore - -let get_guild_channels guild_id = - Base.request `GET (Endpoints.guild_channels guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Channel_t.(channel_wrapper_of_yojson_exn g |> wrap))) - -let create_guild_channel guild_id body = - Base.request ~body `POST (Endpoints.guild_channels guild_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap)) - -let modify_guild_channel_positions guild_id body = - Base.request ~body `PATCH (Endpoints.guild_channels guild_id) >>| Result.map ~f:ignore - -let get_member guild_id user_id = - Base.request `GET (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) - -let get_members guild_id = - Base.request `GET (Endpoints.guild_members guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id))) - -let add_member guild_id user_id body = - Base.request ~body `PUT (Endpoints.guild_member guild_id user_id) - >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)) - -let edit_member guild_id user_id body = - Base.request ~body `PATCH (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore - -let remove_member guild_id user_id body = - Base.request ~body `DELETE (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore - -let change_nickname guild_id body = - Base.request ~body `PATCH (Endpoints.guild_me_nick guild_id) - -let add_member_role guild_id user_id role_id = - Base.request `PUT (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore - -let remove_member_role guild_id user_id role_id = - Base.request `DELETE (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore - -let get_bans guild_id = - Base.request `GET (Endpoints.guild_bans guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Ban_t.of_yojson_exn) - -let get_ban guild_id user_id = - Base.request `GET (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:Ban_t.of_yojson_exn - -let guild_ban_add guild_id user_id body = - Base.request ~body `PUT (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore - -let guild_ban_remove guild_id user_id body = - Base.request ~body `DELETE (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore - -let get_roles guild_id = - Base.request `GET (Endpoints.guild_roles guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) - -let guild_role_add guild_id body = - Base.request ~body `POST (Endpoints.guild_roles guild_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) - -let guild_roles_edit guild_id body = - Base.request ~body `PATCH (Endpoints.guild_roles guild_id) - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))) - -let guild_role_edit guild_id role_id body = - Base.request ~body `PATCH (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)) - -let guild_role_remove guild_id role_id = - Base.request `DELETE (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:ignore - -let guild_prune_count guild_id days = - Base.request ~query:[("days", Int.to_string days)] `GET (Endpoints.guild_prune guild_id) - >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) - -let guild_prune_start guild_id days = - Base.request ~query:[("days", Int.to_string days)] `POST (Endpoints.guild_prune guild_id) - >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int)) - -let get_guild_voice_regions guild_id = - Base.request `GET (Endpoints.guild_voice_regions guild_id) - -let get_guild_invites guild_id = - Base.request `GET (Endpoints.guild_invites guild_id) - -let get_integrations guild_id = - Base.request `GET (Endpoints.guild_integrations guild_id) - -let add_integration guild_id body = - Base.request ~body `POST (Endpoints.guild_integrations guild_id) >>| Result.map ~f:ignore - -let edit_integration guild_id integration_id body = - Base.request ~body `POST (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore - -let delete_integration guild_id integration_id = - Base.request `DELETE (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore - -let sync_integration guild_id integration_id = - Base.request `POST (Endpoints.guild_integration_sync guild_id integration_id) >>| Result.map ~f:ignore - -let get_guild_embed guild_id = - Base.request `GET (Endpoints.guild_embed guild_id) - -let edit_guild_embed guild_id body = - Base.request ~body `PATCH (Endpoints.guild_embed guild_id) - -let get_vanity_url guild_id = - Base.request `GET (Endpoints.guild_vanity_url guild_id) - -let get_invite invite_code = - Base.request `GET (Endpoints.invite invite_code) - -let delete_invite invite_code = - Base.request `DELETE (Endpoints.invite invite_code) - -let get_current_user () = - Base.request `GET Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn - -let edit_current_user body = - Base.request ~body `PATCH Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn - -let get_guilds () = - Base.request `GET Endpoints.me_guilds - >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))) - -let leave_guild guild_id = - Base.request `DELETE (Endpoints.me_guild guild_id) >>| Result.map ~f:ignore - -let get_private_channels () = - Base.request `GET Endpoints.me_channels - -let create_dm body = - Base.request ~body `POST Endpoints.me_channels - -let create_group_dm body = - Base.request ~body `POST Endpoints.me_channels - -let get_connections () = - Base.request `GET Endpoints.me_connections - -let get_user user_id = - Base.request `GET (Endpoints.user user_id) >>| Result.map ~f:User_t.of_yojson_exn - -let get_voice_regions () = - Base.request `GET Endpoints.regions - -let create_webhook channel_id body = - Base.request ~body `POST (Endpoints.webhooks_channel channel_id) - -let get_channel_webhooks channel_id = - Base.request `GET (Endpoints.webhooks_channel channel_id) - -let get_guild_webhooks guild_id = - Base.request `GET (Endpoints.webhooks_guild guild_id) - -let get_webhook webhook_id = - Base.request `GET (Endpoints.webhook webhook_id) - -let get_webhook_with_token webhook_id token = - Base.request `GET (Endpoints.webhook_token webhook_id token) - -let edit_webhook webhook_id body = - Base.request ~body `PATCH (Endpoints.webhook webhook_id) - -let edit_webhook_with_token webhook_id token body = - Base.request ~body `PATCH (Endpoints.webhook_token webhook_id token) - -let delete_webhook webhook_id = - Base.request `DELETE (Endpoints.webhook webhook_id) >>| Result.map ~f:ignore - -let delete_webhook_with_token webhook_id token = - Base.request `DELETE (Endpoints.webhook_token webhook_id token) >>| Result.map ~f:ignore - -let execute_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_token webhook_id token) - -let execute_slack_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_slack webhook_id token) - -let execute_git_webhook webhook_id token body = - Base.request ~body `POST (Endpoints.webhook_git webhook_id token) - -let get_audit_logs guild_id body = - Base.request ~body `GET (Endpoints.guild_audit_logs guild_id) - -let get_application_info () = +open Core
+open Async
+open Cohttp
+
+module Base = struct
+ exception Invalid_Method
+
+ let rl = ref Rl.empty
+
+ let base_url = "https://discordapp.com/api/v7"
+
+ let process_url path =
+ Uri.of_string (base_url ^ path)
+
+ let process_request_body body =
+ body
+ |> Yojson.Safe.to_string
+ |> Cohttp_async.Body.of_string
+
+ let process_request_headers () =
+ let h = Header.init () in
+ Header.add_list h [
+ "User-Agent", "Dis.ml v0.1.0";
+ "Authorization", ("Bot " ^ !Client_options.token);
+ "Content-Type", "application/json";
+ ]
+
+ let process_response path ((resp:Response.t), body) =
+ (match Response.headers resp
+ |> Rl.rl_of_header with
+ | Some r -> Mvar.put (Rl.find_exn !rl path) r
+ | None -> return ())
+ >>= fun () ->
+ match resp |> Response.status |> Code.code_of_status with
+ | 200 -> body |> Cohttp_async.Body.to_string >>| Yojson.Safe.from_string >>= Deferred.Or_error.return
+ | code ->
+ body |> Cohttp_async.Body.to_string >>= fun body ->
+ Deferred.Or_error.errorf "Unsuccessful response received: %d - %s" code body
+
+ let request ?(body=`Null) ?(query=[]) m path =
+ rl := Rl.update ~f:(function
+ | None ->
+ let r = Mvar.create () in
+ Mvar.set r Rl.default;
+ r
+ | Some r -> r
+ ) !rl path;
+ let limit = Rl.find_exn !rl path in
+ Mvar.take limit >>= fun limit ->
+ let process () =
+ let uri = Uri.add_query_params' (process_url path) query in
+ let headers = process_request_headers () in
+ let body = process_request_body body in
+ (match m with
+ | `DELETE -> Cohttp_async.Client.delete ~headers ~body uri
+ | `GET -> Cohttp_async.Client.get ~headers uri
+ | `PATCH -> Cohttp_async.Client.patch ~headers ~body uri
+ | `POST -> Cohttp_async.Client.post ~headers ~body uri
+ | `PUT -> Cohttp_async.Client.put ~headers ~body uri
+ | _ -> raise Invalid_Method)
+ >>= process_response path
+ in if limit.remaining > 0 then process ()
+ else Clock.at (Core.Time.(Span.of_int_sec limit.reset |> of_span_since_epoch)) >>= process
+end
+
+let get_gateway () =
+ Base.request `GET Endpoints.gateway
+
+let get_gateway_bot () =
+ Base.request `GET Endpoints.gateway_bot
+
+let get_channel channel_id =
+ Base.request `GET (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap))
+
+let modify_channel channel_id body =
+ Base.request ~body `PATCH (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap))
+
+let delete_channel channel_id =
+ Base.request `DELETE (Endpoints.channel channel_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap))
+
+let get_messages channel_id limit (kind, id) =
+ Base.request ~query:[(kind, string_of_int id); ("limit", string_of_int limit)] `GET (Endpoints.channel_messages channel_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn)
+
+let get_message channel_id message_id =
+ Base.request `GET (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn
+
+let create_message channel_id body =
+ Base.request ~body:body `POST (Endpoints.channel_messages channel_id) >>| Result.map ~f:Message_t.of_yojson_exn
+
+let create_reaction channel_id message_id emoji =
+ Base.request `PUT (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore
+
+let delete_own_reaction channel_id message_id emoji =
+ Base.request `DELETE (Endpoints.channel_reaction_me channel_id message_id emoji) >>| Result.map ~f:ignore
+
+let delete_reaction channel_id message_id emoji user_id =
+ Base.request `DELETE (Endpoints.channel_reaction channel_id message_id emoji user_id) >>| Result.map ~f:ignore
+
+let get_reactions channel_id message_id emoji =
+ Base.request `GET (Endpoints.channel_reactions_get channel_id message_id emoji)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:User_t.of_yojson_exn)
+
+let delete_reactions channel_id message_id =
+ Base.request `DELETE (Endpoints.channel_reactions_delete channel_id message_id) >>| Result.map ~f:ignore
+
+let edit_message channel_id message_id body =
+ Base.request ~body `PATCH (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:Message_t.of_yojson_exn
+
+let delete_message channel_id message_id =
+ Base.request `DELETE (Endpoints.channel_message channel_id message_id) >>| Result.map ~f:ignore
+
+let bulk_delete channel_id body =
+ Base.request ~body `POST (Endpoints.channel_bulk_delete channel_id) >>| Result.map ~f:ignore
+
+let edit_channel_permissions channel_id overwrite_id body =
+ Base.request ~body `PUT (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore
+
+let get_channel_invites channel_id =
+ Base.request `GET (Endpoints.channel_invites channel_id)
+
+let create_channel_invite channel_id body =
+ Base.request ~body `POST (Endpoints.channel_invites channel_id)
+
+let delete_channel_permission channel_id overwrite_id =
+ Base.request `DELETE (Endpoints.channel_permission channel_id overwrite_id) >>| Result.map ~f:ignore
+
+let broadcast_typing channel_id =
+ Base.request `POST (Endpoints.channel_typing channel_id) >>| Result.map ~f:ignore
+
+let get_pinned_messages channel_id =
+ Base.request `GET (Endpoints.channel_pins channel_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Message_t.of_yojson_exn)
+
+let pin_message channel_id message_id =
+ Base.request `PUT (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore
+
+let unpin_message channel_id message_id =
+ Base.request `DELETE (Endpoints.channel_pin channel_id message_id) >>| Result.map ~f:ignore
+
+let group_recipient_add channel_id user_id =
+ Base.request `PUT (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore
+
+let group_recipient_remove channel_id user_id =
+ Base.request `DELETE (Endpoints.group_recipient channel_id user_id) >>| Result.map ~f:ignore
+
+let get_emojis guild_id =
+ Base.request `GET (Endpoints.guild_emojis guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Emoji.of_yojson_exn)
+
+let get_emoji guild_id emoji_id =
+ Base.request `GET (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn
+
+let create_emoji guild_id body =
+ Base.request ~body `POST (Endpoints.guild_emojis guild_id) >>| Result.map ~f:Emoji.of_yojson_exn
+
+let edit_emoji guild_id emoji_id body =
+ Base.request ~body `PATCH (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:Emoji.of_yojson_exn
+
+let delete_emoji guild_id emoji_id =
+ Base.request `DELETE (Endpoints.guild_emoji guild_id emoji_id) >>| Result.map ~f:ignore
+
+let create_guild body =
+ Base.request ~body `POST Endpoints.guilds >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))
+
+let get_guild guild_id =
+ Base.request `GET (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))
+
+let edit_guild guild_id body =
+ Base.request ~body `PATCH (Endpoints.guild guild_id) >>| Result.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap))
+
+let delete_guild guild_id =
+ Base.request `DELETE (Endpoints.guild guild_id) >>| Result.map ~f:ignore
+
+let get_guild_channels guild_id =
+ Base.request `GET (Endpoints.guild_channels guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Channel_t.(channel_wrapper_of_yojson_exn g |> wrap)))
+
+let create_guild_channel guild_id body =
+ Base.request ~body `POST (Endpoints.guild_channels guild_id) >>| Result.map ~f:(fun c -> Channel_t.(channel_wrapper_of_yojson_exn c |> wrap))
+
+let modify_guild_channel_positions guild_id body =
+ Base.request ~body `PATCH (Endpoints.guild_channels guild_id) >>| Result.map ~f:ignore
+
+let get_member guild_id user_id =
+ Base.request `GET (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id))
+
+let get_members guild_id =
+ Base.request `GET (Endpoints.guild_members guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id)))
+
+let add_member guild_id user_id body =
+ Base.request ~body `PUT (Endpoints.guild_member guild_id user_id)
+ >>| Result.map ~f:(fun m -> Member_t.(member_of_yojson_exn m |> wrap ~guild_id))
+
+let edit_member guild_id user_id body =
+ Base.request ~body `PATCH (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore
+
+let remove_member guild_id user_id body =
+ Base.request ~body `DELETE (Endpoints.guild_member guild_id user_id) >>| Result.map ~f:ignore
+
+let change_nickname guild_id body =
+ Base.request ~body `PATCH (Endpoints.guild_me_nick guild_id)
+
+let add_member_role guild_id user_id role_id =
+ Base.request `PUT (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore
+
+let remove_member_role guild_id user_id role_id =
+ Base.request `DELETE (Endpoints.guild_member_role guild_id user_id role_id) >>| Result.map ~f:ignore
+
+let get_bans guild_id =
+ Base.request `GET (Endpoints.guild_bans guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:Ban_t.of_yojson_exn)
+
+let get_ban guild_id user_id =
+ Base.request `GET (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:Ban_t.of_yojson_exn
+
+let guild_ban_add guild_id user_id body =
+ Base.request ~body `PUT (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore
+
+let guild_ban_remove guild_id user_id body =
+ Base.request ~body `DELETE (Endpoints.guild_ban guild_id user_id) >>| Result.map ~f:ignore
+
+let get_roles guild_id =
+ Base.request `GET (Endpoints.guild_roles guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)))
+
+let guild_role_add guild_id body =
+ Base.request ~body `POST (Endpoints.guild_roles guild_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))
+
+let guild_roles_edit guild_id body =
+ Base.request ~body `PATCH (Endpoints.guild_roles guild_id)
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id)))
+
+let guild_role_edit guild_id role_id body =
+ Base.request ~body `PATCH (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:(fun r -> Role_t.(role_of_yojson_exn r |> wrap ~guild_id))
+
+let guild_role_remove guild_id role_id =
+ Base.request `DELETE (Endpoints.guild_role guild_id role_id) >>| Result.map ~f:ignore
+
+let guild_prune_count guild_id days =
+ Base.request ~query:[("days", Int.to_string days)] `GET (Endpoints.guild_prune guild_id)
+ >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int))
+
+let guild_prune_start guild_id days =
+ Base.request ~query:[("days", Int.to_string days)] `POST (Endpoints.guild_prune guild_id)
+ >>| Result.map ~f:(fun c -> Yojson.Safe.Util.(member "pruned" c |> to_int))
+
+let get_guild_voice_regions guild_id =
+ Base.request `GET (Endpoints.guild_voice_regions guild_id)
+
+let get_guild_invites guild_id =
+ Base.request `GET (Endpoints.guild_invites guild_id)
+
+let get_integrations guild_id =
+ Base.request `GET (Endpoints.guild_integrations guild_id)
+
+let add_integration guild_id body =
+ Base.request ~body `POST (Endpoints.guild_integrations guild_id) >>| Result.map ~f:ignore
+
+let edit_integration guild_id integration_id body =
+ Base.request ~body `POST (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore
+
+let delete_integration guild_id integration_id =
+ Base.request `DELETE (Endpoints.guild_integration guild_id integration_id) >>| Result.map ~f:ignore
+
+let sync_integration guild_id integration_id =
+ Base.request `POST (Endpoints.guild_integration_sync guild_id integration_id) >>| Result.map ~f:ignore
+
+let get_guild_embed guild_id =
+ Base.request `GET (Endpoints.guild_embed guild_id)
+
+let edit_guild_embed guild_id body =
+ Base.request ~body `PATCH (Endpoints.guild_embed guild_id)
+
+let get_vanity_url guild_id =
+ Base.request `GET (Endpoints.guild_vanity_url guild_id)
+
+let get_invite invite_code =
+ Base.request `GET (Endpoints.invite invite_code)
+
+let delete_invite invite_code =
+ Base.request `DELETE (Endpoints.invite invite_code)
+
+let get_current_user () =
+ Base.request `GET Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn
+
+let edit_current_user body =
+ Base.request ~body `PATCH Endpoints.me >>| Result.map ~f:User_t.of_yojson_exn
+
+let get_guilds () =
+ Base.request `GET Endpoints.me_guilds
+ >>| Result.map ~f:(fun l -> Yojson.Safe.Util.to_list l |> List.map ~f:(fun g -> Guild_t.(pre_of_yojson_exn g |> wrap)))
+
+let leave_guild guild_id =
+ Base.request `DELETE (Endpoints.me_guild guild_id) >>| Result.map ~f:ignore
+
+let get_private_channels () =
+ Base.request `GET Endpoints.me_channels
+
+let create_dm body =
+ Base.request ~body `POST Endpoints.me_channels
+
+let create_group_dm body =
+ Base.request ~body `POST Endpoints.me_channels
+
+let get_connections () =
+ Base.request `GET Endpoints.me_connections
+
+let get_user user_id =
+ Base.request `GET (Endpoints.user user_id) >>| Result.map ~f:User_t.of_yojson_exn
+
+let get_voice_regions () =
+ Base.request `GET Endpoints.regions
+
+let create_webhook channel_id body =
+ Base.request ~body `POST (Endpoints.webhooks_channel channel_id)
+
+let get_channel_webhooks channel_id =
+ Base.request `GET (Endpoints.webhooks_channel channel_id)
+
+let get_guild_webhooks guild_id =
+ Base.request `GET (Endpoints.webhooks_guild guild_id)
+
+let get_webhook webhook_id =
+ Base.request `GET (Endpoints.webhook webhook_id)
+
+let get_webhook_with_token webhook_id token =
+ Base.request `GET (Endpoints.webhook_token webhook_id token)
+
+let edit_webhook webhook_id body =
+ Base.request ~body `PATCH (Endpoints.webhook webhook_id)
+
+let edit_webhook_with_token webhook_id token body =
+ Base.request ~body `PATCH (Endpoints.webhook_token webhook_id token)
+
+let delete_webhook webhook_id =
+ Base.request `DELETE (Endpoints.webhook webhook_id) >>| Result.map ~f:ignore
+
+let delete_webhook_with_token webhook_id token =
+ Base.request `DELETE (Endpoints.webhook_token webhook_id token) >>| Result.map ~f:ignore
+
+let execute_webhook webhook_id token body =
+ Base.request ~body `POST (Endpoints.webhook_token webhook_id token)
+
+let execute_slack_webhook webhook_id token body =
+ Base.request ~body `POST (Endpoints.webhook_slack webhook_id token)
+
+let execute_git_webhook webhook_id token body =
+ Base.request ~body `POST (Endpoints.webhook_git webhook_id token)
+
+let get_audit_logs guild_id body =
+ Base.request ~body `GET (Endpoints.guild_audit_logs guild_id)
+
+let get_application_info () =
Base.request `GET (Endpoints.application_information)
\ No newline at end of file diff --git a/lib/impl.ml b/lib/impl.ml index cc0f050..5fd7680 100644 --- a/lib/impl.ml +++ b/lib/impl.ml @@ -1,164 +1,164 @@ -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) -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 +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)
+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 68b3a97..6ccc66d 100644 --- a/lib/models/channel/channel.ml +++ b/lib/models/channel/channel.ml @@ -1,3 +1,3 @@ -include Channel_t - +include Channel_t
+
include Impl.Channel(Channel_t)
\ No newline at end of file diff --git a/lib/models/channel/channel.mli b/lib/models/channel/channel.mli index feb7323..3eece7d 100644 --- a/lib/models/channel/channel.mli +++ b/lib/models/channel/channel.mli @@ -1,3 +1,3 @@ -include module type of Channel_t -include S.ChannelImpl with +include module type of Channel_t
+include S.ChannelImpl with
type t := Channel_t.t
\ No newline at end of file diff --git a/lib/models/channel/channel_t.ml b/lib/models/channel/channel_t.ml index 62d6ac0..b02fa31 100644 --- a/lib/models/channel/channel_t.ml +++ b/lib/models/channel/channel_t.ml @@ -1,118 +1,118 @@ -open Core - -exception Invalid_channel of Yojson.Safe.json - -type group = { - id: Channel_id_t.t; - last_message_id: Message_id.t option [@default None]; - last_pin_timestamp: string option [@default None]; - icon: string option [@default None]; - name: string option [@default None]; - owner_id: User_id_t.t; - recipients: User_t.t list [@default []]; -} [@@deriving sexp, yojson { strict = false}] - -type dm = { - id: Channel_id_t.t; - last_message_id: Message_id.t option [@default None]; - last_pin_timestamp: string option [@default None]; -} [@@deriving sexp, yojson { strict = false}] - -type guild_text = { - id: Channel_id_t.t; - last_message_id: Message_id.t option [@default None]; - last_pin_timestamp: string option [@default None]; - category_id: Channel_id_t.t option [@default None][@key "parent_id"]; - guild_id: Guild_id_t.t option [@default None]; - name: string; - position: int; - topic: string option [@default None]; - nsfw: bool; - slow_mode_timeout: int option [@default None]; -} [@@deriving sexp, yojson { strict = false}] - -type guild_voice = { - id: Channel_id_t.t; - category_id: Channel_id_t.t option [@default None][@key "parent_id"]; - guild_id: Guild_id_t.t option [@default None]; - name: string; - position: int; - user_limit: int [@default -1]; - bitrate: int option [@default None]; -} [@@deriving sexp, yojson { strict = false}] - -type category = { - id: Channel_id_t.t; - guild_id: Guild_id_t.t option [@default None]; - position: int; - name: string; -} [@@deriving sexp, yojson { strict = false}] - -type t = -| Group of group -| Private of dm -| GuildText of guild_text -| GuildVoice of guild_voice -| Category of category -[@@deriving sexp, yojson { strict = false}] - -type channel_wrapper = { - id: Channel_id_t.t; - kind: int [@key "type"]; - guild_id: Guild_id_t.t option [@default None]; - position: int option [@default None]; - name: string option [@default None]; - topic: string option [@default None]; - nsfw: bool option [@default None]; - last_message_id: Message_id.t option [@default None]; - bitrate: int option [@default None]; - user_limit: int option [@default None]; - slow_mode_timeout: int option [@default None]; - recipients: User_t.t list option [@default None]; - icon: string option [@default None]; - owner_id: User_id_t.t option [@default None]; - application_id: Snowflake.t option [@default None]; - category_id: Channel_id_t.t option [@default None][@key "parent_id"]; - last_pin_timestamp: string option [@default None]; -} [@@deriving sexp, yojson { strict = false}] - -let unwrap_as_guild_text {id;guild_id;position;name;topic;nsfw;last_message_id;slow_mode_timeout;category_id;last_pin_timestamp;_} = - let position = Option.value_exn position in - let name = Option.value_exn name in - let nsfw = Option.value ~default:false nsfw in - { id; guild_id; position; name; topic; nsfw; last_message_id; slow_mode_timeout; category_id; last_pin_timestamp } - -let unwrap_as_guild_voice {id;guild_id;position;name;bitrate;user_limit;category_id;_} = - let position = Option.value_exn position in - let name = Option.value_exn name in - let user_limit = Option.value ~default:(-1) user_limit in - { id; guild_id; position; name; user_limit; bitrate ; category_id; } - -let unwrap_as_dm {id;last_message_id;last_pin_timestamp;_} = - { id; last_message_id; last_pin_timestamp; } - -let unwrap_as_group {id;name;last_message_id;recipients;icon;owner_id;last_pin_timestamp;_} = - let recipients = Option.value ~default:[] recipients in - let owner_id = Option.value_exn owner_id in - { id; name; last_message_id; recipients; icon; owner_id; last_pin_timestamp; } - -let unwrap_as_category {id;guild_id;position;name;_} = - let position = Option.value_exn position in - let name = Option.value_exn name in - { id; guild_id; position; name; } - -let wrap s = - match s.kind with - | 0 -> GuildText (unwrap_as_guild_text s) - | 1 -> Private (unwrap_as_dm s) - | 2 -> GuildVoice (unwrap_as_guild_voice s) - | 3 -> Group (unwrap_as_group s) - | 4 -> Category (unwrap_as_category s) - | _ -> raise (Invalid_channel (channel_wrapper_to_yojson s)) - -let get_id = function -| Group g -> let `Channel_id id = g.id in id -| Private p -> let `Channel_id id = p.id in id -| GuildText t -> let `Channel_id id = t.id in id -| GuildVoice v -> let `Channel_id id = v.id in id +open Core
+
+exception Invalid_channel of Yojson.Safe.json
+
+type group = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option [@default None];
+ last_pin_timestamp: string option [@default None];
+ icon: string option [@default None];
+ name: string option [@default None];
+ owner_id: User_id_t.t;
+ recipients: User_t.t list [@default []];
+} [@@deriving sexp, yojson { strict = false}]
+
+type dm = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option [@default None];
+ last_pin_timestamp: string option [@default None];
+} [@@deriving sexp, yojson { strict = false}]
+
+type guild_text = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option [@default None];
+ last_pin_timestamp: string option [@default None];
+ category_id: Channel_id_t.t option [@default None][@key "parent_id"];
+ guild_id: Guild_id_t.t option [@default None];
+ name: string;
+ position: int;
+ topic: string option [@default None];
+ nsfw: bool;
+ slow_mode_timeout: int option [@default None];
+} [@@deriving sexp, yojson { strict = false}]
+
+type guild_voice = {
+ id: Channel_id_t.t;
+ category_id: Channel_id_t.t option [@default None][@key "parent_id"];
+ guild_id: Guild_id_t.t option [@default None];
+ name: string;
+ position: int;
+ user_limit: int [@default -1];
+ bitrate: int option [@default None];
+} [@@deriving sexp, yojson { strict = false}]
+
+type category = {
+ id: Channel_id_t.t;
+ guild_id: Guild_id_t.t option [@default None];
+ position: int;
+ name: string;
+} [@@deriving sexp, yojson { strict = false}]
+
+type t =
+| Group of group
+| Private of dm
+| GuildText of guild_text
+| GuildVoice of guild_voice
+| Category of category
+[@@deriving sexp, yojson { strict = false}]
+
+type channel_wrapper = {
+ id: Channel_id_t.t;
+ kind: int [@key "type"];
+ guild_id: Guild_id_t.t option [@default None];
+ position: int option [@default None];
+ name: string option [@default None];
+ topic: string option [@default None];
+ nsfw: bool option [@default None];
+ last_message_id: Message_id.t option [@default None];
+ bitrate: int option [@default None];
+ user_limit: int option [@default None];
+ slow_mode_timeout: int option [@default None];
+ recipients: User_t.t list option [@default None];
+ icon: string option [@default None];
+ owner_id: User_id_t.t option [@default None];
+ application_id: Snowflake.t option [@default None];
+ category_id: Channel_id_t.t option [@default None][@key "parent_id"];
+ last_pin_timestamp: string option [@default None];
+} [@@deriving sexp, yojson { strict = false}]
+
+let unwrap_as_guild_text {id;guild_id;position;name;topic;nsfw;last_message_id;slow_mode_timeout;category_id;last_pin_timestamp;_} =
+ let position = Option.value_exn position in
+ let name = Option.value_exn name in
+ let nsfw = Option.value ~default:false nsfw in
+ { id; guild_id; position; name; topic; nsfw; last_message_id; slow_mode_timeout; category_id; last_pin_timestamp }
+
+let unwrap_as_guild_voice {id;guild_id;position;name;bitrate;user_limit;category_id;_} =
+ let position = Option.value_exn position in
+ let name = Option.value_exn name in
+ let user_limit = Option.value ~default:(-1) user_limit in
+ { id; guild_id; position; name; user_limit; bitrate ; category_id; }
+
+let unwrap_as_dm {id;last_message_id;last_pin_timestamp;_} =
+ { id; last_message_id; last_pin_timestamp; }
+
+let unwrap_as_group {id;name;last_message_id;recipients;icon;owner_id;last_pin_timestamp;_} =
+ let recipients = Option.value ~default:[] recipients in
+ let owner_id = Option.value_exn owner_id in
+ { id; name; last_message_id; recipients; icon; owner_id; last_pin_timestamp; }
+
+let unwrap_as_category {id;guild_id;position;name;_} =
+ let position = Option.value_exn position in
+ let name = Option.value_exn name in
+ { id; guild_id; position; name; }
+
+let wrap s =
+ match s.kind with
+ | 0 -> GuildText (unwrap_as_guild_text s)
+ | 1 -> Private (unwrap_as_dm s)
+ | 2 -> GuildVoice (unwrap_as_guild_voice s)
+ | 3 -> Group (unwrap_as_group s)
+ | 4 -> Category (unwrap_as_category s)
+ | _ -> raise (Invalid_channel (channel_wrapper_to_yojson s))
+
+let get_id = function
+| Group g -> let `Channel_id id = g.id in id
+| Private p -> let `Channel_id id = p.id in id
+| GuildText t -> let `Channel_id id = t.id in id
+| GuildVoice v -> let `Channel_id id = v.id in id
| Category c -> let `Channel_id id = c.id in id
\ No newline at end of file diff --git a/lib/models/channel/channel_t.mli b/lib/models/channel/channel_t.mli index 9deea82..711b319 100644 --- a/lib/models/channel/channel_t.mli +++ b/lib/models/channel/channel_t.mli @@ -1,96 +1,96 @@ -exception Invalid_channel of Yojson.Safe.json - -(** Represents a Group channel object. *) -type group = { - id: Channel_id_t.t; - last_message_id: Message_id.t option; - last_pin_timestamp: string option; - icon: string option; - name: string option; - owner_id: User_id_t.t; - recipients: User_t.t list; -} [@@deriving sexp, yojson] - -(** Represents a private channel with a single user. *) -type dm = { - id: Channel_id_t.t; - last_message_id: Message_id.t option; - last_pin_timestamp: string option; -} [@@deriving sexp, yojson] - -(** Represents a text channel in a guild. *) -type guild_text = { - id: Channel_id_t.t; - last_message_id: Message_id.t option; - last_pin_timestamp: string option; - category_id: Channel_id_t.t option; - guild_id: Guild_id_t.t option; - name: string; - position: int; - topic: string option; - nsfw: bool; - slow_mode_timeout: int option; -} [@@deriving sexp, yojson] - -(** Represents a voice channel in a guild. *) -type guild_voice = { - id: Channel_id_t.t; - category_id: Channel_id_t.t option; - guild_id: Guild_id_t.t option; - name: string; - position: int; - user_limit: int; - bitrate: int option; -} [@@deriving sexp, yojson] - -(** Represents a guild category. *) -type category = { - id: Channel_id_t.t; - guild_id: Guild_id_t.t option; - position: int; - name: string; -} [@@deriving sexp, yojson] - -(** Wrapper variant for all channel types. *) -type t = -| Group of group -| Private of dm -| GuildText of guild_text -| GuildVoice of guild_voice -| Category of category -[@@deriving sexp, yojson] - -(** Intermediate used internally. *) -type channel_wrapper = { - id: Channel_id_t.t; - kind: int; - guild_id: Guild_id_t.t option; - position: int option; - name: string option; - topic: string option; - nsfw: bool option; - last_message_id: Message_id.t option; - bitrate: int option; - user_limit: int option; - slow_mode_timeout: int option; - recipients: User_t.t list option; - icon: string option; - owner_id: User_id_t.t option; - application_id: Snowflake.t option; - category_id: Channel_id_t.t option; - last_pin_timestamp: string option; -} [@@deriving sexp, yojson] - -val unwrap_as_guild_text : channel_wrapper -> guild_text - -val unwrap_as_guild_voice : channel_wrapper -> guild_voice - -val unwrap_as_dm : channel_wrapper -> dm - -val unwrap_as_group : channel_wrapper -> group - -val unwrap_as_category : channel_wrapper -> category - -val wrap : channel_wrapper -> t - +exception Invalid_channel of Yojson.Safe.json
+
+(** Represents a Group channel object. *)
+type group = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option;
+ last_pin_timestamp: string option;
+ icon: string option;
+ name: string option;
+ owner_id: User_id_t.t;
+ recipients: User_t.t list;
+} [@@deriving sexp, yojson]
+
+(** Represents a private channel with a single user. *)
+type dm = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option;
+ last_pin_timestamp: string option;
+} [@@deriving sexp, yojson]
+
+(** Represents a text channel in a guild. *)
+type guild_text = {
+ id: Channel_id_t.t;
+ last_message_id: Message_id.t option;
+ last_pin_timestamp: string option;
+ category_id: Channel_id_t.t option;
+ guild_id: Guild_id_t.t option;
+ name: string;
+ position: int;
+ topic: string option;
+ nsfw: bool;
+ slow_mode_timeout: int option;
+} [@@deriving sexp, yojson]
+
+(** Represents a voice channel in a guild. *)
+type guild_voice = {
+ id: Channel_id_t.t;
+ category_id: Channel_id_t.t option;
+ guild_id: Guild_id_t.t option;
+ name: string;
+ position: int;
+ user_limit: int;
+ bitrate: int option;
+} [@@deriving sexp, yojson]
+
+(** Represents a guild category. *)
+type category = {
+ id: Channel_id_t.t;
+ guild_id: Guild_id_t.t option;
+ position: int;
+ name: string;
+} [@@deriving sexp, yojson]
+
+(** Wrapper variant for all channel types. *)
+type t =
+| Group of group
+| Private of dm
+| GuildText of guild_text
+| GuildVoice of guild_voice
+| Category of category
+[@@deriving sexp, yojson]
+
+(** Intermediate used internally. *)
+type channel_wrapper = {
+ id: Channel_id_t.t;
+ kind: int;
+ guild_id: Guild_id_t.t option;
+ position: int option;
+ name: string option;
+ topic: string option;
+ nsfw: bool option;
+ last_message_id: Message_id.t option;
+ bitrate: int option;
+ user_limit: int option;
+ slow_mode_timeout: int option;
+ recipients: User_t.t list option;
+ icon: string option;
+ owner_id: User_id_t.t option;
+ application_id: Snowflake.t option;
+ category_id: Channel_id_t.t option;
+ last_pin_timestamp: string option;
+} [@@deriving sexp, yojson]
+
+val unwrap_as_guild_text : channel_wrapper -> guild_text
+
+val unwrap_as_guild_voice : channel_wrapper -> guild_voice
+
+val unwrap_as_dm : channel_wrapper -> dm
+
+val unwrap_as_group : channel_wrapper -> group
+
+val unwrap_as_category : channel_wrapper -> category
+
+val wrap : channel_wrapper -> t
+
val get_id : t -> Snowflake.t
\ No newline at end of file diff --git a/lib/models/channel/message/attachment.mli b/lib/models/channel/message/attachment.mli index 2780011..f935471 100644 --- a/lib/models/channel/message/attachment.mli +++ b/lib/models/channel/message/attachment.mli @@ -1,9 +1,9 @@ -type t = { - id: Snowflake.t; - filename: string; - size: int; - url: string; - proxy_url: string; - height: int; - width: int; +type t = {
+ id: Snowflake.t;
+ filename: string;
+ size: int;
+ url: string;
+ proxy_url: string;
+ height: int;
+ width: int;
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/channel/message/embed.ml b/lib/models/channel/message/embed.ml index 9f9aacd..584d3c7 100644 --- a/lib/models/channel/message/embed.ml +++ b/lib/models/channel/message/embed.ml @@ -1,121 +1,121 @@ -open Core - -type footer = { - text: string; - icon_url: string option [@default None]; - proxy_icon_url: string option [@default None]; -} [@@deriving sexp, yojson] - -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] - -type video = { - url: string option [@default None]; - height: int option [@default None]; - width: int option [@default None]; -} [@@deriving sexp, yojson] - -type provider = { - name: string option [@default None]; - url: string option [@default None]; -} [@@deriving sexp, yojson] - -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] - -type field = { - name: string; - value: string; - inline: bool [@default false]; -} [@@deriving sexp, yojson] - -type t = { - title: string option [@default None]; - kind: string option [@default None][@key "type"]; - description: string option [@default None]; - url: string option [@default None]; - timestamp: string option [@default None]; - colour: int option [@default None][@key "color"]; - footer: footer option [@default None]; - image: image option [@default None]; - thumbnail: image option [@default None]; - video: video option [@default None]; - provider: provider option [@default None]; - author: author option [@default None]; - fields: field list [@default []]; -} [@@deriving sexp, yojson { strict = false }] - -let default = { - title = None; - kind = None; - description = None; - url = None; - timestamp = None; - colour = None; - footer = None; - image = None; - thumbnail = None; - video = None; - provider = None; - author = None; - fields = []; -} - -let default_footer = { - text = ""; - icon_url = None; - proxy_icon_url = None; -} - -let default_image = { - url = None; - proxy_url = None; - height = None; - width = None; -} - -let default_video = { - url = None; - width = None; - height = None; -} - -let default_provider = { - name = None; - url = None; -} - -let default_author = { - name = None; - url = None; - icon_url = None; - proxy_icon_url = None; -} - -let title v e = { e with title = Some v } -let description v e = { e with description = Some v } -let url v e = { e with url = Some v } -let timestamp v e = { e with timestamp = Some v } -let colour v e = { e with colour = Some v } -let color v e = { e with colour = Some v } -let footer f e = { e with footer = Some (f default_footer) } -let image v e = { e with image = Some { default_image with url = Some v } } -let thumbnail v e = { e with thumbnail = Some { default_image with url = Some v } } -let author f e = { e with author = Some (f default_author) } -let field (name, value, inline) e = { e with fields = { name; value; inline; }::e.fields } -let fields l e = { e with fields = List.map ~f:(fun (name, value, inline) -> { name; value; inline; }) l } - -let footer_text v f : footer = { f with text = v } -let footer_icon v f : footer = { f with icon_url = Some v } - -let author_name v a : author = { a with name = Some v } -let author_url v a : author = { a with url = Some v } +open Core
+
+type footer = {
+ text: string;
+ icon_url: string option [@default None];
+ proxy_icon_url: string option [@default None];
+} [@@deriving sexp, yojson]
+
+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]
+
+type video = {
+ url: string option [@default None];
+ height: int option [@default None];
+ width: int option [@default None];
+} [@@deriving sexp, yojson]
+
+type provider = {
+ name: string option [@default None];
+ url: string option [@default None];
+} [@@deriving sexp, yojson]
+
+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]
+
+type field = {
+ name: string;
+ value: string;
+ inline: bool [@default false];
+} [@@deriving sexp, yojson]
+
+type t = {
+ title: string option [@default None];
+ kind: string option [@default None][@key "type"];
+ description: string option [@default None];
+ url: string option [@default None];
+ timestamp: string option [@default None];
+ colour: int option [@default None][@key "color"];
+ footer: footer option [@default None];
+ image: image option [@default None];
+ thumbnail: image option [@default None];
+ video: video option [@default None];
+ provider: provider option [@default None];
+ author: author option [@default None];
+ fields: field list [@default []];
+} [@@deriving sexp, yojson { strict = false }]
+
+let default = {
+ title = None;
+ kind = None;
+ description = None;
+ url = None;
+ timestamp = None;
+ colour = None;
+ footer = None;
+ image = None;
+ thumbnail = None;
+ video = None;
+ provider = None;
+ author = None;
+ fields = [];
+}
+
+let default_footer = {
+ text = "";
+ icon_url = None;
+ proxy_icon_url = None;
+}
+
+let default_image = {
+ url = None;
+ proxy_url = None;
+ height = None;
+ width = None;
+}
+
+let default_video = {
+ url = None;
+ width = None;
+ height = None;
+}
+
+let default_provider = {
+ name = None;
+ url = None;
+}
+
+let default_author = {
+ name = None;
+ url = None;
+ icon_url = None;
+ proxy_icon_url = None;
+}
+
+let title v e = { e with title = Some v }
+let description v e = { e with description = Some v }
+let url v e = { e with url = Some v }
+let timestamp v e = { e with timestamp = Some v }
+let colour v e = { e with colour = Some v }
+let color v e = { e with colour = Some v }
+let footer f e = { e with footer = Some (f default_footer) }
+let image v e = { e with image = Some { default_image with url = Some v } }
+let thumbnail v e = { e with thumbnail = Some { default_image with url = Some v } }
+let author f e = { e with author = Some (f default_author) }
+let field (name, value, inline) e = { e with fields = { name; value; inline; }::e.fields }
+let fields l e = { e with fields = List.map ~f:(fun (name, value, inline) -> { name; value; inline; }) l }
+
+let footer_text v f : footer = { f with text = v }
+let footer_icon v f : footer = { f with icon_url = Some v }
+
+let author_name v a : author = { a with name = Some v }
+let author_url v a : author = { a with url = Some v }
let author_icon v a : author = { a with icon_url = Some v }
\ No newline at end of file diff --git a/lib/models/channel/message/embed.mli b/lib/models/channel/message/embed.mli index 411d8cc..d30d015 100644 --- a/lib/models/channel/message/embed.mli +++ b/lib/models/channel/message/embed.mli @@ -1,128 +1,128 @@ -(** A footer object belonging to an embed. *) -type footer = { - text: string; - icon_url: string option; - proxy_icon_url: string option; -} [@@deriving sexp, yojson] - -(** An image object belonging to an embed. *) -type image = { - url: string option; - proxy_url: string option; - height: int option; - width: int option; -} [@@deriving sexp, yojson] - -(** A video object belonging to an embed. *) -type video = { - url: string option; - height: int option; - width: int option; -} [@@deriving sexp, yojson] - -(** A provider object belonging to an embed. *) -type provider = { - name: string option; - url: string option; -} [@@deriving sexp, yojson] - -(** An author object belonging to an embed. *) -type author = { - name: string option; - url: string option; - icon_url: string option; - proxy_icon_url: string option; -} [@@deriving sexp, yojson] - -(** A field object belonging to an embed. *) -type field = { - name: string; - value: string; - inline: bool; -} [@@deriving sexp, yojson] - -(** An embed object. See this {{:https://leovoel.github.io/embed-visualizer/}embed visualiser} if you need help understanding each component. *) -type t = { - title: string option; - kind: string option[@key "type"]; - description: string option; - url: string option; - timestamp: string option; - colour: int option[@key "color"]; - footer: footer option; - image: image option; - thumbnail: image option; - video: video option; - provider: provider option; - author: author option; - fields: field list [@default []]; -} [@@deriving sexp, yojson { strict = false }] - -(** An embed where all values are empty. *) -val default : t - -(** A footer where all values are empty. *) -val default_footer : footer - -(** An image where all values are empty. *) -val default_image : image - -(** A video where all values are empty. *) -val default_video : video - -(** A provider where all values are empty. *) -val default_provider : provider - -(** An author where all values are empty. *) -val default_author : author - -(** Set the title of an embed. *) -val title : string -> t -> t - -(** Set the description of an embed. *) -val description : string -> t -> t - -(** Set the URL of an embed. *) -val url : string -> t -> t - -(** Set the timestamp of an embed. *) -val timestamp : string -> t -> t - -(** Set the colour of an embed. *) -val colour : int -> t -> t - -(** Identical to {!colour} but with US English spelling. *) -val color : int -> t -> t - -(** Set the footer of an embed. The function passes {!default_footer} and must return a footer. *) -val footer : (footer -> footer) -> t -> t - -(** Set the image URL of an embed. *) -val image : string -> t -> t - -(** Set the thumbnail URL of an embed. *) -val thumbnail : string -> t -> t - -(** Set the author of an embed. The function passes {!default_author} and must return an author. *) -val author : (author -> author) -> t -> t - -(** Add a field to an embed. Takes a tuple in [(name, value, inline)] order. {b Fields added this way will appear in reverse order in the embed.} *) -val field : string * string * bool -> t -> t - -(** Set the fields of an embed. Similar to {!val:field}, but because a complete list is passed, fields preserve order. *) -val fields : (string * string * bool) list -> t -> t - -(** Set the footer text. Typically used in the closure passed to {!val:footer}. *) -val footer_text : string -> footer -> footer - -(** Set the footer icon URL. Typically used in the closure passed to {!val:footer}. *) -val footer_icon : string -> footer -> footer - -(** Set the author name. Typically used in the closure passed to {!val:author}. *) -val author_name : string -> author -> author - -(** Set the author URL. Typically used in the closure passed to {!val:author}. *) -val author_url : string -> author -> author - -(** Set the author icon URL. Typically used in the closure passed to {!val:author}. *) +(** A footer object belonging to an embed. *)
+type footer = {
+ text: string;
+ icon_url: string option;
+ proxy_icon_url: string option;
+} [@@deriving sexp, yojson]
+
+(** An image object belonging to an embed. *)
+type image = {
+ url: string option;
+ proxy_url: string option;
+ height: int option;
+ width: int option;
+} [@@deriving sexp, yojson]
+
+(** A video object belonging to an embed. *)
+type video = {
+ url: string option;
+ height: int option;
+ width: int option;
+} [@@deriving sexp, yojson]
+
+(** A provider object belonging to an embed. *)
+type provider = {
+ name: string option;
+ url: string option;
+} [@@deriving sexp, yojson]
+
+(** An author object belonging to an embed. *)
+type author = {
+ name: string option;
+ url: string option;
+ icon_url: string option;
+ proxy_icon_url: string option;
+} [@@deriving sexp, yojson]
+
+(** A field object belonging to an embed. *)
+type field = {
+ name: string;
+ value: string;
+ inline: bool;
+} [@@deriving sexp, yojson]
+
+(** An embed object. See this {{:https://leovoel.github.io/embed-visualizer/}embed visualiser} if you need help understanding each component. *)
+type t = {
+ title: string option;
+ kind: string option[@key "type"];
+ description: string option;
+ url: string option;
+ timestamp: string option;
+ colour: int option[@key "color"];
+ footer: footer option;
+ image: image option;
+ thumbnail: image option;
+ video: video option;
+ provider: provider option;
+ author: author option;
+ fields: field list [@default []];
+} [@@deriving sexp, yojson { strict = false }]
+
+(** An embed where all values are empty. *)
+val default : t
+
+(** A footer where all values are empty. *)
+val default_footer : footer
+
+(** An image where all values are empty. *)
+val default_image : image
+
+(** A video where all values are empty. *)
+val default_video : video
+
+(** A provider where all values are empty. *)
+val default_provider : provider
+
+(** An author where all values are empty. *)
+val default_author : author
+
+(** Set the title of an embed. *)
+val title : string -> t -> t
+
+(** Set the description of an embed. *)
+val description : string -> t -> t
+
+(** Set the URL of an embed. *)
+val url : string -> t -> t
+
+(** Set the timestamp of an embed. *)
+val timestamp : string -> t -> t
+
+(** Set the colour of an embed. *)
+val colour : int -> t -> t
+
+(** Identical to {!colour} but with US English spelling. *)
+val color : int -> t -> t
+
+(** Set the footer of an embed. The function passes {!default_footer} and must return a footer. *)
+val footer : (footer -> footer) -> t -> t
+
+(** Set the image URL of an embed. *)
+val image : string -> t -> t
+
+(** Set the thumbnail URL of an embed. *)
+val thumbnail : string -> t -> t
+
+(** Set the author of an embed. The function passes {!default_author} and must return an author. *)
+val author : (author -> author) -> t -> t
+
+(** Add a field to an embed. Takes a tuple in [(name, value, inline)] order. {b Fields added this way will appear in reverse order in the embed.} *)
+val field : string * string * bool -> t -> t
+
+(** Set the fields of an embed. Similar to {!val:field}, but because a complete list is passed, fields preserve order. *)
+val fields : (string * string * bool) list -> t -> t
+
+(** Set the footer text. Typically used in the closure passed to {!val:footer}. *)
+val footer_text : string -> footer -> footer
+
+(** Set the footer icon URL. Typically used in the closure passed to {!val:footer}. *)
+val footer_icon : string -> footer -> footer
+
+(** Set the author name. Typically used in the closure passed to {!val:author}. *)
+val author_name : string -> author -> author
+
+(** Set the author URL. Typically used in the closure passed to {!val:author}. *)
+val author_url : string -> author -> author
+
+(** Set the author icon URL. Typically used in the closure passed to {!val:author}. *)
val author_icon : string -> author -> author
\ No newline at end of file diff --git a/lib/models/channel/message/message.ml b/lib/models/channel/message/message.ml index a64c09d..43929d2 100644 --- a/lib/models/channel/message/message.ml +++ b/lib/models/channel/message/message.ml @@ -1,67 +1,67 @@ -open Async -include Message_t - -let add_reaction msg (emoji:Emoji.t) = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - let e = match emoji.id with - | Some i -> Printf.sprintf "%s:%d" emoji.name i - | None -> emoji.name - in - Http.create_reaction channel_id id e - - -let remove_reaction msg (emoji:Emoji.t) (user:User_t.t) = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - let `User_id user_id = user.id in - let e = match emoji.id with - | Some i -> Printf.sprintf "%s:%d" emoji.name i - | None -> emoji.name - in - Http.delete_reaction channel_id id e user_id - - -let clear_reactions msg = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - Http.delete_reactions channel_id id - - -let delete msg = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - Http.delete_message channel_id id - - -let pin msg = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - Http.pin_message channel_id id - - -let unpin msg = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - Http.unpin_message channel_id id - - -let reply msg content = - Channel_id.say content msg.channel_id - -let reply_with ?embed ?content ?file ?tts msg = - Channel_id.send_message ?embed ?content ?file ?tts msg.channel_id - -let set_content msg cont = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - to_yojson { msg with content = cont; } - |> Http.edit_message channel_id id - - -let set_embed msg embed = - let `Message_id id = msg.id in - let `Channel_id channel_id = msg.channel_id in - to_yojson { msg with embeds = [embed]; } - |> Http.edit_message channel_id id +open Async
+include Message_t
+
+let add_reaction msg (emoji:Emoji.t) =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ let e = match emoji.id with
+ | Some i -> Printf.sprintf "%s:%d" emoji.name i
+ | None -> emoji.name
+ in
+ Http.create_reaction channel_id id e
+
+
+let remove_reaction msg (emoji:Emoji.t) (user:User_t.t) =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ let `User_id user_id = user.id in
+ let e = match emoji.id with
+ | Some i -> Printf.sprintf "%s:%d" emoji.name i
+ | None -> emoji.name
+ in
+ Http.delete_reaction channel_id id e user_id
+
+
+let clear_reactions msg =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ Http.delete_reactions channel_id id
+
+
+let delete msg =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ Http.delete_message channel_id id
+
+
+let pin msg =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ Http.pin_message channel_id id
+
+
+let unpin msg =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ Http.unpin_message channel_id id
+
+
+let reply msg content =
+ Channel_id.say content msg.channel_id
+
+let reply_with ?embed ?content ?file ?tts msg =
+ Channel_id.send_message ?embed ?content ?file ?tts msg.channel_id
+
+let set_content msg cont =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ to_yojson { msg with content = cont; }
+ |> Http.edit_message channel_id id
+
+
+let set_embed msg embed =
+ let `Message_id id = msg.id in
+ let `Channel_id channel_id = msg.channel_id in
+ to_yojson { msg with embeds = [embed]; }
+ |> Http.edit_message channel_id id
\ No newline at end of file diff --git a/lib/models/channel/message/message.mli b/lib/models/channel/message/message.mli index 09e62a4..56e1c98 100644 --- a/lib/models/channel/message/message.mli +++ b/lib/models/channel/message/message.mli @@ -1,20 +1,39 @@ -open Async - -include module type of Message_t - -val add_reaction : t -> Emoji.t -> unit Deferred.Or_error.t -val remove_reaction : t -> Emoji.t -> User_t.t -> unit Deferred.Or_error.t -val clear_reactions : t -> unit Deferred.Or_error.t -val delete : t -> unit Deferred.Or_error.t -val pin : t -> unit Deferred.Or_error.t -val unpin : t -> unit Deferred.Or_error.t -val reply : t -> string -> t Deferred.Or_error.t -val reply_with : - ?embed:Embed.t -> - ?content:string -> - ?file:string -> - ?tts:bool -> - t -> - Message_t.t Deferred.Or_error.t -val set_content : t -> string -> t Deferred.Or_error.t +open Async
+
+include module type of Message_t
+
+(** Add the given emoji as a reaction. *)
+val add_reaction : t -> Emoji.t -> unit Deferred.Or_error.t
+
+(** Remove the reaction. Must also specify the user. *)
+val remove_reaction : t -> Emoji.t -> User_t.t -> unit Deferred.Or_error.t
+
+(** Remove all reactions from the message. *)
+val clear_reactions : t -> unit Deferred.Or_error.t
+
+(** Delete the message. *)
+val delete : t -> unit Deferred.Or_error.t
+
+(** Pin the message. *)
+val pin : t -> unit Deferred.Or_error.t
+
+(** Unping the message. *)
+val unpin : t -> unit Deferred.Or_error.t
+
+(** Sugar for [Channel_id.say msg.channel_id content]. *)
+val reply : t -> string -> t Deferred.Or_error.t
+
+(** Sugar for [Channel_id.send_message ?embed ?content ?file ?tts msg.channel_id]. *)
+val reply_with :
+ ?embed:Embed.t ->
+ ?content:string ->
+ ?file:string ->
+ ?tts:bool ->
+ t ->
+ Message_t.t Deferred.Or_error.t
+
+(** Set the content of the message. *)
+val set_content : t -> string -> t Deferred.Or_error.t
+
+(** Set the embed of the message. *)
val set_embed : t -> Embed.t -> t Deferred.Or_error.t
\ No newline at end of file diff --git a/lib/models/channel/message/message_t.ml b/lib/models/channel/message/message_t.ml index 3c2e736..fc678f6 100644 --- a/lib/models/channel/message/message_t.ml +++ b/lib/models/channel/message/message_t.ml @@ -1,23 +1,23 @@ -open Core - -type t = { - id: Message_id.t; - author: User_t.t; - channel_id: Channel_id_t.t; - member: Member_t.partial_member option [@default None]; - guild_id: Guild_id_t.t option [@default None]; - content: string; - timestamp: string; - edited_timestamp: string option [@default None]; - tts: bool; - mention_everyone: bool; - mentions: User_t.t list [@default []]; - mention_roles: Role_id.t list [@default []]; - attachments: Attachment.t list [@default []]; - embeds: Embed.t list [@default []]; - reactions: Snowflake.t list [@default []]; - nonce: Snowflake.t option [@default None]; - pinned: bool; - webhook_id: Snowflake.t option [@default None]; - kind: int [@key "type"]; +open Core
+
+type t = {
+ id: Message_id.t;
+ author: User_t.t;
+ channel_id: Channel_id_t.t;
+ member: Member_t.partial_member option [@default None];
+ guild_id: Guild_id_t.t option [@default None];
+ content: string;
+ timestamp: string;
+ edited_timestamp: string option [@default None];
+ tts: bool;
+ mention_everyone: bool;
+ mentions: User_t.t list [@default []];
+ mention_roles: Role_id.t list [@default []];
+ attachments: Attachment.t list [@default []];
+ embeds: Embed.t list [@default []];
+ reactions: Snowflake.t list [@default []];
+ nonce: Snowflake.t option [@default None];
+ pinned: bool;
+ webhook_id: Snowflake.t option [@default None];
+ kind: int [@key "type"];
} [@@deriving sexp, yojson { strict = false}]
\ No newline at end of file diff --git a/lib/models/channel/message/message_t.mli b/lib/models/channel/message/message_t.mli index 1f691b5..de56655 100644 --- a/lib/models/channel/message/message_t.mli +++ b/lib/models/channel/message/message_t.mli @@ -1,22 +1,22 @@ -(** Represents a message object. *) -type t = { - id: Message_id.t; - author: User_t.t; - channel_id: Channel_id_t.t; - member: Member_t.partial_member option; - guild_id: Guild_id_t.t option; - content: string; - timestamp: string; - edited_timestamp: string option; - tts: bool; - mention_everyone: bool; - mentions: User_t.t list; - mention_roles: Role_id.t list; - attachments: Attachment.t list; - embeds: Embed.t list; - reactions: Snowflake.t list; - nonce: Snowflake.t option; - pinned: bool; - webhook_id: Snowflake.t option; - kind: int; +(** Represents a message object. *)
+type t = {
+ id: Message_id.t; (** Snowflake ID of the message. *)
+ author: User_t.t; (** User that authored the message. *)
+ channel_id: Channel_id_t.t; (** Channel ID the message exists in. *)
+ member: Member_t.partial_member option; (** A partial member if the message was sent in a guild. *)
+ guild_id: Guild_id_t.t option; (** Guild ID if the message was sent in a guild. *)
+ content: string; (** Content of the message. *)
+ timestamp: string; (** ISO8601 timestamp of when the message was created. *)
+ edited_timestamp: string option; (** Like timestamp, but for last edit, if any. *)
+ tts: bool; (** Whether the message used text-to-speech. *)
+ mention_everyone: bool; (** Whether the message mentioned [@everyone] or [@here] *)
+ mentions: User_t.t list; (** A List of users that were mentioned in the message. *)
+ mention_roles: Role_id.t list; (** A list of roles that were mentioned in the message. *)
+ attachments: Attachment.t list; (** A list of attachments. *)
+ embeds: Embed.t list; (** A List of embeds on the message. *)
+ reactions: Snowflake.t list; (** A list of reactions. *)
+ nonce: Snowflake.t option; (** Used in verification, safe to ignore. *)
+ pinned: bool; (** Whether the message is pinned. *)
+ webhook_id: Snowflake.t option; (** The webhook ID, if the message was sent by a webhook. *)
+ kind: int; (** See {{:https://discordapp.com/developers/docs/resources/channel#message-object-message-types}the discord docs} for message type enumeration. *)
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/channel/message/reaction_t.ml b/lib/models/channel/message/reaction_t.ml index 1aa3c84..7c78baf 100644 --- a/lib/models/channel/message/reaction_t.ml +++ b/lib/models/channel/message/reaction_t.ml @@ -1,14 +1,14 @@ -open Core - -type reaction_event = { - user_id: User_id_t.t; - channel_id: Channel_id_t.t; - message_id: Message_id.t; - guild_id: Guild_id_t.t option [@default None]; - emoji: Emoji.partial_emoji; -} [@@deriving sexp, yojson] - -type t = { - count: int; - emoji: Emoji.t; +open Core
+
+type reaction_event = {
+ user_id: User_id_t.t;
+ channel_id: Channel_id_t.t;
+ message_id: Message_id.t;
+ guild_id: Guild_id_t.t option [@default None];
+ emoji: Emoji.partial_emoji;
+} [@@deriving sexp, yojson]
+
+type t = {
+ count: int;
+ emoji: Emoji.t;
} [@@deriving sexp, yojson { strict = false}]
\ No newline at end of file diff --git a/lib/models/channel/message/reaction_t.mli b/lib/models/channel/message/reaction_t.mli index 6c2782a..ace8f55 100644 --- a/lib/models/channel/message/reaction_t.mli +++ b/lib/models/channel/message/reaction_t.mli @@ -1,14 +1,14 @@ -(** Represents a single reaction as received over the gateway. *) -type reaction_event = { - user_id: User_id_t.t; - channel_id: Channel_id_t.t; - message_id: Message_id.t; - guild_id: Guild_id_t.t option; - emoji: Emoji.partial_emoji; -} [@@deriving sexp, yojson] - -(** Represents a number of emojis used as a reaction on a message. *) -type t = { - count: int; - emoji: Emoji.t; +(** Represents a single reaction as received over the gateway. *)
+type reaction_event = {
+ user_id: User_id_t.t;
+ channel_id: Channel_id_t.t;
+ message_id: Message_id.t;
+ guild_id: Guild_id_t.t option;
+ emoji: Emoji.partial_emoji;
+} [@@deriving sexp, yojson]
+
+(** Represents a number of emojis used as a reaction on a message. *)
+type t = {
+ count: int;
+ emoji: Emoji.t;
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/emoji.ml b/lib/models/emoji.ml index 4d33615..63318a5 100644 --- a/lib/models/emoji.ml +++ b/lib/models/emoji.ml @@ -1,16 +1,16 @@ -open Core - -type partial_emoji = { - id: Snowflake.t option [@default None]; - name: string; -} [@@deriving sexp, yojson { strict = false }] - -type t = { - id: Snowflake.t option [@default None]; - name: string; - roles: Role_id.t list [@default []]; - user: User_t.t option [@default None]; - require_colons: bool [@default false]; - managed: bool [@default false]; - animated: bool [@default false]; +open Core
+
+type partial_emoji = {
+ id: Snowflake.t option [@default None];
+ name: string;
+} [@@deriving sexp, yojson { strict = false }]
+
+type t = {
+ id: Snowflake.t option [@default None];
+ name: string;
+ roles: Role_id.t list [@default []];
+ user: User_t.t option [@default None];
+ require_colons: bool [@default false];
+ managed: bool [@default false];
+ animated: bool [@default false];
} [@@deriving sexp, yojson { strict = false}]
\ No newline at end of file diff --git a/lib/models/emoji.mli b/lib/models/emoji.mli index 1660719..c159a0e 100644 --- a/lib/models/emoji.mli +++ b/lib/models/emoji.mli @@ -1,16 +1,16 @@ -(** A partial emoji, used internally. *) -type partial_emoji = { - id: Snowflake.t option; - name: string; -} [@@deriving sexp, yojson] - -(** A full emoji object. *) -type t = { - id: Snowflake.t option; (** Snowflake ID of the emoji. Only exists for custom emojis. *) - name: string; (** Name of the emoji. Either the emoji custom name or a unicode character. *) - roles: Role_id.t list; (** List of roles required to use this emoji. Is only non-empty on some integration emojis. *) - user: User_t.t option; (** User object of the person who uploaded the emoji. Only exists for custom emojis. *) - require_colons: bool; (** Whether the emoji must be wrapped in colons. Is false for unicode emojis. *) - managed: bool; (** Whether the emoji is managed by an integration. *) - animated: bool; (** Whether the emoji is animated. *) +(** A partial emoji, used internally. *)
+type partial_emoji = {
+ id: Snowflake.t option;
+ name: string;
+} [@@deriving sexp, yojson]
+
+(** A full emoji object. *)
+type t = {
+ id: Snowflake.t option; (** Snowflake ID of the emoji. Only exists for custom emojis. *)
+ name: string; (** Name of the emoji. Either the emoji custom name or a unicode character. *)
+ roles: Role_id.t list; (** List of roles required to use this emoji. Is only non-empty on some integration emojis. *)
+ user: User_t.t option; (** User object of the person who uploaded the emoji. Only exists for custom emojis. *)
+ require_colons: bool; (** Whether the emoji must be wrapped in colons. Is false for unicode emojis. *)
+ managed: bool; (** Whether the emoji is managed by an integration. *)
+ animated: bool; (** Whether the emoji is animated. *)
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/event_models.ml b/lib/models/event_models.ml index 3cb2aa3..b5eb80d 100644 --- a/lib/models/event_models.ml +++ b/lib/models/event_models.ml @@ -1,371 +1,371 @@ -open Core - -module ChannelCreate = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] - - let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } -end - -module ChannelDelete = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] - - let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } -end - -module ChannelUpdate = struct - type t = { - channel: Channel_t.t; - } [@@deriving sexp] - - let deserialize ev = - let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in - { channel; } -end - -module ChannelPinsUpdate = struct - type t = { - channel_id: Channel_id.t; - last_pin_timestamp: string option [@default None]; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module ChannelRecipientAdd = struct - type t = { - channel_id: Channel_id.t; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module ChannelRecipientRemove = struct - type t = { - channel_id: Channel_id.t; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildBanAdd = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildBanRemove = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildCreate = struct - type t = { - guild: Guild_t.t; - } [@@deriving sexp] - - let deserialize ev = - let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in - { guild; } -end - -module GuildDelete = struct - type t = { - id: Guild_id.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildUpdate = struct - type t = { - guild: Guild_t.t; - } [@@deriving sexp] - - let deserialize ev = - let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in - { guild; } -end - -module GuildEmojisUpdate = struct - type t = { - emojis: Emoji.t list; - guild_id: Guild_id.t - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -(* TODO guild integrations *) - -module GuildMemberAdd = struct - include Member_t - - let deserialize = of_yojson_exn -end - -module GuildMemberRemove = struct - type t = { - guild_id: Guild_id.t; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildMemberUpdate = struct - type t = { - guild_id: Guild_id.t; - nick: string option; - roles: Role_id.t list; - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildMembersChunk = struct - type t = { - guild_id: Guild_id.t; - members: (Snowflake.t * Member_t.t) list; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildRoleCreate = struct - type t = { - guild_id: Guild_id.t; - role: Role_t.role; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildRoleDelete = struct - type t = { - guild_id: Guild_id.t; - role_id: Role_id.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module GuildRoleUpdate = struct - type t = { - guild_id: Guild_id.t; - role: Role_t.role; - } [@@deriving sexp, yojson { strict = false }] - - 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 }] - - let deserialize = of_yojson_exn -end - -module MessageCreate = struct - type t = { - message: Message_t.t; - } [@@deriving sexp] - - let deserialize ev = - let message = Message_t.of_yojson_exn ev in - { message; } -end - -module MessageDelete = struct - type t = { - id: Message_id.t; - channel_id: Channel_id.t; - guild_id: Guild_id.t option [@default None]; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -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_id.t list [@default []]; - role_mentions: Role_id.t list [@default []]; - attachments: Attachment.t list [@default []]; - embeds: Embed.t list [@default []]; - reactions: Snowflake.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}] - - let deserialize = of_yojson_exn -end - -module MessageDeleteBulk = struct - 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 }] - - let deserialize = of_yojson_exn -end - -module PresenceUpdate = struct - include Presence - - let deserialize = of_yojson_exn -end - -(* module PresencesReplace = struct - type t = - - let deserialize = of_yojson_exn -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; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -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; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module ReactionRemoveAll = struct - 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 }] - - let deserialize = of_yojson_exn -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; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module Resumed = struct - type t = { - trace: string option list [@key "_trace"]; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -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; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module UserUpdate = struct - type t = { - user: User_t.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize ev = - let user = User_t.of_yojson_exn ev in - { user; } -end - -module WebhookUpdate = struct - type t = { - channel_id: Channel_id.t; - guild_id: Guild_id.t; - } [@@deriving sexp, yojson { strict = false }] - - let deserialize = of_yojson_exn -end - -module Unknown = struct - type t = { - kind: string; - value: Yojson.Safe.json; - } - - let deserialize kind value = { kind; value; } -end - -(* module VoiceHeartbeat = struct - -end - -module VoiceHello = struct - -end - -module VoiceServerUpdate = struct - -end - -module VoiceSessionDescription = struct - -end - -module VoiceSpeaking = struct - -end - -module VoiceStateUpdate = struct - +open Core
+
+module ChannelCreate = struct
+ type t = {
+ channel: Channel_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in
+ { channel; }
+end
+
+module ChannelDelete = struct
+ type t = {
+ channel: Channel_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in
+ { channel; }
+end
+
+module ChannelUpdate = struct
+ type t = {
+ channel: Channel_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let channel = Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap) in
+ { channel; }
+end
+
+module ChannelPinsUpdate = struct
+ type t = {
+ channel_id: Channel_id.t;
+ last_pin_timestamp: string option [@default None];
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module ChannelRecipientAdd = struct
+ type t = {
+ channel_id: Channel_id.t;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module ChannelRecipientRemove = struct
+ type t = {
+ channel_id: Channel_id.t;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildBanAdd = struct
+ type t = {
+ guild_id: Guild_id.t;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildBanRemove = struct
+ type t = {
+ guild_id: Guild_id.t;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildCreate = struct
+ type t = {
+ guild: Guild_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in
+ { guild; }
+end
+
+module GuildDelete = struct
+ type t = {
+ id: Guild_id.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildUpdate = struct
+ type t = {
+ guild: Guild_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let guild = Guild_t.(pre_of_yojson_exn ev |> wrap) in
+ { guild; }
+end
+
+module GuildEmojisUpdate = struct
+ type t = {
+ emojis: Emoji.t list;
+ guild_id: Guild_id.t
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+(* TODO guild integrations *)
+
+module GuildMemberAdd = struct
+ include Member_t
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildMemberRemove = struct
+ type t = {
+ guild_id: Guild_id.t;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildMemberUpdate = struct
+ type t = {
+ guild_id: Guild_id.t;
+ nick: string option;
+ roles: Role_id.t list;
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildMembersChunk = struct
+ type t = {
+ guild_id: Guild_id.t;
+ members: (Snowflake.t * Member_t.t) list;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildRoleCreate = struct
+ type t = {
+ guild_id: Guild_id.t;
+ role: Role_t.role;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildRoleDelete = struct
+ type t = {
+ guild_id: Guild_id.t;
+ role_id: Role_id.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module GuildRoleUpdate = struct
+ type t = {
+ guild_id: Guild_id.t;
+ role: Role_t.role;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ 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 }]
+
+ let deserialize = of_yojson_exn
+end
+
+module MessageCreate = struct
+ type t = {
+ message: Message_t.t;
+ } [@@deriving sexp]
+
+ let deserialize ev =
+ let message = Message_t.of_yojson_exn ev in
+ { message; }
+end
+
+module MessageDelete = struct
+ type t = {
+ id: Message_id.t;
+ channel_id: Channel_id.t;
+ guild_id: Guild_id.t option [@default None];
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+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_id.t list [@default []];
+ role_mentions: Role_id.t list [@default []];
+ attachments: Attachment.t list [@default []];
+ embeds: Embed.t list [@default []];
+ reactions: Snowflake.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}]
+
+ let deserialize = of_yojson_exn
+end
+
+module MessageDeleteBulk = struct
+ 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 }]
+
+ let deserialize = of_yojson_exn
+end
+
+module PresenceUpdate = struct
+ include Presence
+
+ let deserialize = of_yojson_exn
+end
+
+(* module PresencesReplace = struct
+ type t =
+
+ let deserialize = of_yojson_exn
+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;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+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;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module ReactionRemoveAll = struct
+ 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 }]
+
+ let deserialize = of_yojson_exn
+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;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module Resumed = struct
+ type t = {
+ trace: string option list [@key "_trace"];
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+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;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module UserUpdate = struct
+ type t = {
+ user: User_t.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize ev =
+ let user = User_t.of_yojson_exn ev in
+ { user; }
+end
+
+module WebhookUpdate = struct
+ type t = {
+ channel_id: Channel_id.t;
+ guild_id: Guild_id.t;
+ } [@@deriving sexp, yojson { strict = false }]
+
+ let deserialize = of_yojson_exn
+end
+
+module Unknown = struct
+ type t = {
+ kind: string;
+ value: Yojson.Safe.json;
+ }
+
+ let deserialize kind value = { kind; value; }
+end
+
+(* module VoiceHeartbeat = struct
+
+end
+
+module VoiceHello = struct
+
+end
+
+module VoiceServerUpdate = struct
+
+end
+
+module VoiceSessionDescription = struct
+
+end
+
+module VoiceSpeaking = struct
+
+end
+
+module VoiceStateUpdate = struct
+
end *)
\ No newline at end of file diff --git a/lib/models/guild/ban_t.mli b/lib/models/guild/ban_t.mli index 51d59e7..37e5cfa 100644 --- a/lib/models/guild/ban_t.mli +++ b/lib/models/guild/ban_t.mli @@ -1,4 +1,4 @@ -type t = { - reason: string option; (** The reason for the ban. *) - user: User_t.t; (** The banned user. *) +type t = {
+ reason: string option; (** The reason for the ban. *)
+ user: User_t.t; (** The banned user. *)
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/guild/guild.ml b/lib/models/guild/guild.ml index 812a49e..b1e8bfe 100644 --- a/lib/models/guild/guild.ml +++ b/lib/models/guild/guild.ml @@ -1,22 +1,22 @@ -open Core -open Async - -include Guild_t -include Impl.Guild(Guild_t) - -let get_member ~(id:User_id_t.t) guild = - match List.find ~f:(fun m -> m.user.id = id) guild.members with - | Some m -> Deferred.Or_error.return m - | None -> - let `User_id id = id in - Http.get_member (get_id guild) id - -let get_channel ~(id:Channel_id_t.t) guild = - let `Channel_id id = id in - match List.find ~f:(fun c -> Channel_t.get_id c = id) guild.channels with - | Some c -> Deferred.Or_error.return c - | None -> Http.get_channel id - -(* TODO add HTTP fallback *) -let get_role ~(id:Role_id.t) guild = +open Core
+open Async
+
+include Guild_t
+include Impl.Guild(Guild_t)
+
+let get_member ~(id:User_id_t.t) guild =
+ match List.find ~f:(fun m -> m.user.id = id) guild.members with
+ | Some m -> Deferred.Or_error.return m
+ | None ->
+ let `User_id id = id in
+ Http.get_member (get_id guild) id
+
+let get_channel ~(id:Channel_id_t.t) guild =
+ let `Channel_id id = id in
+ match List.find ~f:(fun c -> Channel_t.get_id c = id) guild.channels with
+ | Some c -> Deferred.Or_error.return c
+ | None -> Http.get_channel id
+
+(* TODO add HTTP fallback *)
+let get_role ~(id:Role_id.t) guild =
List.find ~f:(fun r -> r.id = id) guild.roles
\ No newline at end of file diff --git a/lib/models/guild/guild.mli b/lib/models/guild/guild.mli index e6f272c..be9300a 100644 --- a/lib/models/guild/guild.mli +++ b/lib/models/guild/guild.mli @@ -1,14 +1,14 @@ -open Async - -include module type of Guild_t -include S.GuildImpl with - type t := Guild_t.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 - -(** Get a member belonging to this guild. This does not make an HTTP request. *) -val get_member : id:User_id_t.t -> t -> Member_t.t Deferred.Or_error.t - -(** Get a role belonging to this guild. This does not make an HTTP request. *) +open Async
+
+include module type of Guild_t
+include S.GuildImpl with
+ type t := Guild_t.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
+
+(** Get a member belonging to this guild. This does not make an HTTP request. *)
+val get_member : id:User_id_t.t -> t -> Member_t.t Deferred.Or_error.t
+
+(** Get a role belonging to this guild. This does not make an HTTP request. *)
val get_role : id:Role_id.t -> t -> Role_t.t option
\ No newline at end of file diff --git a/lib/models/guild/guild_t.ml b/lib/models/guild/guild_t.ml index fa62a8f..9ad7cb9 100644 --- a/lib/models/guild/guild_t.ml +++ b/lib/models/guild/guild_t.ml @@ -1,72 +1,72 @@ -open Core - -type unavailable = { - id: Guild_id_t.t; -} [@@deriving sexp, yojson { strict = false }] - -type pre = { - id: Guild_id_t.t; - name: string; - icon: string option [@default None]; - splash: string option [@default None]; - owner_id: User_id_t.t; - region: string; - afk_channel_id: Channel_id_t.t option [@default None]; - afk_timeout: int; - embed_enabled: bool [@default false]; - embed_channel_id: Channel_id_t.t option [@default None]; - verification_level: int; - default_message_notifications: int; - explicit_content_filter: int; - roles: Role_t.role list; - emojis: Emoji.t list; - features: string list; - mfa_level: int; - application_id: Snowflake.t option [@default None]; - 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; - member_count: int option [@default None]; - members: Member_t.member list; - channels: Channel_t.channel_wrapper list; -} [@@deriving sexp, yojson { strict = false }] - -type t = { - id: Guild_id_t.t; - name: string; - icon: string option [@default None]; - splash: string option [@default None]; - owner_id: User_id_t.t; - region: string; - afk_channel_id: Channel_id_t.t option [@default None]; - afk_timeout: int; - embed_enabled: bool [@default false]; - embed_channel_id: Channel_id_t.t option [@default None]; - verification_level: int; - default_message_notifications: int; - explicit_content_filter: int; - roles: Role_t.t list; - emojis: Emoji.t list; - features: string list; - mfa_level: int; - application_id: Snowflake.t option [@default None]; - 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; - member_count: int option [@default None]; - members: Member_t.t list; - channels: Channel_t.t list; -} [@@deriving sexp, yojson { strict = false }] - -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 `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} - +open Core
+
+type unavailable = {
+ id: Guild_id_t.t;
+} [@@deriving sexp, yojson { strict = false }]
+
+type pre = {
+ id: Guild_id_t.t;
+ name: string;
+ icon: string option [@default None];
+ splash: string option [@default None];
+ owner_id: User_id_t.t;
+ region: string;
+ afk_channel_id: Channel_id_t.t option [@default None];
+ afk_timeout: int;
+ embed_enabled: bool [@default false];
+ embed_channel_id: Channel_id_t.t option [@default None];
+ verification_level: int;
+ default_message_notifications: int;
+ explicit_content_filter: int;
+ roles: Role_t.role list;
+ emojis: Emoji.t list;
+ features: string list;
+ mfa_level: int;
+ application_id: Snowflake.t option [@default None];
+ 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;
+ member_count: int option [@default None];
+ members: Member_t.member list;
+ channels: Channel_t.channel_wrapper list;
+} [@@deriving sexp, yojson { strict = false }]
+
+type t = {
+ id: Guild_id_t.t;
+ name: string;
+ icon: string option [@default None];
+ splash: string option [@default None];
+ owner_id: User_id_t.t;
+ region: string;
+ afk_channel_id: Channel_id_t.t option [@default None];
+ afk_timeout: int;
+ embed_enabled: bool [@default false];
+ embed_channel_id: Channel_id_t.t option [@default None];
+ verification_level: int;
+ default_message_notifications: int;
+ explicit_content_filter: int;
+ roles: Role_t.t list;
+ emojis: Emoji.t list;
+ features: string list;
+ mfa_level: int;
+ application_id: Snowflake.t option [@default None];
+ 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;
+ member_count: int option [@default None];
+ members: Member_t.t list;
+ channels: Channel_t.t list;
+} [@@deriving sexp, yojson { strict = false }]
+
+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 `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}
+
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 e1c0718..7296372 100644 --- a/lib/models/guild/guild_t.mli +++ b/lib/models/guild/guild_t.mli @@ -1,66 +1,66 @@ -type unavailable = { - id: Guild_id_t.t; -} [@@deriving sexp, yojson] - -(** Used internally. *) -type pre = { - id: Guild_id_t.t; - name: string; - icon: string option; - splash: string option; - owner_id: User_id_t.t; - region: string; - afk_channel_id: Channel_id_t.t option; - afk_timeout: int; - embed_enabled: bool; - embed_channel_id: Channel_id_t.t option; - verification_level: int; - default_message_notifications: int; - explicit_content_filter: int; - roles: Role_t.role list; - emojis: Emoji.t list; - features: string list; - mfa_level: int; - application_id: Snowflake.t option; - widget_enabled: bool; - 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; -} [@@deriving sexp, yojson] - -(** A Guild object *) -type t = { - id: Guild_id_t.t; (** The guild's snowflake ID. *) - name: string; (** The guild name. *) - icon: string option; (** The guild icon hash, if one is set. *) - splash: string option; (** The guild splash hash, if one is set. *) - owner_id: User_id_t.t; (** The user ID of the owner. *) - region: string; (** The region the guild is in. *) - afk_channel_id: Channel_id_t.t option; (** The AFK channel ID, if one is set. *) - afk_timeout: int; (** The time before a user is moved to the AFK channel. *) - embed_enabled: bool; (** Whether the embed is enabled. *) - embed_channel_id: Channel_id_t.t option; (** The channel ID of the embed channel, if it is enabled. *) - verification_level: int; (** See {{:https://discordapp.com/developers/docs/resources/guild#guild-object-verification-level} the discord docs} for details. *) - default_message_notifications: int; (** 0 = All messages, 1 = Only mentions *) - explicit_content_filter: int; (** 0 = Disabled, 1 = For members with no roles, 2 = All members *) - roles: Role_t.t list; (** List of roles in the guild. *) - emojis: Emoji.t list; (** List of custom emojis in the guild. *) - features: string list; (** A List of features enabled for the guild. *) - mfa_level: int; (** 0 = None, 1 = Elevated *) - application_id: Snowflake.t option; (** Snowflake ID if the guild is bot-created. *) - widget_enabled: bool; (** Whether the widget is enabled. *) - 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. *) -} [@@deriving sexp, yojson] - -val wrap : pre -> t +type unavailable = {
+ id: Guild_id_t.t;
+} [@@deriving sexp, yojson]
+
+(** Used internally. *)
+type pre = {
+ id: Guild_id_t.t;
+ name: string;
+ icon: string option;
+ splash: string option;
+ owner_id: User_id_t.t;
+ region: string;
+ afk_channel_id: Channel_id_t.t option;
+ afk_timeout: int;
+ embed_enabled: bool;
+ embed_channel_id: Channel_id_t.t option;
+ verification_level: int;
+ default_message_notifications: int;
+ explicit_content_filter: int;
+ roles: Role_t.role list;
+ emojis: Emoji.t list;
+ features: string list;
+ mfa_level: int;
+ application_id: Snowflake.t option;
+ widget_enabled: bool;
+ 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;
+} [@@deriving sexp, yojson]
+
+(** A Guild object *)
+type t = {
+ id: Guild_id_t.t; (** The guild's snowflake ID. *)
+ name: string; (** The guild name. *)
+ icon: string option; (** The guild icon hash, if one is set. *)
+ splash: string option; (** The guild splash hash, if one is set. *)
+ owner_id: User_id_t.t; (** The user ID of the owner. *)
+ region: string; (** The region the guild is in. *)
+ afk_channel_id: Channel_id_t.t option; (** The AFK channel ID, if one is set. *)
+ afk_timeout: int; (** The time before a user is moved to the AFK channel. *)
+ embed_enabled: bool; (** Whether the embed is enabled. *)
+ embed_channel_id: Channel_id_t.t option; (** The channel ID of the embed channel, if it is enabled. *)
+ verification_level: int; (** See {{:https://discordapp.com/developers/docs/resources/guild#guild-object-verification-level} the discord docs} for details. *)
+ default_message_notifications: int; (** 0 = All messages, 1 = Only mentions *)
+ explicit_content_filter: int; (** 0 = Disabled, 1 = For members with no roles, 2 = All members *)
+ roles: Role_t.t list; (** List of roles in the guild. *)
+ emojis: Emoji.t list; (** List of custom emojis in the guild. *)
+ features: string list; (** A List of features enabled for the guild. *)
+ mfa_level: int; (** 0 = None, 1 = Elevated *)
+ application_id: Snowflake.t option; (** Snowflake ID if the guild is bot-created. *)
+ widget_enabled: bool; (** Whether the widget is enabled. *)
+ 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. *)
+} [@@deriving sexp, yojson]
+
+val wrap : pre -> t
val get_id : t -> Snowflake.t
\ No newline at end of file diff --git a/lib/models/guild/member.ml b/lib/models/guild/member.ml index f083cce..c5a7455 100644 --- a/lib/models/guild/member.ml +++ b/lib/models/guild/member.ml @@ -1,57 +1,57 @@ -include Member_t - -let add_role ~(role:Role_t.t) member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - let `Role_id role_id = role.id in - Http.add_member_role guild_id user_id role_id - -let remove_role ~(role:Role_t.t) member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - let `Role_id role_id = role.id in - Http.remove_member_role guild_id user_id role_id - -let ban ?(reason="") ?(days=0) member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - Http.guild_ban_add guild_id user_id (`Assoc [ - ("delete-message-days", `Int days); - ("reason", `String reason); - ]) - -let kick ?reason member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - let payload = match reason with - | Some r -> `Assoc [("reason", `String r)] - | None -> `Null - in Http.remove_member guild_id user_id payload - -let mute member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - Http.edit_member guild_id user_id (`Assoc [ - ("mute", `Bool true); - ]) - -let deafen member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - Http.edit_member guild_id user_id (`Assoc [ - ("deaf", `Bool true); - ]) - -let unmute member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - Http.edit_member guild_id user_id (`Assoc [ - ("mute", `Bool false); - ]) - -let undeafen member = - let `Guild_id guild_id = member.guild_id in - let `User_id user_id = member.user.id in - Http.edit_member guild_id user_id (`Assoc [ - ("deaf", `Bool false); - ]) +include Member_t
+
+let add_role ~(role:Role_t.t) member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ let `Role_id role_id = role.id in
+ Http.add_member_role guild_id user_id role_id
+
+let remove_role ~(role:Role_t.t) member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ let `Role_id role_id = role.id in
+ Http.remove_member_role guild_id user_id role_id
+
+let ban ?(reason="") ?(days=0) member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ Http.guild_ban_add guild_id user_id (`Assoc [
+ ("delete-message-days", `Int days);
+ ("reason", `String reason);
+ ])
+
+let kick ?reason member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ let payload = match reason with
+ | Some r -> `Assoc [("reason", `String r)]
+ | None -> `Null
+ in Http.remove_member guild_id user_id payload
+
+let mute member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ Http.edit_member guild_id user_id (`Assoc [
+ ("mute", `Bool true);
+ ])
+
+let deafen member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ Http.edit_member guild_id user_id (`Assoc [
+ ("deaf", `Bool true);
+ ])
+
+let unmute member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ Http.edit_member guild_id user_id (`Assoc [
+ ("mute", `Bool false);
+ ])
+
+let undeafen member =
+ let `Guild_id guild_id = member.guild_id in
+ let `User_id user_id = member.user.id in
+ Http.edit_member guild_id user_id (`Assoc [
+ ("deaf", `Bool false);
+ ])
diff --git a/lib/models/guild/member_t.ml b/lib/models/guild/member_t.ml index 10f1cf0..ae6b894 100644 --- a/lib/models/guild/member_t.ml +++ b/lib/models/guild/member_t.ml @@ -1,43 +1,43 @@ -open Core - -type partial_member = { - nick: string option [@default None]; - roles: Role_id.t list; - joined_at: string; - deaf: bool; - mute: bool; -} [@@deriving sexp, yojson { strict = false}] - -type member = { - nick: string option [@default None]; - roles: Role_id.t list; - joined_at: string; - deaf: bool; - mute: bool; - user: User_t.t; -} [@@deriving sexp, yojson { strict = false}] - -type member_wrapper = { - guild_id: Guild_id_t.t; - user: User_t.t; -} [@@deriving sexp, yojson { strict = false }] - -type member_update = { - guild_id: Guild_id_t.t; - roles: Role_id.t list [@default []]; - user: User_t.t; - nick: string option [@default None]; -} [@@deriving sexp, yojson { strict = false}] - -type t = { - nick: string option [@default None]; - roles: Role_id.t list; - joined_at: string; - deaf: bool; - mute: bool; - user: User_t.t; - guild_id: Guild_id_t.t; -} [@@deriving sexp, yojson { strict = false}] - -let wrap ~guild_id ({nick;roles;joined_at;deaf;mute;user}:member) = +open Core
+
+type partial_member = {
+ nick: string option [@default None];
+ roles: Role_id.t list;
+ joined_at: string;
+ deaf: bool;
+ mute: bool;
+} [@@deriving sexp, yojson { strict = false}]
+
+type member = {
+ nick: string option [@default None];
+ roles: Role_id.t list;
+ joined_at: string;
+ deaf: bool;
+ mute: bool;
+ user: User_t.t;
+} [@@deriving sexp, yojson { strict = false}]
+
+type member_wrapper = {
+ guild_id: Guild_id_t.t;
+ user: User_t.t;
+} [@@deriving sexp, yojson { strict = false }]
+
+type member_update = {
+ guild_id: Guild_id_t.t;
+ roles: Role_id.t list [@default []];
+ user: User_t.t;
+ nick: string option [@default None];
+} [@@deriving sexp, yojson { strict = false}]
+
+type t = {
+ nick: string option [@default None];
+ roles: Role_id.t list;
+ joined_at: string;
+ deaf: bool;
+ mute: bool;
+ user: User_t.t;
+ guild_id: Guild_id_t.t;
+} [@@deriving sexp, yojson { strict = false}]
+
+let wrap ~guild_id ({nick;roles;joined_at;deaf;mute;user}:member) =
{nick;roles;joined_at;deaf;mute;user;guild_id = `Guild_id guild_id}
\ No newline at end of file diff --git a/lib/models/guild/member_t.mli b/lib/models/guild/member_t.mli index 918885e..170504f 100644 --- a/lib/models/guild/member_t.mli +++ b/lib/models/guild/member_t.mli @@ -1,41 +1,41 @@ -type partial_member = { - nick: string option; - roles: Role_id.t list; - joined_at: string; - deaf: bool; - mute: bool; -} [@@deriving sexp, yojson] - -type member = { - nick: string option; - roles: Role_id.t list; - joined_at: string; - deaf: bool; - mute: bool; - user: User_t.t; -} [@@deriving sexp, yojson] - -type member_wrapper = { - guild_id: Guild_id_t.t; - user: User_t.t; -} [@@deriving sexp, yojson] - -type member_update = { - guild_id: Guild_id_t.t; - roles: Role_id.t list; - user: User_t.t; - nick: string option; -} [@@deriving sexp, yojson] - -(** A member object. *) -type t = { - nick: string option; (** The nickname of the member, if they have one set. *) - roles: Role_id.t list; (** The roles the member has. *) - joined_at: string; (** An ISO8601 timestamp of when the user joined. *) - deaf: bool; (** Whether the user is deafened. *) - mute: bool; (** Whether the user is muted. *) - user: User_t.t; (** The underlying user object for the member. *) - guild_id: Guild_id_t.t; (** The guild ID in which the member exists. *) -} [@@deriving sexp, yojson] - +type partial_member = {
+ nick: string option;
+ roles: Role_id.t list;
+ joined_at: string;
+ deaf: bool;
+ mute: bool;
+} [@@deriving sexp, yojson]
+
+type member = {
+ nick: string option;
+ roles: Role_id.t list;
+ joined_at: string;
+ deaf: bool;
+ mute: bool;
+ user: User_t.t;
+} [@@deriving sexp, yojson]
+
+type member_wrapper = {
+ guild_id: Guild_id_t.t;
+ user: User_t.t;
+} [@@deriving sexp, yojson]
+
+type member_update = {
+ guild_id: Guild_id_t.t;
+ roles: Role_id.t list;
+ user: User_t.t;
+ nick: string option;
+} [@@deriving sexp, yojson]
+
+(** A member object. *)
+type t = {
+ nick: string option; (** The nickname of the member, if they have one set. *)
+ roles: Role_id.t list; (** The roles the member has. *)
+ joined_at: string; (** An ISO8601 timestamp of when the user joined. *)
+ deaf: bool; (** Whether the user is deafened. *)
+ mute: bool; (** Whether the user is muted. *)
+ user: User_t.t; (** The underlying user object for the member. *)
+ guild_id: Guild_id_t.t; (** The guild ID in which the member exists. *)
+} [@@deriving sexp, yojson]
+
val wrap : guild_id:Snowflake.t -> member -> t
\ No newline at end of file diff --git a/lib/models/guild/role.ml b/lib/models/guild/role.ml index 46f908b..55e5813 100644 --- a/lib/models/guild/role.ml +++ b/lib/models/guild/role.ml @@ -1,29 +1,29 @@ -include Role_t - -let edit_role ~body (role:t) = - let `Role_id id = role.id in - let `Guild_id guild_id = role.guild_id in - Http.guild_role_edit guild_id id body - -let allow_mention role = - edit_role ~body:(`Assoc [("mentionable", `Bool true)]) role - -let delete (role:t) = - let `Role_id id = role.id in - let `Guild_id guild_id = role.guild_id in - Http.guild_role_remove guild_id id - -let disallow_mention role = - edit_role ~body:(`Assoc [("mentionable", `Bool false)]) role - -let hoist role = - edit_role ~body:(`Assoc [("hoist", `Bool true)]) role - -let set_colour ~colour role = - edit_role ~body:(`Assoc [("color", `Int colour)]) role - -let set_name ~name role = - edit_role ~body:(`Assoc [("name", `String name)]) role - -let unhoist role = +include Role_t
+
+let edit_role ~body (role:t) =
+ let `Role_id id = role.id in
+ let `Guild_id guild_id = role.guild_id in
+ Http.guild_role_edit guild_id id body
+
+let allow_mention role =
+ edit_role ~body:(`Assoc [("mentionable", `Bool true)]) role
+
+let delete (role:t) =
+ let `Role_id id = role.id in
+ let `Guild_id guild_id = role.guild_id in
+ Http.guild_role_remove guild_id id
+
+let disallow_mention role =
+ edit_role ~body:(`Assoc [("mentionable", `Bool false)]) role
+
+let hoist role =
+ edit_role ~body:(`Assoc [("hoist", `Bool true)]) role
+
+let set_colour ~colour role =
+ edit_role ~body:(`Assoc [("color", `Int colour)]) role
+
+let set_name ~name role =
+ edit_role ~body:(`Assoc [("name", `String name)]) role
+
+let unhoist role =
edit_role ~body:(`Assoc [("hoist", `Bool false)]) role
\ No newline at end of file diff --git a/lib/models/guild/role_t.ml b/lib/models/guild/role_t.ml index f012a15..cc461f3 100644 --- a/lib/models/guild/role_t.ml +++ b/lib/models/guild/role_t.ml @@ -1,27 +1,27 @@ -open Core - -type role = { - id: Role_id.t; - name: string; - colour: int [@key "color"]; - hoist: bool; - position: int; - permissions: int; - managed: bool; - mentionable: bool; -} [@@deriving sexp, yojson { strict = false}] - -type t = { - id: Role_id.t; - name: string; - colour: int [@key "color"]; - hoist: bool; - position: int; - permissions: int; - managed: bool; - mentionable: bool; - guild_id: Guild_id_t.t; -} [@@deriving sexp, yojson { strict = false}] - -let wrap ~guild_id ({id;name;colour;hoist;position;permissions;managed;mentionable}:role) = +open Core
+
+type role = {
+ id: Role_id.t;
+ name: string;
+ colour: int [@key "color"];
+ hoist: bool;
+ position: int;
+ permissions: int;
+ managed: bool;
+ mentionable: bool;
+} [@@deriving sexp, yojson { strict = false}]
+
+type t = {
+ id: Role_id.t;
+ name: string;
+ colour: int [@key "color"];
+ hoist: bool;
+ position: int;
+ permissions: int;
+ managed: bool;
+ mentionable: bool;
+ guild_id: Guild_id_t.t;
+} [@@deriving sexp, yojson { strict = false}]
+
+let wrap ~guild_id ({id;name;colour;hoist;position;permissions;managed;mentionable}:role) =
{id;name;colour;hoist;position;permissions;managed;mentionable;guild_id = `Guild_id guild_id}
\ No newline at end of file diff --git a/lib/models/guild/role_t.mli b/lib/models/guild/role_t.mli index 6fd023f..1b69e25 100644 --- a/lib/models/guild/role_t.mli +++ b/lib/models/guild/role_t.mli @@ -1,27 +1,27 @@ -(** A role as Discord sends it. Only difference between this and {!t} is the lack of the guild_id field. *) -type role = { - id: Role_id.t; - name: string; - colour: int; - hoist: bool; - position: int; - permissions: int; - managed: bool; - mentionable: bool; -} [@@deriving sexp, yojson] - -(** A role object. *) -type t = { - id: Role_id.t; (** The role's snowflake ID. *) - name: string; (** The role's name. *) - colour: int; (** The integer representation of the role colour. *) - hoist: bool; (** Whether the role is hoisted. This property controls whether the role is separated on the sidebar. *) - position: int; (** The position of the role. [@everyone] begins the list at 0. *) - permissions: int; (** The integer representation of the permissions the role has. *) - managed: bool; (** Whether the guild is managed by an integration. *) - mentionable: bool; (** Whether the role can be mentioned. *) - guild_id: Guild_id_t.t; (** The guild ID this role belongs to. *) -} [@@deriving sexp, yojson] - -(** Convenience method to produce {!t} from {!role} and a snowflake. *) +(** A role as Discord sends it. Only difference between this and {!t} is the lack of the guild_id field. *)
+type role = {
+ id: Role_id.t;
+ name: string;
+ colour: int;
+ hoist: bool;
+ position: int;
+ permissions: int;
+ managed: bool;
+ mentionable: bool;
+} [@@deriving sexp, yojson]
+
+(** A role object. *)
+type t = {
+ id: Role_id.t; (** The role's snowflake ID. *)
+ name: string; (** The role's name. *)
+ colour: int; (** The integer representation of the role colour. *)
+ hoist: bool; (** Whether the role is hoisted. This property controls whether the role is separated on the sidebar. *)
+ position: int; (** The position of the role. [@everyone] begins the list at 0. *)
+ permissions: int; (** The integer representation of the permissions the role has. *)
+ managed: bool; (** Whether the guild is managed by an integration. *)
+ mentionable: bool; (** Whether the role can be mentioned. *)
+ guild_id: Guild_id_t.t; (** The guild ID this role belongs to. *)
+} [@@deriving sexp, yojson]
+
+(** Convenience method to produce {!t} from {!role} and a snowflake. *)
val wrap : guild_id:Snowflake.t -> role -> t
\ No newline at end of file diff --git a/lib/models/id/channel_id.ml b/lib/models/id/channel_id.ml index 67f81a5..be4bfab 100644 --- a/lib/models/id/channel_id.ml +++ b/lib/models/id/channel_id.ml @@ -1,2 +1,2 @@ -include Channel_id_t +include Channel_id_t
include Impl.Channel(Channel_id_t)
\ No newline at end of file diff --git a/lib/models/id/channel_id.mli b/lib/models/id/channel_id.mli index f352160..59b4d23 100644 --- a/lib/models/id/channel_id.mli +++ b/lib/models/id/channel_id.mli @@ -1,3 +1,3 @@ -include module type of Channel_id_t -include S.ChannelImpl with +include module type of Channel_id_t
+include S.ChannelImpl with
type t := Channel_id_t.t
\ 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 26bd984..e49beef 100644 --- a/lib/models/id/channel_id_t.ml +++ b/lib/models/id/channel_id_t.ml @@ -1,11 +1,11 @@ -type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp] - -let of_yojson a : (t, string) result = - match Snowflake.of_yojson a with - | Ok id -> Ok (`Channel_id id) - | Error err -> Error err - -let of_yojson_exn a : t = `Channel_id (Snowflake.of_yojson_exn a) -let to_yojson (`Channel_id id) = (Snowflake.to_yojson id) - +type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp]
+
+let of_yojson a : (t, string) result =
+ match Snowflake.of_yojson a with
+ | Ok id -> Ok (`Channel_id id)
+ | Error err -> Error err
+
+let of_yojson_exn a : t = `Channel_id (Snowflake.of_yojson_exn a)
+let to_yojson (`Channel_id id) = (Snowflake.to_yojson id)
+
let get_id (`Channel_id id) = id
\ No newline at end of file diff --git a/lib/models/id/channel_id_t.mli b/lib/models/id/channel_id_t.mli index 821c8b0..2e7c76f 100644 --- a/lib/models/id/channel_id_t.mli +++ b/lib/models/id/channel_id_t.mli @@ -1,3 +1,3 @@ -type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp, yojson] - +type t = [ `Channel_id of Snowflake.t ] [@@deriving sexp, yojson]
+
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 051006b..79b4323 100644 --- a/lib/models/id/guild_id.ml +++ b/lib/models/id/guild_id.ml @@ -1,2 +1,2 @@ -include Guild_id_t +include Guild_id_t
include Impl.Guild(Guild_id_t)
\ No newline at end of file diff --git a/lib/models/id/guild_id.mli b/lib/models/id/guild_id.mli index 670a903..88e9fa7 100644 --- a/lib/models/id/guild_id.mli +++ b/lib/models/id/guild_id.mli @@ -1,3 +1,3 @@ -include module type of Guild_id_t -include S.GuildImpl with +include module type of Guild_id_t
+include S.GuildImpl with
type t := Guild_id_t.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 d023058..cd8eb58 100644 --- a/lib/models/id/guild_id_t.ml +++ b/lib/models/id/guild_id_t.ml @@ -1,11 +1,11 @@ -type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp] - -let of_yojson a : (t, string) result = - match Snowflake.of_yojson a with - | Ok id -> Ok (`Guild_id id) - | Error err -> Error err - -let of_yojson_exn a : t = `Guild_id (Snowflake.of_yojson_exn a) -let to_yojson (`Guild_id id) = (Snowflake.to_yojson id) - +type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp]
+
+let of_yojson a : (t, string) result =
+ match Snowflake.of_yojson a with
+ | Ok id -> Ok (`Guild_id id)
+ | Error err -> Error err
+
+let of_yojson_exn a : t = `Guild_id (Snowflake.of_yojson_exn a)
+let to_yojson (`Guild_id id) = (Snowflake.to_yojson id)
+
let get_id (`Guild_id id) = id
\ No newline at end of file diff --git a/lib/models/id/guild_id_t.mli b/lib/models/id/guild_id_t.mli index dc72deb..9c92d6c 100644 --- a/lib/models/id/guild_id_t.mli +++ b/lib/models/id/guild_id_t.mli @@ -1,3 +1,3 @@ -type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp, yojson] - +type t = [ `Guild_id of Snowflake.t ] [@@deriving sexp, yojson]
+
val get_id : t -> Snowflake.t
\ No newline at end of file diff --git a/lib/models/id/message_id.ml b/lib/models/id/message_id.ml index 4a4fbb3..10bcb1d 100644 --- a/lib/models/id/message_id.ml +++ b/lib/models/id/message_id.ml @@ -1,11 +1,11 @@ -type t = [ `Message_id of Snowflake.t ] [@@deriving sexp] - -let of_yojson a : (t, string) result = - match Snowflake.of_yojson a with - | Ok id -> Ok (`Message_id id) - | Error err -> Error err - -let of_yojson_exn a : t = `Message_id (Snowflake.of_yojson_exn a) -let to_yojson (`Message_id id) = (Snowflake.to_yojson id) - +type t = [ `Message_id of Snowflake.t ] [@@deriving sexp]
+
+let of_yojson a : (t, string) result =
+ match Snowflake.of_yojson a with
+ | Ok id -> Ok (`Message_id id)
+ | Error err -> Error err
+
+let of_yojson_exn a : t = `Message_id (Snowflake.of_yojson_exn a)
+let to_yojson (`Message_id id) = (Snowflake.to_yojson id)
+
let get_id (`Message_id id) = id
\ No newline at end of file diff --git a/lib/models/id/message_id.mli b/lib/models/id/message_id.mli index da50f72..90107b5 100644 --- a/lib/models/id/message_id.mli +++ b/lib/models/id/message_id.mli @@ -1,3 +1,3 @@ -type t = [ `Message_id of Snowflake.t ] [@@deriving sexp, yojson] - +type t = [ `Message_id of Snowflake.t ] [@@deriving sexp, yojson]
+
val get_id : t -> Snowflake.t
\ No newline at end of file diff --git a/lib/models/id/role_id.ml b/lib/models/id/role_id.ml index b3fa5a1..f055b1a 100644 --- a/lib/models/id/role_id.ml +++ b/lib/models/id/role_id.ml @@ -1,11 +1,11 @@ -type t = [ `Role_id of Snowflake.t ] [@@deriving sexp] - -let of_yojson a : (t, string) result = - match Snowflake.of_yojson a with - | Ok id -> Ok (`Role_id id) - | Error err -> Error err - -let of_yojson_exn a : t = `Role_id (Snowflake.of_yojson_exn a) -let to_yojson (`Role_id id) = (Snowflake.to_yojson id) - +type t = [ `Role_id of Snowflake.t ] [@@deriving sexp]
+
+let of_yojson a : (t, string) result =
+ match Snowflake.of_yojson a with
+ | Ok id -> Ok (`Role_id id)
+ | Error err -> Error err
+
+let of_yojson_exn a : t = `Role_id (Snowflake.of_yojson_exn a)
+let to_yojson (`Role_id id) = (Snowflake.to_yojson id)
+
let get_id (`Role_id id) = id
\ No newline at end of file diff --git a/lib/models/id/role_id.mli b/lib/models/id/role_id.mli index ededf3a..701e4a9 100644 --- a/lib/models/id/role_id.mli +++ b/lib/models/id/role_id.mli @@ -1,3 +1,3 @@ -type t = [ `Role_id of Snowflake.t ] [@@deriving sexp, yojson] - +type t = [ `Role_id of Snowflake.t ] [@@deriving sexp, yojson]
+
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 77ce220..cc71764 100644 --- a/lib/models/id/user_id.ml +++ b/lib/models/id/user_id.ml @@ -1,2 +1,2 @@ -include User_id_t +include User_id_t
include Impl.User(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 d7da91e..574c4f0 100644 --- a/lib/models/id/user_id.mli +++ b/lib/models/id/user_id.mli @@ -1,3 +1,3 @@ -include module type of User_id_t -include S.UserImpl with +include module type of User_id_t
+include S.UserImpl with
type t := User_id_t.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 5ed9f14..f168daa 100644 --- a/lib/models/id/user_id_t.ml +++ b/lib/models/id/user_id_t.ml @@ -1,11 +1,11 @@ -type t = [ `User_id of Snowflake.t ] [@@deriving sexp] - -let of_yojson a : (t, string) result = - match Snowflake.of_yojson a with - | Ok id -> Ok (`User_id id) - | Error err -> Error err - -let of_yojson_exn a : t = `User_id (Snowflake.of_yojson_exn a) -let to_yojson (`User_id id) = (Snowflake.to_yojson id) - +type t = [ `User_id of Snowflake.t ] [@@deriving sexp]
+
+let of_yojson a : (t, string) result =
+ match Snowflake.of_yojson a with
+ | Ok id -> Ok (`User_id id)
+ | Error err -> Error err
+
+let of_yojson_exn a : t = `User_id (Snowflake.of_yojson_exn a)
+let to_yojson (`User_id id) = (Snowflake.to_yojson id)
+
let get_id (`User_id id) = id
\ No newline at end of file diff --git a/lib/models/id/user_id_t.mli b/lib/models/id/user_id_t.mli index 90211ab..0893a34 100644 --- a/lib/models/id/user_id_t.mli +++ b/lib/models/id/user_id_t.mli @@ -1,3 +1,3 @@ -type t = [ `User_id of Snowflake.t ] [@@deriving sexp, yojson] - +type t = [ `User_id of Snowflake.t ] [@@deriving sexp, yojson]
+
val get_id : t -> Snowflake.t
\ No newline at end of file diff --git a/lib/models/snowflake.ml b/lib/models/snowflake.ml index 3b55493..44b0a48 100644 --- a/lib/models/snowflake.ml +++ b/lib/models/snowflake.ml @@ -1,22 +1,22 @@ -open Core - -type t = Int.t [@@deriving sexp] - -let of_yojson_exn d = Yojson.Safe.Util.to_string d |> Int.of_string - -let of_yojson d = - try of_yojson_exn d |> Ok - with Yojson.Safe.Util.Type_error (why,_) -> Error why - -let to_yojson s : Yojson.Safe.json = `String (Int.to_string s) - -let timestamp snowflake = (snowflake lsr 22) + 1_420_070_400_000 - -let time_of_t snowflake = - let t = timestamp snowflake |> float_of_int in - Time.(Span.of_ms t - |> of_span_since_epoch) - -let timestamp_iso snowflake = - time_of_t snowflake +open Core
+
+type t = Int.t [@@deriving sexp]
+
+let of_yojson_exn d = Yojson.Safe.Util.to_string d |> Int.of_string
+
+let of_yojson d =
+ try of_yojson_exn d |> Ok
+ with Yojson.Safe.Util.Type_error (why,_) -> Error why
+
+let to_yojson s : Yojson.Safe.json = `String (Int.to_string s)
+
+let timestamp snowflake = (snowflake lsr 22) + 1_420_070_400_000
+
+let time_of_t snowflake =
+ let t = timestamp snowflake |> float_of_int in
+ Time.(Span.of_ms t
+ |> of_span_since_epoch)
+
+let timestamp_iso snowflake =
+ time_of_t snowflake
|> Time.(to_string_iso8601_basic ~zone:Zone.utc)
\ No newline at end of file diff --git a/lib/models/snowflake.mli b/lib/models/snowflake.mli index e7f6be3..475b94c 100644 --- a/lib/models/snowflake.mli +++ b/lib/models/snowflake.mli @@ -1,12 +1,12 @@ -open Core - -type t = Int.t [@@deriving sexp, yojson] - -(** Convert a snowflake into a {!Core.Time.t} *) -val time_of_t : t -> Time.t - -(** Convert a snowflake into a Unix timestamp. Millisecond precision. *) -val timestamp : t -> int - -(** Convert a snowflake into an ISO8601 timestamp string. This is equivalent to calling [Snowflake.time_of_t snowflake |> Time.(to_string_iso8601_basic ~zone:Zone.utc)] *) +open Core
+
+type t = Int.t [@@deriving sexp, yojson]
+
+(** Convert a snowflake into a {!Core.Time.t} *)
+val time_of_t : t -> Time.t
+
+(** Convert a snowflake into a Unix timestamp. Millisecond precision. *)
+val timestamp : t -> int
+
+(** Convert a snowflake into an ISO8601 timestamp string. This is equivalent to calling [Snowflake.time_of_t snowflake |> Time.(to_string_iso8601_basic ~zone:Zone.utc)] *)
val timestamp_iso : t -> string
\ No newline at end of file diff --git a/lib/models/user/activity.mli b/lib/models/user/activity.mli index 970ac59..1ddd4e7 100644 --- a/lib/models/user/activity.mli +++ b/lib/models/user/activity.mli @@ -1,6 +1,6 @@ -(** An activity object. *) -type t = { - name: string; (** The name of the activity. *) - kind: int; (** 0 = Playing, 1 = Streaming, 2 = Listening, 3 = Watching *) - url: string option; (** Stream URL. Only validated for kind = 1. *) +(** An activity object. *)
+type t = {
+ name: string; (** The name of the activity. *)
+ kind: int; (** 0 = Playing, 1 = Streaming, 2 = Listening, 3 = Watching *)
+ url: string option; (** Stream URL. Only validated for kind = 1. *)
} [@@deriving sexp, yojson]
\ No newline at end of file diff --git a/lib/models/user/presence.mli b/lib/models/user/presence.mli index 6c60d7f..d75d408 100644 --- a/lib/models/user/presence.mli +++ b/lib/models/user/presence.mli @@ -1,9 +1,9 @@ -(** 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. *) +(** 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]
\ No newline at end of file diff --git a/lib/models/user/user.ml b/lib/models/user/user.ml index de7ce01..b8c3b25 100644 --- a/lib/models/user/user.ml +++ b/lib/models/user/user.ml @@ -1,23 +1,23 @@ -open Core -include User_t - -let tag user = - Printf.sprintf "%s#%s" user.username user.discriminator - -let mention user = - let `User_id id = user.id in - Printf.sprintf "<@%d>" id - -let default_avatar user = - let avatar = Int.of_string user.discriminator % 5 in - Endpoints.cdn_default_avatar avatar - -let face user = - let `User_id id = user.id in - match user.avatar with - | Some avatar -> - let ext = if String.is_substring ~substring:"a_" avatar - then "gif" - else "png" in - Endpoints.cdn_avatar id avatar ext +open Core
+include User_t
+
+let tag user =
+ Printf.sprintf "%s#%s" user.username user.discriminator
+
+let mention user =
+ let `User_id id = user.id in
+ Printf.sprintf "<@%d>" id
+
+let default_avatar user =
+ let avatar = Int.of_string user.discriminator % 5 in
+ Endpoints.cdn_default_avatar avatar
+
+let face user =
+ let `User_id id = user.id in
+ match user.avatar with
+ | Some avatar ->
+ let ext = if String.is_substring ~substring:"a_" avatar
+ then "gif"
+ else "png" in
+ Endpoints.cdn_avatar id avatar ext
| None -> default_avatar user
\ No newline at end of file diff --git a/lib/models/user/user_t.ml b/lib/models/user/user_t.ml index 89a6895..8958e84 100644 --- a/lib/models/user/user_t.ml +++ b/lib/models/user/user_t.ml @@ -1,13 +1,13 @@ -open Core - -type partial_user = { - id: User_id_t.t; -} [@@deriving sexp, yojson { strict = false}] - -type t = { - id: User_id_t.t; - username: string; - discriminator: string; - avatar: string option [@default None]; - bot: bool [@default false]; +open Core
+
+type partial_user = {
+ id: User_id_t.t;
+} [@@deriving sexp, yojson { strict = false}]
+
+type t = {
+ id: User_id_t.t;
+ username: string;
+ discriminator: string;
+ avatar: string option [@default None];
+ bot: bool [@default false];
} [@@deriving sexp, yojson { strict = false }]
\ No newline at end of file diff --git a/lib/models/user/user_t.mli b/lib/models/user/user_t.mli index 694fc1e..645df3e 100644 --- a/lib/models/user/user_t.mli +++ b/lib/models/user/user_t.mli @@ -1,13 +1,13 @@ -(** A partial user. Used internally. *) -type partial_user = { - id: User_id_t.t; -} [@@deriving sexp, yojson] - -(** A user object. *) -type t = { - id: User_id_t.t; (** The user's Snowflake ID, wrapped in the convenience [`User_id] type. *) - username: string; (** The username of the user. *) - discriminator: string; (** The 4 digits, as a string, that come after the '#' in a Discord username. *) - avatar: string option; (** The hash of the user avatar, if they have one set. See {!User.face} to get the avatar URL. *) - bot: bool; (** Whether the user is a bot. *) +(** A partial user. Used internally. *)
+type partial_user = {
+ id: User_id_t.t;
+} [@@deriving sexp, yojson]
+
+(** A user object. *)
+type t = {
+ id: User_id_t.t; (** The user's Snowflake ID, wrapped in the convenience [`User_id] type. *)
+ username: string; (** The username of the user. *)
+ discriminator: string; (** The 4 digits, as a string, that come after the '#' in a Discord username. *)
+ avatar: string option; (** The hash of the user avatar, if they have one set. See {!User.face} to get the avatar URL. *)
+ bot: bool; (** Whether the user is a bot. *)
} [@@deriving sexp, yojson]
\ No newline at end of file @@ -1,92 +1,92 @@ -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 - (* 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.json Deferred.Or_error.t - val get_prune_count : days:int -> t -> int Deferred.Or_error.t - val get_webhooks : t -> Yojson.Safe.json 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.json 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.json Deferred.Or_error.t *) +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
+ (* 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.json Deferred.Or_error.t
+ val get_prune_count : days:int -> t -> int Deferred.Or_error.t
+ val get_webhooks : t -> Yojson.Safe.json 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.json 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.json Deferred.Or_error.t *)
end
\ No newline at end of file diff --git a/lib/sharder.ml b/lib/sharder.ml index 11a6bd8..f98ee8f 100644 --- a/lib/sharder.ml +++ b/lib/sharder.ml @@ -1,327 +1,327 @@ -open Async -open Core -open Websocket_async - -exception Invalid_Payload -exception Failure_to_Establish_Heartbeat - -module Shard = struct - type shard = { - hb_interval: Time.Span.t Ivar.t; - seq: int; - session: string option; - pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; - ready: unit Ivar.t; - url: string; - id: int * int; - _internal: Reader.t * Writer.t; - } - - type 'a t = { - mutable state: 'a; - } - - let identify_lock = Mvar.create () - let _ = Mvar.set identify_lock () - - let parse (frame:[`Ok of Frame.t | `Eof]) = - match frame with - | `Ok s -> begin - let open Frame.Opcode in - match s.opcode with - | Text -> Some (Yojson.Safe.from_string s.content) - | _ -> None - end - | `Eof -> None - - let push_frame ?payload ~ev shard = - let content = match payload with - | None -> "" - | Some p -> - Yojson.Safe.to_string @@ `Assoc [ - ("op", `Int (Opcode.to_int ev)); - ("d", p); - ] - in - let (_, write) = shard.pipe in - Pipe.write write @@ Frame.create ~content () - >>| fun () -> - shard - - let heartbeat shard = - Logs.debug (fun m -> m "Heartbeating - Shard: [%d, %d] - Seq: %d" (fst shard.id) (snd shard.id) (shard.seq)); - let payload = match shard.seq with - | 0 -> `Null - | i -> `Int i - in - push_frame ~payload ~ev:HEARTBEAT shard - - let dispatch ~payload shard = - let module J = Yojson.Safe.Util in - let seq = J.(member "s" payload |> to_int) in - let t = J.(member "t" payload |> to_string) in - let data = J.member "d" payload in - let session = if t = "READY" then begin - Ivar.fill_if_empty shard.ready (); - Clock.after (Core.Time.Span.create ~sec:5 ()) - >>> (fun _ -> Mvar.put identify_lock () >>> ignore); - J.(member "session_id" data |> to_string_option) - end else None in - Event.handle_event ~ev:t data; - return { shard with - seq = seq; - session = session; - } - - let set_status ~(status:Yojson.Safe.json) shard = - let payload = match status with - | `Assoc [("name", `String name); ("type", `Int t)] -> - `Assoc [ - ("status", `String "online"); - ("afk", `Bool false); - ("since", `Null); - ("game", `Assoc [ - ("name", `String name); - ("type", `Int t) - ]) - ] - | `String name -> - `Assoc [ - ("status", `String "online"); - ("afk", `Bool false); - ("since", `Null); - ("game", `Assoc [ - ("name", `String name); - ("type", `Int 0) - ]) - ] - | _ -> raise Invalid_Payload - in - Ivar.read shard.ready >>= fun _ -> - push_frame ~payload ~ev:STATUS_UPDATE shard - - let request_guild_members ?(query="") ?(limit=0) ~guild shard = - let payload = `Assoc [ - ("guild_id", `String (Int.to_string guild)); - ("query", `String query); - ("limit", `Int limit); - ] in - Ivar.read shard.ready >>= fun _ -> - push_frame ~payload ~ev:REQUEST_GUILD_MEMBERS shard - - let initialize ?data shard = - let module J = Yojson.Safe.Util in - let _ = match data with - | Some data -> Ivar.fill shard.hb_interval (Time.Span.create ~ms:J.(member "heartbeat_interval" data |> to_int) ()) - | None -> raise Failure_to_Establish_Heartbeat - in - let shards = [`Int (fst shard.id); `Int (snd shard.id)] in - match shard.session with - | None -> begin - Mvar.take identify_lock >>= fun () -> - Logs.debug (fun m -> m "Identifying shard [%d, %d]" (fst shard.id) (snd shard.id)); - let payload = `Assoc [ - ("token", `String !Client_options.token); - ("properties", `Assoc [ - ("$os", `String Sys.os_type); - ("$device", `String "dis.ml"); - ("$browser", `String "dis.ml") - ]); - ("compress", `Bool false); (* TODO add compression handling*) - ("large_threshold", `Int 250); - ("shard", `List shards); - ] in - push_frame ~payload ~ev:IDENTIFY shard - >>| fun s -> s - end - | Some s -> - let payload = `Assoc [ - ("token", `String !Client_options.token); - ("session_id", `String s); - ("seq", `Int shard.seq) - ] in - push_frame ~payload ~ev:RESUME shard - - let handle_frame ~f shard = - let module J = Yojson.Safe.Util in - let op = J.(member "op" f |> to_int) |> Opcode.from_int in - match op with - | DISPATCH -> dispatch ~payload:f shard - | HEARTBEAT -> heartbeat shard - | INVALID_SESSION -> begin - Logs.err (fun m -> m "Received OP 9 on Shard [%d, %d]: %s" (fst shard.id) (snd shard.id) (Yojson.Safe.pretty_to_string f)); - if J.(member "d" f |> to_bool) then - initialize shard - else begin - initialize { shard with session = None; } - end - end - | RECONNECT -> initialize shard - | HELLO -> initialize ~data:(J.member "d" f) shard - | HEARTBEAT_ACK -> return shard - | opcode -> - Logs.warn (fun m -> m "Invalid Opcode: %s" (Opcode.to_string opcode)); - return shard - - let rec make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri = - client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri - >>> fun res -> - match res with - | Ok () -> () - | Error _ -> - let backoff = Time.Span.create ~ms:500 () in - Clock.after backoff >>> (fun () -> - make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri) - - - let create ~url ~shards () = - let open Core in - let uri = (url ^ "?v=6&encoding=json") |> Uri.of_string in - let extra_headers = Http.Base.process_request_headers () in - let host = Option.value_exn ~message:"no host in uri" Uri.(host uri) in - let port = - match Uri.port uri, Uri_services.tcp_port_of_uri uri with - | Some p, _ -> p - | None, Some p -> p - | _ -> 443 in - let scheme = Option.value_exn ~message:"no scheme in uri" Uri.(scheme uri) in - let tcp_fun (net_to_ws, ws_to_net) = - (* Writer.monitor ws_to_net - |> Monitor.detach_and_get_error_stream - |> Stream.iter ~f:(fun e -> Logs.err (fun m -> m "Socket Connection Error: %s" (Exn.sexp_of_t e |> Sexp.to_string_hum))); *) - let (app_to_ws, write) = Pipe.create () in - let (read, ws_to_app) = Pipe.create () in - let initialized = Ivar.create () in - make_client - ~initialized - ~extra_headers - ~app_to_ws - ~ws_to_app - ~net_to_ws - ~ws_to_net - uri; - Ivar.read initialized >>| fun () -> - { - pipe = (read, write); - ready = Ivar.create (); - hb_interval = Ivar.create (); - seq = 0; - id = shards; - session = None; - url; - _internal = (net_to_ws, ws_to_net); - } - in - match Unix.getaddrinfo host (string_of_int port) [] with - | [] -> failwithf "DNS resolution failed for %s" host () - | { ai_addr; _ } :: _ -> - let addr = - match scheme, ai_addr with - | _, ADDR_UNIX path -> `Unix_domain_socket path - | "https", ADDR_INET (h, p) - | "wss", ADDR_INET (h, p) -> - let h = Ipaddr_unix.of_inet_addr h in - `OpenSSL (h, p, Conduit_async.V2.Ssl.Config.create ()) - | _, ADDR_INET (h, p) -> - let h = Ipaddr_unix.of_inet_addr h in - `TCP (h, p) - in - Conduit_async.V2.connect addr >>= tcp_fun - - let shutdown_clean shard = - let (_,w) = shard._internal in - Writer.close w - - let recreate shard = - shutdown_clean shard >>= fun () -> - create ~url:(shard.url) ~shards:(shard.id) () -end - -type t = { - shards: (Shard.shard Shard.t) list; -} - -let start ?count () = - let module J = Yojson.Safe.Util in - Http.get_gateway_bot () >>= fun data -> - let data = match data with - | Ok d -> d - | Error e -> Error.raise e - in - let url = J.(member "url" data |> to_string) in - let count = match count with - | Some c -> c - | None -> J.(member "shards" data |> to_int) - in - let shard_list = (0, count) in - let rec ev_loop (t:Shard.shard Shard.t) = - let (read, _) = t.state.pipe in - Pipe.read read - >>= fun frame -> - (match Shard.parse frame with - | Some f -> begin - Shard.handle_frame ~f t.state - >>| fun s -> t.state <- s; t - end - | None -> begin - Shard.recreate t.state - >>| fun s -> t.state <- s; t - end) - >>= fun t -> - ev_loop t - in - let rec gen_shards l a = - match l with - | (id, total) when id >= total -> return a - | (id, total) -> - Shard.create ~url ~shards:(id, total) () - >>= fun shard -> - let t = Shard.{ state = shard; } in - let _ = Ivar.read t.state.hb_interval >>> fun hb -> Clock.every ~continue_on_error:true hb (fun () -> Shard.heartbeat t.state >>> ignore) in - ev_loop t >>> ignore; - gen_shards (id+1, total) (t :: a) - in - gen_shards shard_list [] - >>| fun shards -> - { shards; } - -let set_status ~status sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.set_status ~status t.state - ) sharder.shards - -let set_status_with ~f sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.set_status ~status:(f t.state) t.state - ) sharder.shards - -let request_guild_members ?query ?limit ~guild sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.request_guild_members ~guild ?query ?limit t.state - ) sharder.shards - -let shutdown_all sharder = - Deferred.all @@ List.map ~f:(fun t -> - Shard.shutdown_clean t.state +open Async
+open Core
+open Websocket_async
+
+exception Invalid_Payload
+exception Failure_to_Establish_Heartbeat
+
+module Shard = struct
+ type shard = {
+ hb_interval: Time.Span.t Ivar.t;
+ seq: int;
+ session: string option;
+ pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t;
+ ready: unit Ivar.t;
+ url: string;
+ id: int * int;
+ _internal: Reader.t * Writer.t;
+ }
+
+ type 'a t = {
+ mutable state: 'a;
+ }
+
+ let identify_lock = Mvar.create ()
+ let _ = Mvar.set identify_lock ()
+
+ let parse (frame:[`Ok of Frame.t | `Eof]) =
+ match frame with
+ | `Ok s -> begin
+ let open Frame.Opcode in
+ match s.opcode with
+ | Text -> Some (Yojson.Safe.from_string s.content)
+ | _ -> None
+ end
+ | `Eof -> None
+
+ let push_frame ?payload ~ev shard =
+ let content = match payload with
+ | None -> ""
+ | Some p ->
+ Yojson.Safe.to_string @@ `Assoc [
+ ("op", `Int (Opcode.to_int ev));
+ ("d", p);
+ ]
+ in
+ let (_, write) = shard.pipe in
+ Pipe.write write @@ Frame.create ~content ()
+ >>| fun () ->
+ shard
+
+ let heartbeat shard =
+ Logs.debug (fun m -> m "Heartbeating - Shard: [%d, %d] - Seq: %d" (fst shard.id) (snd shard.id) (shard.seq));
+ let payload = match shard.seq with
+ | 0 -> `Null
+ | i -> `Int i
+ in
+ push_frame ~payload ~ev:HEARTBEAT shard
+
+ let dispatch ~payload shard =
+ let module J = Yojson.Safe.Util in
+ let seq = J.(member "s" payload |> to_int) in
+ let t = J.(member "t" payload |> to_string) in
+ let data = J.member "d" payload in
+ let session = if t = "READY" then begin
+ Ivar.fill_if_empty shard.ready ();
+ Clock.after (Core.Time.Span.create ~sec:5 ())
+ >>> (fun _ -> Mvar.put identify_lock () >>> ignore);
+ J.(member "session_id" data |> to_string_option)
+ end else None in
+ Event.handle_event ~ev:t data;
+ return { shard with
+ seq = seq;
+ session = session;
+ }
+
+ let set_status ~(status:Yojson.Safe.json) shard =
+ let payload = match status with
+ | `Assoc [("name", `String name); ("type", `Int t)] ->
+ `Assoc [
+ ("status", `String "online");
+ ("afk", `Bool false);
+ ("since", `Null);
+ ("game", `Assoc [
+ ("name", `String name);
+ ("type", `Int t)
+ ])
+ ]
+ | `String name ->
+ `Assoc [
+ ("status", `String "online");
+ ("afk", `Bool false);
+ ("since", `Null);
+ ("game", `Assoc [
+ ("name", `String name);
+ ("type", `Int 0)
+ ])
+ ]
+ | _ -> raise Invalid_Payload
+ in
+ Ivar.read shard.ready >>= fun _ ->
+ push_frame ~payload ~ev:STATUS_UPDATE shard
+
+ let request_guild_members ?(query="") ?(limit=0) ~guild shard =
+ let payload = `Assoc [
+ ("guild_id", `String (Int.to_string guild));
+ ("query", `String query);
+ ("limit", `Int limit);
+ ] in
+ Ivar.read shard.ready >>= fun _ ->
+ push_frame ~payload ~ev:REQUEST_GUILD_MEMBERS shard
+
+ let initialize ?data shard =
+ let module J = Yojson.Safe.Util in
+ let _ = match data with
+ | Some data -> Ivar.fill shard.hb_interval (Time.Span.create ~ms:J.(member "heartbeat_interval" data |> to_int) ())
+ | None -> raise Failure_to_Establish_Heartbeat
+ in
+ let shards = [`Int (fst shard.id); `Int (snd shard.id)] in
+ match shard.session with
+ | None -> begin
+ Mvar.take identify_lock >>= fun () ->
+ Logs.debug (fun m -> m "Identifying shard [%d, %d]" (fst shard.id) (snd shard.id));
+ let payload = `Assoc [
+ ("token", `String !Client_options.token);
+ ("properties", `Assoc [
+ ("$os", `String Sys.os_type);
+ ("$device", `String "dis.ml");
+ ("$browser", `String "dis.ml")
+ ]);
+ ("compress", `Bool false); (* TODO add compression handling*)
+ ("large_threshold", `Int 250);
+ ("shard", `List shards);
+ ] in
+ push_frame ~payload ~ev:IDENTIFY shard
+ >>| fun s -> s
+ end
+ | Some s ->
+ let payload = `Assoc [
+ ("token", `String !Client_options.token);
+ ("session_id", `String s);
+ ("seq", `Int shard.seq)
+ ] in
+ push_frame ~payload ~ev:RESUME shard
+
+ let handle_frame ~f shard =
+ let module J = Yojson.Safe.Util in
+ let op = J.(member "op" f |> to_int) |> Opcode.from_int in
+ match op with
+ | DISPATCH -> dispatch ~payload:f shard
+ | HEARTBEAT -> heartbeat shard
+ | INVALID_SESSION -> begin
+ Logs.err (fun m -> m "Received OP 9 on Shard [%d, %d]: %s" (fst shard.id) (snd shard.id) (Yojson.Safe.pretty_to_string f));
+ if J.(member "d" f |> to_bool) then
+ initialize shard
+ else begin
+ initialize { shard with session = None; }
+ end
+ end
+ | RECONNECT -> initialize shard
+ | HELLO -> initialize ~data:(J.member "d" f) shard
+ | HEARTBEAT_ACK -> return shard
+ | opcode ->
+ Logs.warn (fun m -> m "Invalid Opcode: %s" (Opcode.to_string opcode));
+ return shard
+
+ let rec make_client
+ ~initialized
+ ~extra_headers
+ ~app_to_ws
+ ~ws_to_app
+ ~net_to_ws
+ ~ws_to_net
+ uri =
+ client
+ ~initialized
+ ~extra_headers
+ ~app_to_ws
+ ~ws_to_app
+ ~net_to_ws
+ ~ws_to_net
+ uri
+ >>> fun res ->
+ match res with
+ | Ok () -> ()
+ | Error _ ->
+ let backoff = Time.Span.create ~ms:500 () in
+ Clock.after backoff >>> (fun () ->
+ make_client
+ ~initialized
+ ~extra_headers
+ ~app_to_ws
+ ~ws_to_app
+ ~net_to_ws
+ ~ws_to_net
+ uri)
+
+
+ let create ~url ~shards () =
+ let open Core in
+ let uri = (url ^ "?v=6&encoding=json") |> Uri.of_string in
+ let extra_headers = Http.Base.process_request_headers () in
+ let host = Option.value_exn ~message:"no host in uri" Uri.(host uri) in
+ let port =
+ match Uri.port uri, Uri_services.tcp_port_of_uri uri with
+ | Some p, _ -> p
+ | None, Some p -> p
+ | _ -> 443 in
+ let scheme = Option.value_exn ~message:"no scheme in uri" Uri.(scheme uri) in
+ let tcp_fun (net_to_ws, ws_to_net) =
+ (* Writer.monitor ws_to_net
+ |> Monitor.detach_and_get_error_stream
+ |> Stream.iter ~f:(fun e -> Logs.err (fun m -> m "Socket Connection Error: %s" (Exn.sexp_of_t e |> Sexp.to_string_hum))); *)
+ let (app_to_ws, write) = Pipe.create () in
+ let (read, ws_to_app) = Pipe.create () in
+ let initialized = Ivar.create () in
+ make_client
+ ~initialized
+ ~extra_headers
+ ~app_to_ws
+ ~ws_to_app
+ ~net_to_ws
+ ~ws_to_net
+ uri;
+ Ivar.read initialized >>| fun () ->
+ {
+ pipe = (read, write);
+ ready = Ivar.create ();
+ hb_interval = Ivar.create ();
+ seq = 0;
+ id = shards;
+ session = None;
+ url;
+ _internal = (net_to_ws, ws_to_net);
+ }
+ in
+ match Unix.getaddrinfo host (string_of_int port) [] with
+ | [] -> failwithf "DNS resolution failed for %s" host ()
+ | { ai_addr; _ } :: _ ->
+ let addr =
+ match scheme, ai_addr with
+ | _, ADDR_UNIX path -> `Unix_domain_socket path
+ | "https", ADDR_INET (h, p)
+ | "wss", ADDR_INET (h, p) ->
+ let h = Ipaddr_unix.of_inet_addr h in
+ `OpenSSL (h, p, Conduit_async.V2.Ssl.Config.create ())
+ | _, ADDR_INET (h, p) ->
+ let h = Ipaddr_unix.of_inet_addr h in
+ `TCP (h, p)
+ in
+ Conduit_async.V2.connect addr >>= tcp_fun
+
+ let shutdown_clean shard =
+ let (_,w) = shard._internal in
+ Writer.close w
+
+ let recreate shard =
+ shutdown_clean shard >>= fun () ->
+ create ~url:(shard.url) ~shards:(shard.id) ()
+end
+
+type t = {
+ shards: (Shard.shard Shard.t) list;
+}
+
+let start ?count () =
+ let module J = Yojson.Safe.Util in
+ Http.get_gateway_bot () >>= fun data ->
+ let data = match data with
+ | Ok d -> d
+ | Error e -> Error.raise e
+ in
+ let url = J.(member "url" data |> to_string) in
+ let count = match count with
+ | Some c -> c
+ | None -> J.(member "shards" data |> to_int)
+ in
+ let shard_list = (0, count) in
+ let rec ev_loop (t:Shard.shard Shard.t) =
+ let (read, _) = t.state.pipe in
+ Pipe.read read
+ >>= fun frame ->
+ (match Shard.parse frame with
+ | Some f -> begin
+ Shard.handle_frame ~f t.state
+ >>| fun s -> t.state <- s; t
+ end
+ | None -> begin
+ Shard.recreate t.state
+ >>| fun s -> t.state <- s; t
+ end)
+ >>= fun t ->
+ ev_loop t
+ in
+ let rec gen_shards l a =
+ match l with
+ | (id, total) when id >= total -> return a
+ | (id, total) ->
+ Shard.create ~url ~shards:(id, total) ()
+ >>= fun shard ->
+ let t = Shard.{ state = shard; } in
+ let _ = Ivar.read t.state.hb_interval >>> fun hb -> Clock.every ~continue_on_error:true hb (fun () -> Shard.heartbeat t.state >>> ignore) in
+ ev_loop t >>> ignore;
+ gen_shards (id+1, total) (t :: a)
+ in
+ gen_shards shard_list []
+ >>| fun shards ->
+ { shards; }
+
+let set_status ~status sharder =
+ Deferred.all @@ List.map ~f:(fun t ->
+ Shard.set_status ~status t.state
+ ) sharder.shards
+
+let set_status_with ~f sharder =
+ Deferred.all @@ List.map ~f:(fun t ->
+ Shard.set_status ~status:(f t.state) t.state
+ ) sharder.shards
+
+let request_guild_members ?query ?limit ~guild sharder =
+ Deferred.all @@ List.map ~f:(fun t ->
+ Shard.request_guild_members ~guild ?query ?limit t.state
+ ) sharder.shards
+
+let shutdown_all sharder =
+ Deferred.all @@ List.map ~f:(fun t ->
+ Shard.shutdown_clean t.state
) sharder.shards
\ No newline at end of file diff --git a/lib/sharder.mli b/lib/sharder.mli index 0bc014b..92c4178 100644 --- a/lib/sharder.mli +++ b/lib/sharder.mli @@ -1,86 +1,86 @@ -(** Internal sharding manager. Most of this is accessed through {!Client}. *) - -open Core -open Async -open Websocket_async - -exception Invalid_Payload -exception Failure_to_Establish_Heartbeat - -type t - -(** Start the Sharder. This is called by {!Client.start}. *) -val start : - ?count:int -> - unit -> - t Deferred.t - -(** Module representing a single shard. *) -module Shard : sig - (** Representation of the state of a shard. *) - type shard = { - hb_interval: Time.Span.t Ivar.t; (** Time span between heartbeats, wrapped in an Ivar. *) - seq: int; (** Current sequence number *) - session: string option; (** Session id, if one exists. *) - pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; (** Raw frame IO pipe used for websocket communications. *) - ready: unit Ivar.t; (** A simple Ivar indicating if the shard has received READY. *) - url: string; (** The websocket URL in use. *) - id: int * int; (** A tuple as expected by Discord. First element is the current shard index, second element is the total shard count. *) - _internal: Reader.t * Writer.t; - } - - (** Wrapper around an internal state, used to wrap {!shard}. *) - type 'a t = { - mutable state: 'a; - } - - (** Send a heartbeat to Discord. This is handled automatically. *) - val heartbeat : - shard -> - shard Deferred.t - - (** Set the status of the shard. *) - val set_status : - status:Yojson.Safe.json -> - shard -> - shard Deferred.t - - (** Request guild members for the shard's guild. Causes dispatch of multiple {{!Dispatch.members_chunk}member chunk} events. *) - val request_guild_members : - ?query:string -> - ?limit:int -> - guild:Snowflake.t -> - shard -> - shard Deferred.t - - (** Create a new shard *) - val create : - url:string -> - shards:int * int -> - unit -> - shard Deferred.t - - val shutdown_clean : shard -> unit Deferred.t -end - -(** Calls {!Shard.set_status} for each shard registered with the sharder. *) -val set_status : - status:Yojson.Safe.json -> - t -> - Shard.shard list Deferred.t - -(** Like {!set_status} but takes a function with a {{!Shard.shard}shard} as its parameter and {{!Yojson.Safe.json}json} for its return. *) -val set_status_with : - f:(Shard.shard -> Yojson.Safe.json) -> - t -> - Shard.shard list Deferred.t - -(** Calls {!Shard.request_guild_members} for each shard registered with the sharder. *) -val request_guild_members : - ?query:string -> - ?limit:int -> - guild:Snowflake.t -> - t -> - Shard.shard list Deferred.t - +(** Internal sharding manager. Most of this is accessed through {!Client}. *)
+
+open Core
+open Async
+open Websocket_async
+
+exception Invalid_Payload
+exception Failure_to_Establish_Heartbeat
+
+type t
+
+(** Start the Sharder. This is called by {!Client.start}. *)
+val start :
+ ?count:int ->
+ unit ->
+ t Deferred.t
+
+(** Module representing a single shard. *)
+module Shard : sig
+ (** Representation of the state of a shard. *)
+ type shard = {
+ hb_interval: Time.Span.t Ivar.t; (** Time span between heartbeats, wrapped in an Ivar. *)
+ seq: int; (** Current sequence number *)
+ session: string option; (** Session id, if one exists. *)
+ pipe: Frame.t Pipe.Reader.t * Frame.t Pipe.Writer.t; (** Raw frame IO pipe used for websocket communications. *)
+ ready: unit Ivar.t; (** A simple Ivar indicating if the shard has received READY. *)
+ url: string; (** The websocket URL in use. *)
+ id: int * int; (** A tuple as expected by Discord. First element is the current shard index, second element is the total shard count. *)
+ _internal: Reader.t * Writer.t;
+ }
+
+ (** Wrapper around an internal state, used to wrap {!shard}. *)
+ type 'a t = {
+ mutable state: 'a;
+ }
+
+ (** Send a heartbeat to Discord. This is handled automatically. *)
+ val heartbeat :
+ shard ->
+ shard Deferred.t
+
+ (** Set the status of the shard. *)
+ val set_status :
+ status:Yojson.Safe.json ->
+ shard ->
+ shard Deferred.t
+
+ (** Request guild members for the shard's guild. Causes dispatch of multiple {{!Dispatch.members_chunk}member chunk} events. *)
+ val request_guild_members :
+ ?query:string ->
+ ?limit:int ->
+ guild:Snowflake.t ->
+ shard ->
+ shard Deferred.t
+
+ (** Create a new shard *)
+ val create :
+ url:string ->
+ shards:int * int ->
+ unit ->
+ shard Deferred.t
+
+ val shutdown_clean : shard -> unit Deferred.t
+end
+
+(** Calls {!Shard.set_status} for each shard registered with the sharder. *)
+val set_status :
+ status:Yojson.Safe.json ->
+ t ->
+ Shard.shard list Deferred.t
+
+(** Like {!set_status} but takes a function with a {{!Shard.shard}shard} as its parameter and {{!Yojson.Safe.json}json} for its return. *)
+val set_status_with :
+ f:(Shard.shard -> Yojson.Safe.json) ->
+ t ->
+ Shard.shard list Deferred.t
+
+(** Calls {!Shard.request_guild_members} for each shard registered with the sharder. *)
+val request_guild_members :
+ ?query:string ->
+ ?limit:int ->
+ guild:Snowflake.t ->
+ t ->
+ Shard.shard list Deferred.t
+
val shutdown_all : t -> unit list Deferred.t
\ No newline at end of file |