...
 
Commits (3)
......@@ -194,13 +194,15 @@ let role_test (message:Message.t) args =
let check_permissions (message:Message.t) _args =
Cache.read_copy Cache.cache >>= fun cache ->
let itemized = ref "" in
let empty = Permissions.empty in
let permissions = match message.guild_id, message.member with
| Some g, Some m ->
begin match Cache.guild g cache with
| Some g ->
List.fold m.roles ~init:Permissions.empty ~f:(fun acc rid ->
List.fold m.roles ~init:empty ~f:(fun acc rid ->
let role = List.find_exn g.roles ~f:(fun r -> r.id = rid) in
itemized := !itemized ^ "\n" ^ (Permissions.to_int role.permissions |> string_of_int);
Permissions.union acc role.permissions)
| None -> empty
end
......@@ -218,12 +220,13 @@ let check_permissions (message:Message.t) _args =
| None -> empty, empty
end
| None -> empty, empty in
let g_perms = Permissions.elements permissions
let _g_perms = Permissions.elements permissions
|> List.sexp_of_t Permissions.sexp_of_elt
|> Sexplib.Sexp.to_string_hum in
let c_perms = Permissions.(union permissions allow
let _c_perms = Permissions.(union permissions allow
|> diff deny
|> elements)
|> List.sexp_of_t Permissions.sexp_of_elt
|> Sexplib.Sexp.to_string_hum in
Message.reply message (Printf.sprintf "Global Permissions: %s\nChannel Permissions: %s" g_perms c_perms) >|= ignore
\ No newline at end of file
Message.reply message !itemized >|= ignore
(* Message.reply message (Printf.sprintf "Global Permissions: %s\nChannel Permissions: %s" g_perms c_perms) >|= ignore *)
\ No newline at end of file
......@@ -31,6 +31,7 @@ depends: [
"websocket-lwt" {>= "2.12"}
"yojson" {>= "1.6.0"}
"bitmasks" {>= "1.1.0"}
"calendar" {>= "2.04"}
]
build: [
["dune" "subst"] {pinned}
......
......@@ -22,7 +22,7 @@
event_models
cache client client_options disml dispatch endpoints event http opcode rl sharder
)
(libraries str checkseum.ocaml base lwt_ssl cohttp-lwt decompress yojson websocket-lwt ppx_deriving_yojson.runtime bitmasks)
(libraries str checkseum.ocaml base lwt_ssl cohttp-lwt decompress yojson websocket-lwt ppx_deriving_yojson.runtime bitmasks calendar)
(preprocess (pps ppx_sexp_conv ppx_deriving_yojson)))
(include_subdirs unqualified)
open Printf
let gateway = "/gateway"
let gateway_bot = "/gateway/bot"
let channel = sprintf "/channels/%d"
let channel_messages = sprintf "/channels/%d/messages"
let channel_message = sprintf "/channels/%d/messages/%d"
let channel_reaction_me = sprintf "/channels/%d/messages/%d/reactions/%s/@me"
let channel_reaction = sprintf "/channels/%d/messages/%d/reactions/%s/%d"
let channel_reactions_get = sprintf "/channels/%d/messages/%d/reactions/%s"
let channel_reactions_delete = sprintf "/channels/%d/messages/%d/reactions"
let channel_bulk_delete = sprintf "/channels/%d"
let channel_permission = sprintf "/channels/%d/permissions/%d"
let channel_permissions = sprintf "/channels/%d/permissions"
let channels = "/channels"
let channel_call_ring = sprintf "/channels/%d/call/ring"
let channel_invites = sprintf "/channels/%d/invites"
let channel_typing = sprintf "/channels/%d/typing"
let channel_pins = sprintf "/channels/%d/pins"
let channel_pin = sprintf "/channels/%d/pins/%d"
let guilds = "/guilds"
let guild = sprintf "/guilds/%d"
let guild_channels = sprintf "/guilds/%d/channels"
let guild_members = sprintf "/guilds/%d/members"
let guild_member = sprintf "/guilds/%d/members/%d"
let guild_member_role = sprintf "/guilds/%d/members/%d/roles/%d"
let guild_bans = sprintf "/guilds/%d/bans"
let guild_ban = sprintf "/guilds/%d/bans/%d"
let guild_roles = sprintf "/guilds/%d/roles"
let guild_role = sprintf "/guilds/%d/roles/%d"
let guild_prune = sprintf "/guilds/%d/prune"
let guild_voice_regions = sprintf "/guilds/%d/regions"
let guild_invites = sprintf "/guilds/%d/invites"
let guild_integrations = sprintf "/guilds/%d/integrations"
let guild_integration = sprintf "/guilds/%d/integrations/%d"
let guild_integration_sync = sprintf "/guilds/%d/integrations/%d/sync"
let guild_embed = sprintf "/guilds/%d/embed"
let guild_emojis = sprintf "/guilds/%d/emojis"
let guild_emoji = sprintf "/guilds/%d/emojis/%d"
let webhooks_guild = sprintf "/guilds/%d/webhooks"
let webhooks_channel = sprintf "/channels/%d/webhooks"
let webhook = sprintf "/webhooks/%d"
let webhook_token = sprintf "/webhooks/%d/%s"
let webhook_git = sprintf "/webhooks/%d/%s/github"
let webhook_slack = sprintf "/webhooks/%d/%s/slack"
let user = sprintf "/users/%d"
let me = "/users/@me"
let me_guilds = "/users/@me/guilds"
let me_guild = sprintf "/users/@me/guilds/%d"
let me_channels = "/users/@me/channels"
let me_connections = "/users/@me/connections"
let invite = sprintf "/invites/%s"
let regions = "/voice/regions"
let application_information = "/oauth2/applications/@me"
let group_recipient = sprintf "/channels/%d/recipients/%d"
let guild_me_nick = sprintf "/guilds/%d/members/@me/nick"
let guild_vanity_url = sprintf "/guilds/%d/vanity-url"
let guild_audit_logs = sprintf "/guilds/%d/audit-logs"
let cdn_embed_avatar = sprintf "/embed/avatars/%s.png"
let cdn_emoji = sprintf "/emojis/%s.%s"
let cdn_icon = sprintf "/icons/%d/%s.%s"
let cdn_avatar = sprintf "/avatars/%d/%s.%s"
let cdn_default_avatar = sprintf "/embed/avatars/%d"
\ No newline at end of file
type t =
{ endpoint: string
; route: string
}
let make endpoint = { endpoint; route = endpoint }
(* let make_complex endpoint route = { endpoint; route } *)
let gateway = make "/gateway"
let gateway_bot = make "/gateway/bot"
let channel cid =
make (sprintf "/channels/%d" cid)
let channel_messages cid =
make (sprintf "/channels/%d/messages" cid)
let channel_message cid mid =
make (sprintf "/channels/%d/messages/%d" cid mid)
let channel_reaction_me cid mid em =
make (sprintf "/channels/%d/messages/%d/reactions/%s/@me" cid mid em)
let channel_reaction cid mid em uid =
make (sprintf "/channels/%d/messages/%d/reactions/%s/%d" cid mid em uid)
let channel_reactions_get cid mid em =
make (sprintf "/channels/%d/messages/%d/reactions/%s" cid mid em)
let channel_reactions_delete cid mid =
make (sprintf "/channels/%d/messages/%d/reactions" cid mid)
let channel_bulk_delete cid =
make (sprintf "/channels/%d" cid)
let channel_permission cid uid =
make (sprintf "/channels/%d/permissions/%d" cid uid)
let channel_permissions cid =
make (sprintf "/channels/%d/permissions" cid)
let channels = make "/channels"
let channel_call_ring cid =
make (sprintf "/channels/%d/call/ring" cid)
let channel_invites cid =
make (sprintf "/channels/%d/invites" cid)
let channel_typing cid =
make (sprintf "/channels/%d/typing" cid)
let channel_pins cid =
make (sprintf "/channels/%d/pins" cid)
let channel_pin cid mid =
make (sprintf "/channels/%d/pins/%d" cid mid)
let guilds = make "/guilds"
let guild gid =
make (sprintf "/guilds/%d" gid)
let guild_channels gid =
make (sprintf "/guilds/%d/channels" gid)
let guild_members gid =
make (sprintf "/guilds/%d/members" gid)
let guild_member gid uid =
make (sprintf "/guilds/%d/members/%d" gid uid)
let guild_member_role gid uid rid =
make (sprintf "/guilds/%d/members/%d/roles/%d" gid uid rid)
let guild_bans gid =
make (sprintf "/guilds/%d/bans" gid)
let guild_ban gid uid =
make (sprintf "/guilds/%d/bans/%d" gid uid)
let guild_roles gid =
make (sprintf "/guilds/%d/roles" gid)
let guild_role gid rid =
make (sprintf "/guilds/%d/roles/%d" gid rid)
let guild_prune gid =
make (sprintf "/guilds/%d/prune" gid)
let guild_voice_regions gid =
make (sprintf "/guilds/%d/regions" gid)
let guild_invites gid =
make (sprintf "/guilds/%d/invites" gid)
let guild_integrations gid =
make (sprintf "/guilds/%d/integrations" gid)
let guild_integration gid iid =
make (sprintf "/guilds/%d/integrations/%d" gid iid)
let guild_integration_sync gid iid =
make (sprintf "/guilds/%d/integrations/%d/sync" gid iid)
let guild_embed gid =
make (sprintf "/guilds/%d/embed" gid)
let guild_emojis gid =
make (sprintf "/guilds/%d/emojis" gid)
let guild_emoji gid eid =
make (sprintf "/guilds/%d/emojis/%d" gid eid)
let guild_me_nick gid =
make (sprintf "/guilds/%d/members/@me/nick" gid)
let guild_vanity_url gid =
make (sprintf "/guilds/%d/vanity-url" gid)
let guild_audit_logs gid =
make (sprintf "/guilds/%d/audit-logs" gid)
let webhooks_guild gid =
make (sprintf "/guilds/%d/webhooks" gid)
let webhooks_channel cid =
make (sprintf "/channels/%d/webhooks" cid)
let webhook wid =
make (sprintf "/webhooks/%d" wid)
let webhook_token wid token =
make (sprintf "/webhooks/%d/%s" wid token)
let webhook_git wid token =
make (sprintf "/webhooks/%d/%s/github" wid token)
let webhook_slack wid token =
make (sprintf "/webhooks/%d/%s/slack" wid token)
let user uid =
make (sprintf "/users/%d" uid)
let me = make "/users/@me"
let me_guilds = make "/users/@me/guilds"
let me_guild gid =
make (sprintf "/users/@me/guilds/%d" gid)
let me_channels = make "/users/@me/channels"
let me_connections = make "/users/@me/connections"
let invite iid =
make (sprintf "/invites/%s" iid)
let regions = make "/voice/regions"
let application_information = make "/oauth2/applications/@me"
let group_recipient cid uid =
make (sprintf "/channels/%d/recipients/%d" cid uid)
let cdn_embed_avatar hash =
make (sprintf "/embed/avatars/%s.png" hash)
let cdn_emoji hash ext =
make (sprintf "/emojis/%s.%s" hash ext)
let cdn_icon uid hash ext =
make (sprintf "/icons/%d/%s.%s" uid hash ext)
let cdn_avatar uid hash ext =
make (sprintf "/avatars/%d/%s.%s" uid hash ext)
let cdn_default_avatar ind =
make (sprintf "/embed/avatars/%d" ind)
\ No newline at end of file
(** Endpoint formatters used internally. *)
val gateway : string
val gateway_bot : string
val channel : int -> string
val channel_messages : int -> string
val channel_message : int -> int -> string
val channel_reaction_me : int -> int -> string -> string
val channel_reaction : int -> int -> string -> int -> string
val channel_reactions_get : int -> int -> string -> string
val channel_reactions_delete : int -> int -> string
val channel_bulk_delete : int -> string
val channel_permission : int -> int -> string
val channel_permissions : int -> string
val channels : string
val channel_call_ring : int -> string
val channel_invites : int -> string
val channel_typing : int -> string
val channel_pins : int -> string
val channel_pin : int -> int -> string
val guilds : string
val guild : int -> string
val guild_channels : int -> string
val guild_members : int -> string
val guild_member : int -> int -> string
val guild_member_role : int -> int -> int -> string
val guild_bans : int -> string
val guild_ban : int -> int -> string
val guild_roles : int -> string
val guild_role : int -> int -> string
val guild_prune : int -> string
val guild_voice_regions : int -> string
val guild_invites : int -> string
val guild_integrations : int -> string
val guild_integration : int -> int -> string
val guild_integration_sync : int -> int -> string
val guild_embed : int -> string
val guild_emojis : int -> string
val guild_emoji : int -> int -> string
val webhooks_guild : int -> string
val webhooks_channel : int -> string
val webhook : int -> string
val webhook_token : int -> string -> string
val webhook_git : int -> string -> string
val webhook_slack : int -> string -> string
val user : int -> string
val me : string
val me_guilds : string
val me_guild : int -> string
val me_channels : string
val me_connections : string
val invite : string -> string
val regions : string
val application_information : string
val group_recipient : int -> int -> string
val guild_me_nick : int -> string
val guild_vanity_url : int -> string
val guild_audit_logs : int -> string
val cdn_embed_avatar : string -> string
val cdn_emoji : string -> string -> string
val cdn_icon : int -> string -> string -> string
val cdn_avatar : int -> string -> string -> string
val cdn_default_avatar : int -> string
\ No newline at end of file
type t =
{ endpoint: string
; route: string
}
val gateway : t
val gateway_bot : t
val channel : int -> t
val channel_messages : int -> t
val channel_message : int -> int -> t
val channel_reaction_me : int -> int -> string -> t
val channel_reaction : int -> int -> string -> int -> t
val channel_reactions_get : int -> int -> string -> t
val channel_reactions_delete : int -> int -> t
val channel_bulk_delete : int -> t
val channel_permission : int -> int -> t
val channel_permissions : int -> t
val channels : t
val channel_call_ring : int -> t
val channel_invites : int -> t
val channel_typing : int -> t
val channel_pins : int -> t
val channel_pin : int -> int -> t
val guilds : t
val guild : int -> t
val guild_channels : int -> t
val guild_members : int -> t
val guild_member : int -> int -> t
val guild_member_role : int -> int -> int -> t
val guild_bans : int -> t
val guild_ban : int -> int -> t
val guild_roles : int -> t
val guild_role : int -> int -> t
val guild_prune : int -> t
val guild_voice_regions : int -> t
val guild_invites : int -> t
val guild_integrations : int -> t
val guild_integration : int -> int -> t
val guild_integration_sync : int -> int -> t
val guild_embed : int -> t
val guild_emojis : int -> t
val guild_emoji : int -> int -> t
val webhooks_guild : int -> t
val webhooks_channel : int -> t
val webhook : int -> t
val webhook_token : int -> string -> t
val webhook_git : int -> string -> t
val webhook_slack : int -> string -> t
val user : int -> t
val me : t
val me_guilds : t
val me_guild : int -> t
val me_channels : t
val me_connections : t
val invite : string -> t
val regions : t
val application_information : t
val group_recipient : int -> int -> t
val guild_me_nick : int -> t
val guild_vanity_url : int -> t
val guild_audit_logs : int -> t
val cdn_embed_avatar : string -> t
val cdn_emoji : string -> string -> t
val cdn_icon : int -> string -> string -> t
val cdn_avatar : int -> string -> string -> t
val cdn_default_avatar : int -> t
\ No newline at end of file
......@@ -40,12 +40,12 @@ module Base = struct
Logs_lwt.warn (fun m -> m "[Unsuccessful Response] [Code: %d]\n%s\n%s" code body headers) >>= fun () ->
Lwt_result.fail @@ Printf.sprintf "Unsuccessful response received: %d - %s" code body
let request ?(body=`Null) ?(query=[]) m path =
let limit, rlm = Rl.get_rl m path !rl in
let request ?(body=`Null) ?(query=[]) m (endpoint:Endpoints.t) =
let limit, rlm = Rl.get_rl m endpoint.route !rl in
rl := rlm;
Lwt_mvar.take limit >>= fun limit ->
let process () =
let uri = Uri.add_query_params' (process_url path) query in
let uri = Uri.add_query_params' (process_url endpoint.endpoint) query in
let headers = process_request_headers () in
let body = process_request_body body in
(match m with
......@@ -54,14 +54,14 @@ module Base = struct
| `Patch -> Cohttp_lwt_unix.Client.patch ~headers ~body uri
| `Post -> Cohttp_lwt_unix.Client.post ~headers ~body uri
| `Put -> Cohttp_lwt_unix.Client.put ~headers ~body uri)
>>= process_response path
>>= process_response endpoint.endpoint
in if limit.remaining > 0 then process ()
else
(* TODO use Date header instead of unix time *)
let time = float_of_int limit.reset -. Unix.time () in
Logs_lwt.info (fun m -> m
"Rate-limiting [Route: %s] [Duration: %f s]"
path time) >>= fun () ->
endpoint.route time) >>= fun () ->
Lwt_unix.sleep time >>= process
end
......
......@@ -16,7 +16,7 @@ module Base : sig
?body:Yojson.Safe.t ->
?query:(string * string) list ->
[ `Delete | `Get | `Patch | `Post | `Put ] ->
string ->
Endpoints.t ->
(Yojson.Safe.t, string) Lwt_result.t
end
......
......@@ -36,6 +36,8 @@ include BitMaskSet.Make(struct
let mask = 0b0111_1111_1111_0111_1111_1101_1111_1111
end)
let to_int (t:t) : int = t
let sexp_of_t = Base.Int.sexp_of_t
let t_of_sexp = Base.Int.t_of_sexp
......
......@@ -34,6 +34,7 @@ include BitMaskSet.S with type elt := elt
with type storage = int
with type t = private int
val to_int : t -> int
val sexp_of_t : t -> Sexplib.Sexp.t
val t_of_sexp : Sexplib.Sexp.t -> t
val of_yojson_exn : Yojson.Safe.t -> t
......
......@@ -7,7 +7,7 @@ val tag : t -> string
val mention : t -> string
(** The default avatar for the user. *)
val default_avatar : t -> string
val default_avatar : t -> Endpoints.t
(** The avatar url of the user, falling back to the default avatar. *)
val face : t -> string
\ No newline at end of file
val face : t -> Endpoints.t
\ No newline at end of file