152 lines
3.7 KiB
OCaml
152 lines
3.7 KiB
OCaml
let random_state = Random.State.make_self_init ()
|
|
|
|
module Id = struct
|
|
type t = Uuidm.t
|
|
|
|
let create () =
|
|
(* TODO: use a CSPRNG *)
|
|
Uuidm.v4_gen random_state ()
|
|
|
|
let equal = Uuidm.equal
|
|
|
|
let hash (t : t) = Hashtbl.hash t
|
|
|
|
let of_string = Uuidm.of_string
|
|
|
|
let to_string = Uuidm.to_string ~upper:false
|
|
|
|
let pp = Uuidm.pp
|
|
end
|
|
|
|
type t =
|
|
{ id : Id.t
|
|
; mutable expires_at : Ptime.t
|
|
; mutable payload : (string * string) list
|
|
}
|
|
|
|
module Tbl : sig
|
|
val find : Id.t -> t option
|
|
|
|
val add : Id.t -> t -> unit
|
|
|
|
val remove : Id.t -> unit
|
|
end = struct
|
|
include Hashtbl.Make (Id)
|
|
|
|
let tbl = create 512
|
|
|
|
let mutex = Mutex.create ()
|
|
|
|
let finally () = Mutex.unlock mutex
|
|
|
|
let find key =
|
|
Mutex.lock mutex;
|
|
Fun.protect ~finally (fun () -> find_opt tbl key)
|
|
|
|
let add key value =
|
|
Mutex.lock mutex;
|
|
Fun.protect ~finally (fun () -> replace tbl key value)
|
|
|
|
let remove key =
|
|
Mutex.lock mutex;
|
|
Fun.protect ~finally (fun () -> remove tbl key)
|
|
end
|
|
|
|
let now () = Ptime.v (Ptime_clock.now_d_ps ())
|
|
|
|
let two_weeks =
|
|
match Ptime.Span.of_float_s (60. *. 60. *. 24. *. 7. *. 2.) with
|
|
| None -> assert false
|
|
| Some span -> span
|
|
|
|
let one_week =
|
|
match Ptime.Span.of_float_s (60. *. 60. *. 24. *. 7.) with
|
|
| None -> assert false
|
|
| Some span -> span
|
|
|
|
let create () =
|
|
let id = Id.create () in
|
|
let expires_at = Ptime.add_span (now ()) two_weeks in
|
|
let expires_at =
|
|
match expires_at with None -> assert false | Some expires_at -> expires_at
|
|
in
|
|
let payload = [] in
|
|
{ id; expires_at; payload }
|
|
|
|
let load request =
|
|
let now = now () in
|
|
let valid_session =
|
|
let session_id = Cookie.get ~decrypt:false request "drame.session" in
|
|
match session_id with
|
|
| None -> None
|
|
| Some session_id -> (
|
|
match Id.of_string session_id with
|
|
| None -> None
|
|
| Some session_id -> (
|
|
match Tbl.find session_id with
|
|
| None -> None
|
|
| Some { id; expires_at; _ } as session ->
|
|
let is_valid = Ptime.is_earlier now ~than:expires_at in
|
|
if is_valid then session
|
|
else begin
|
|
Tbl.remove id;
|
|
None
|
|
end ) )
|
|
in
|
|
match valid_session with
|
|
| None ->
|
|
let session = create () in
|
|
Tbl.add session.id session;
|
|
session
|
|
| Some ({ expires_at; _ } as session) ->
|
|
let renew_date =
|
|
match Ptime.sub_span expires_at one_week with
|
|
| None -> assert false
|
|
| Some span -> span
|
|
in
|
|
if Ptime.is_earlier now ~than:renew_date then session
|
|
else begin
|
|
let expires_at =
|
|
match Ptime.add_span now two_weeks with
|
|
| None -> assert false
|
|
| Some date -> date
|
|
in
|
|
session.expires_at <- expires_at;
|
|
session
|
|
end
|
|
|
|
let get request key =
|
|
let { payload; _ } = load request in
|
|
List.assoc_opt key payload
|
|
|
|
let set request key value =
|
|
let ({ payload; _ } as session) = load request in
|
|
let payload = List.remove_assoc key payload in
|
|
let payload = (key, value) :: payload in
|
|
session.payload <- payload
|
|
|
|
let drop request key =
|
|
let ({ payload; _ } as session) = load request in
|
|
let payload = List.remove_assoc key payload in
|
|
session.payload <- payload
|
|
|
|
let invalidate request =
|
|
let { id; _ } = load request in
|
|
Tbl.remove id
|
|
|
|
let make_send_headers session =
|
|
let value = Id.to_string session.id in
|
|
let max_age = Ptime.diff session.expires_at (now ()) in
|
|
let max_age = Option.some @@ Ptime.Span.to_float_s max_age in
|
|
Cookie.make_set_headers ~encrypt:false ~max_age ~key:"drame.session" ~value
|
|
|
|
let pp fmt request =
|
|
let { id; expires_at; payload } = load request in
|
|
Fmt.pf fmt "id = %a ; expires_at = %a ; payload:@\n @[<v>" Id.pp id Ptime.pp
|
|
expires_at;
|
|
Fmt.list
|
|
~sep:(fun fmt () -> Fmt.string fmt "@\n")
|
|
(fun fmt (k, v) -> Fmt.pf fmt "%s = %s" k v)
|
|
fmt payload;
|
|
Fmt.pf fmt "@]"
|