Commit f6883830 authored by Adelyn Breedlove's avatar Adelyn Breedlove

Unfuck the cache

parent 93b10fe5
Pipeline #50614273 failed with stage
in 1 minute and 52 seconds
......@@ -17,14 +17,14 @@ let check_command (message:Message.t) =
| "!embed" -> Commands.embed message rest
| "!status" -> Commands.status message rest
| "!echo" -> Commands.echo message rest
(* | "!cache" -> Commands.cache message rest *)
| "!cache" -> Commands.cache message rest
| "!shutdown" -> Commands.shutdown message rest
| "!restart" -> Commands.restart message rest
| "!rgm" -> Commands.request_members message rest
(* | "!new" -> Commands.new_guild message rest *)
(* | "!delall" -> Commands.delete_guilds message rest *)
(* | "!roletest" -> Commands.role_test message rest *)
(* | "!perms" -> Commands.check_permissions message rest *)
| "!new" -> Commands.new_guild message rest
| "!delall" -> Commands.delete_guilds message rest
| "!roletest" -> Commands.role_test message rest
| "!perms" -> Commands.check_permissions message rest
| _ -> Lwt.return_unit (* Fallback case, no matched command. *)
(* Example Lwt-friendly logs setup *)
......
......@@ -78,11 +78,11 @@ let echo (message:Message.t) args =
| _ -> Lwt.return_unit
(* Output cache counts as a a basic embed. *)
(* let cache message _args =
let cache message _args =
let module C = Cache.ChannelMap in
let module G = Cache.GuildMap in
let module U = Cache.UserMap in
let cache = Mvar.peek_exn Cache.cache in
Cache.read_copy Cache.cache >>= fun cache ->
let gc = G.cardinal cache.guilds in
let ug = G.cardinal cache.unavailable_guilds in
let tc = C.cardinal cache.text_channels in
......@@ -101,7 +101,7 @@ let echo (message:Message.t) args =
Private Channels: %d\nUsers: %d\n\
Presences: %d\nCurrent User: %s"
gc ug tc vc cs gr pr uc pre user)) in
Message.reply_with ~embed message >|= ignore *)
Message.reply_with ~embed message >|= ignore
(* Issue a shutdown to all shards, then exits the process. *)
let shutdown (message:Message.t) _args =
......@@ -123,54 +123,54 @@ let request_members (message:Message.t) _args =
| None -> Lwt.return_unit
(* Creates a guild named testing or what the user provided *)
(* let new_guild message args =
let new_guild message args =
let name = List.fold ~init:"" ~f:(fun a v -> a ^ " " ^ v) args in
let name = if String.length name = 0 then "Testing" else name in
Guild.create [ "name", `String name ] >>= begin function
| Ok g -> Message.reply message (Printf.sprintf "Created guild %s" g.name)
| Error e -> Message.reply message (Printf.sprintf "Failed to create guild. Error: %s" e)
end *)
end >|= ignore
(* Deletes all guilds made by the bot *)
(* let delete_guilds message _args =
let cache = Mvar.peek_exn Cache.cache in
let delete_guilds message _args =
Cache.read_copy Cache.cache >>= fun cache ->
let uid = match cache.user with
| Some u -> u.id
| None -> `User_id 0
in
let guilds = Cache.GuildMap.filter cache.guilds ~f:(fun g -> g.owner_id = uid) in
let guilds = Cache.GuildMap.filter (fun _ (g:Guild.t) -> g.owner_id = uid) cache.guilds in
let res = ref "" in
let all = Cache.GuildMap.(map guilds ~f:(fun g -> Guild.delete g >>| function
let all = Cache.GuildMap.(map (fun g -> Guild.delete g >|= function
| Ok () -> res := Printf.sprintf "%s\nDeleted %s" !res g.name
| Error _ -> ()) |> to_alist) |> List.map ~f:(snd) in
Deferred.all all >>= (fun _ ->
Message.reply message !res) >|= ignore *)
| Error _ -> ()) guilds |> to_seq) |> Seq.map snd |> Stdlib.List.of_seq in
Lwt.join all >>= (fun _ ->
Message.reply message !res) >|= ignore
(* let role_test (message:Message.t) args =
let role_test (message:Message.t) args =
let exception Member_not_found in
let cache = Mvar.peek_exn Cache.cache in
Cache.read_copy Cache.cache >>= fun cache ->
let name = List.fold ~init:"" ~f:(fun a v -> a ^ " " ^ v) args in
let create_role name guild_id =
Guild_id.create_role ~name guild_id >>| function
Guild_id.create_role ~name guild_id >|= function
| Ok role -> role
| Error e -> Error.raise e
| Error e -> raise (Failure e)
in
let delete_role role =
Role.delete role >>| function
Role.delete role >|= function
| Ok () -> ()
| Error e -> Error.raise e
| Error e -> raise (Failure e)
in
let add_role member role =
Member.add_role ~role member >>| function
Member.add_role ~role member >|= function
| Ok () -> role
| Error e -> Error.raise e
| Error e -> raise (Failure e)
in
let remove_role member role =
Member.remove_role ~role member >>| function
Member.remove_role ~role member >|= function
| Ok () -> role
| Error e -> Error.raise e
| Error e -> raise (Failure e)
in
let get_member id = match Cache.GuildMap.find cache.guilds id with
let get_member id = match Cache.GuildMap.find_opt id cache.guilds with
| Some guild ->
begin match List.find guild.members ~f:(fun m -> m.user.id = message.author.id) with
| Some member -> member
......@@ -190,14 +190,14 @@ let request_members (message:Message.t) _args =
| Member_not_found -> Message.reply message "Error: Member not found"
| exn -> Message.reply message (Printf.sprintf "Error: %s" Error.(of_exn exn |> to_string_hum))
end >|= ignore
| None -> () *)
| None -> Lwt.return_unit
(* let check_permissions (message:Message.t) _args =
let cache = Mvar.peek_exn Cache.cache in
let check_permissions (message:Message.t) _args =
Cache.read_copy Cache.cache >>= fun cache ->
let empty = Permissions.empty in
let permissions = match message.guild_id, message.member with
| Some g, Some m ->
begin match Cache.guild cache g with
begin match Cache.guild g cache with
| Some g ->
List.fold m.roles ~init:Permissions.empty ~f:(fun acc rid ->
let role = List.find_exn g.roles ~f:(fun r -> r.id = rid) in
......@@ -226,4 +226,4 @@ let request_members (message:Message.t) _args =
|> 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 (Printf.sprintf "Global Permissions: %s\nChannel Permissions: %s" g_perms c_perms) >|= ignore
\ No newline at end of file
......@@ -2,7 +2,7 @@ module ChannelMap = Map.Make(Channel_id_t)
module GuildMap = Map.Make(Guild_id_t)
module UserMap = Map.Make(User_id_t)
type t =
type cache =
{ text_channels: Channel_t.guild_text ChannelMap.t
; voice_channels: Channel_t.guild_voice ChannelMap.t
; categories: Channel_t.category ChannelMap.t
......@@ -16,20 +16,37 @@ type t =
; users: User_t.t UserMap.t
}
type t =
{ lock: Lwt_mutex.t
; mutable cache: cache
}
let create () =
{ text_channels = ChannelMap.empty
; voice_channels = ChannelMap.empty
; categories = ChannelMap.empty
; groups = ChannelMap.empty
; private_channels = ChannelMap.empty
; guilds = GuildMap.empty
; presences = UserMap.empty
; unavailable_guilds = GuildMap.empty
; user = None
; users = UserMap.empty
}
let cache = Lwt_mvar.create (create ())
let lock = Lwt_mutex.create () in
let cache =
{ text_channels = ChannelMap.empty
; voice_channels = ChannelMap.empty
; categories = ChannelMap.empty
; groups = ChannelMap.empty
; private_channels = ChannelMap.empty
; guilds = GuildMap.empty
; presences = UserMap.empty
; unavailable_guilds = GuildMap.empty
; user = None
; users = UserMap.empty
} in
{ lock; cache }
let cache = create ()
let update ({lock; cache} as t) f =
Lwt_mutex.with_lock lock (fun () ->
let cache = f cache in
t.cache <- cache;
Lwt.return_unit)
let read_copy {lock; cache} =
Lwt_mutex.with_lock lock (fun () -> Lwt.return cache)
let guild k cache = GuildMap.find_opt k cache.guilds
......
......@@ -7,10 +7,10 @@ module GuildMap : module type of Map.Make(Guild_id_t)
(** Represents a Map of {!User_id.t} keys. *)
module UserMap : module type of Map.Make(User_id_t)
(** The full cache record. Immutable and intended to be wrapped in a concurrency-safe wrapper such as {{!Async.Mvar.Read_write.t}Mvar}.
(** The full cache record. Immutable and intended to be wrapped in a concurrency-safe wrapper.
Channels are split by type so it isn't necessary to match them later on.
*)
type t =
type cache =
{ text_channels: Channel_t.guild_text ChannelMap.t
; voice_channels: Channel_t.guild_voice ChannelMap.t
; categories: Channel_t.category ChannelMap.t
......@@ -24,8 +24,11 @@ type t =
; users: User_t.t UserMap.t
}
(** A {{!t}cache} wrapped in an {{!Async.Mvar.Read_write.t}Mvar}. *)
val cache : t Lwt_mvar.t
(** An opaque container around a mutex and cache *)
type t
(** A global t that the lib keeps up to date. You can always keep your own cache with this implementation with {!create}. *)
val cache : t
(** Creates a new, empty cache. *)
val create :
......@@ -33,44 +36,55 @@ val create :
unit ->
t
(** [update t f] locks t and calls f with the internal cache, then writes the result to the cache. *)
val update :
t ->
(cache -> cache) ->
unit Lwt.t
(** [read_copy t] awaits the lock on t, then returns a copy of the internal cache before unlocking. *)
val read_copy :
t ->
cache Lwt.t
(** Equivalent to {!GuildMap.find} on cache.guilds. *)
val guild :
Guild_id_t.t ->
t ->
cache ->
Guild_t.t option
(** Equivalent to {!ChannelMap.find} on cache.text_channels. *)
val text_channel :
Channel_id_t.t ->
t ->
cache ->
Channel_t.guild_text option
(** Equivalent to {!ChannelMap.find} on cache.voice_channels. *)
val voice_channel :
Channel_id_t.t ->
t ->
cache ->
Channel_t.guild_voice option
(** Equivalent to {!ChannelMap.find} on cache.categories. *)
val category :
Channel_id_t.t ->
t ->
cache ->
Channel_t.category option
(** Equivalent to {!ChannelMap.find} on cache.private_channels. *)
val dm :
Channel_id_t.t ->
t ->
cache ->
Channel_t.dm option
(** Equivalent to {!ChannelMap.find} on cache.groups. *)
val group :
Channel_id_t.t ->
t ->
cache ->
Channel_t.group option
(** Helper method that scans all channel stores and returns a {!Channel.t} holding the channel. *)
val channel :
Channel_id_t.t ->
t ->
cache ->
Channel_t.t option
\ No newline at end of file
open Lwt.Infix
open Event_models
type t =
......@@ -203,7 +202,6 @@ let dispatch cache ev =
cache
let handle_event ~ev contents =
Lwt_mvar.take Cache.cache >>= fun cache ->
event_of_yojson ~contents ev
|> dispatch cache
|> Lwt_mvar.put Cache.cache
\ No newline at end of file
Cache.update Cache.cache (fun cache ->
event_of_yojson ~contents ev
|> dispatch cache)
\ No newline at end of file
......@@ -43,7 +43,7 @@ type t =
val event_of_yojson : contents:Yojson.Safe.t -> string -> t
(** Sends the event to the registered handler. *)
val dispatch : Cache.t -> t -> Cache.t
val dispatch : Cache.cache -> t -> Cache.cache
(** Wrapper to other functions. This is called from the shards. *)
val handle_event : ev:string -> Yojson.Safe.t -> unit Lwt.t
\ No newline at end of file
......@@ -57,6 +57,7 @@ module Base = struct
>>= process_response path
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]"
......
......@@ -15,7 +15,7 @@ module ChannelCreate = struct
let deserialize ev =
Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap)
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let module C = Cache.ChannelMap in
match t with
| `GuildText c ->
......@@ -46,7 +46,7 @@ module ChannelDelete = struct
let deserialize ev =
Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap)
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let module C = Cache.ChannelMap in
match t with
| `GuildText c ->
......@@ -72,7 +72,7 @@ module ChannelUpdate = struct
let deserialize ev =
Channel_t.(channel_wrapper_of_yojson_exn ev |> wrap)
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let module C = Cache.ChannelMap in
match t with
| `GuildText c ->
......@@ -110,7 +110,7 @@ module ChannelPinsUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let module C = Cache.ChannelMap in
if C.mem t.channel_id cache.private_channels then
let c = C.find t.channel_id cache.private_channels in
......@@ -137,7 +137,7 @@ end
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t = ()
let update_cache (cache:Cache.cache) t = ()
end *)
(* module ChannelRecipientRemove = struct
......@@ -148,7 +148,7 @@ end *)
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t = ()
let update_cache (cache:Cache.cache) t = ()
end *)
(* TODO decide on ban caching, if any *)
......@@ -160,7 +160,7 @@ module GuildBanAdd = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module GuildBanRemove = struct
......@@ -171,7 +171,7 @@ module GuildBanRemove = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module GuildCreate = struct
......@@ -180,7 +180,7 @@ module GuildCreate = struct
let deserialize ev =
Guild_t.(pre_of_yojson_exn ev |> wrap)
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let open Channel_t in
let module C = Cache.ChannelMap in
let guilds = Cache.GuildMap.update t.id (function Some _ | None -> Some t) cache.guilds in
......@@ -233,7 +233,7 @@ module GuildDelete = struct
let deserialize = Guild_t.unavailable_of_yojson_exn
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let open Channel_t in
let module G = Cache.GuildMap in
let module C = Cache.ChannelMap in
......@@ -273,7 +273,7 @@ module GuildUpdate = struct
let deserialize ev =
Guild_t.(pre_of_yojson_exn ev |> wrap)
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let open Guild_t in
let {id; _} = t in
let guilds = Cache.GuildMap.update id (function
......@@ -290,7 +290,7 @@ module GuildEmojisUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g -> Cache.GuildMap.add t.guild_id { g with emojis = t.emojis } cache.guilds
| None -> cache.guilds in
......@@ -304,7 +304,7 @@ module GuildMemberAdd = struct
let deserialize = Member_t.of_yojson_exn
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let members = t :: g.members in
......@@ -322,7 +322,7 @@ module GuildMemberRemove = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let members = List.filter (fun (m:Member_t.t) -> m.user.id <> t.user.id) g.members in
......@@ -342,7 +342,7 @@ module GuildMemberUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let members = List.map (fun (m:Member_t.t) ->
......@@ -363,7 +363,7 @@ module GuildMembersChunk = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| None -> cache
| Some g ->
......@@ -394,7 +394,7 @@ module GuildRoleCreate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let `Guild_id guild_id = t.guild_id in
......@@ -413,7 +413,7 @@ module GuildRoleDelete = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let roles = List.filter (fun (r:Role_t.t) -> r.id <> t.role_id) g.roles in
......@@ -431,7 +431,7 @@ module GuildRoleUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let guilds = match Cache.GuildMap.find_opt t.guild_id cache.guilds with
| Some g ->
let `Guild_id guild_id = t.guild_id in
......@@ -450,7 +450,7 @@ module MessageCreate = struct
let deserialize =
Message_t.of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module MessageDelete = struct
......@@ -462,7 +462,7 @@ module MessageDelete = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module MessageUpdate = struct
......@@ -490,7 +490,7 @@ module MessageUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module MessageDeleteBulk = struct
......@@ -502,7 +502,7 @@ module MessageDeleteBulk = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module PresenceUpdate = struct
......@@ -510,7 +510,7 @@ module PresenceUpdate = struct
let deserialize = Presence.of_yojson_exn
let update_cache (cache:Cache.t) (t:t) =
let update_cache (cache:Cache.cache) (t:t) =
let id = t.user.id in
let presences = Cache.UserMap.add id t cache.presences in
{ cache with presences }
......@@ -533,7 +533,7 @@ module ReactionAdd = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module ReactionRemove = struct
......@@ -547,7 +547,7 @@ module ReactionRemove = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module ReactionRemoveAll = struct
......@@ -559,7 +559,7 @@ module ReactionRemoveAll = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module Ready = struct
......@@ -573,7 +573,7 @@ module Ready = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let unavailable_guilds =
List.map (fun (g:Guild_t.unavailable) -> g.id, g) t.guilds
|> List.to_seq |> Cache.GuildMap.of_seq
......@@ -594,7 +594,7 @@ module Resumed = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module TypingStart = struct
......@@ -607,7 +607,7 @@ module TypingStart = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module UserUpdate = struct
......@@ -615,7 +615,7 @@ module UserUpdate = struct
let deserialize = User_t.of_yojson_exn
let update_cache (cache:Cache.t) t =
let update_cache (cache:Cache.cache) t =
let user = Some t in
{ cache with user }
end
......@@ -628,7 +628,7 @@ module WebhookUpdate = struct
let deserialize = of_yojson_exn
let update_cache (cache:Cache.t) _t = cache
let update_cache (cache:Cache.cache) _t = cache
end
module Unknown = struct
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment