storage.ml

open Utils.Json

let current_version = 5
(* version history:
   1 was initial (fields until email_verification_uuid)
   2 added active
   3 added super_user (but did not serialise it)
   4 properly serialised super_user
   5 cookie has two new fields last_access and user_agent
*)

let t_to_json users configuration =
  `Assoc
    [
      ("version", `Int current_version);
      ("users", `List (List.map User_model.user_to_json users));
      ("configuration", Configuration.to_json configuration);
    ]

let t_of_json json =
  match json with
  | `Assoc xs -> (
      let ( let* ) = Result.bind in
      match (get "version" xs, get "users" xs, get "configuration" xs) with
      | Some (`Int v), Some (`List users), Some configuration ->
          let* () =
            if v = current_version then Ok ()
            else if v = 4 then Ok ()
            else if v = 3 then Ok ()
            else if v = 2 then Ok ()
            else if v = 1 then Ok ()
            else
              Error
                (`Msg
                  (Fmt.str "expected version %u, found version %u"
                     current_version v))
          in
          let* users =
            List.fold_left
              (fun acc js ->
                let* acc = acc in
                let* user =
                  if v = 1 then User_model.user_v1_of_json js
                  else if v = 2 || v = 3 then User_model.user_v2_of_json js
                  else if v = 4 then
                    User_model.(user_of_json cookie_v1_of_json) js
                  else User_model.(user_of_json cookie_of_json) js
                in
                Ok (user :: acc))
              (Ok []) users
          in
          let* configuration = Configuration.of_json configuration in
          Ok (users, configuration)
      | _ -> Error (`Msg "invalid data: no version and users field"))
  | _ -> Error (`Msg "invalid data: not an assoc")

let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt

module Make (BLOCK : Mirage_block.S) = struct
  module Stored_data = OneFFS.Make (BLOCK)
  open Lwt.Infix

  type t = {
    disk : Stored_data.t;
    mutable users : User_model.user list;
    mutable configuration : Configuration.t;
  }

  let write_data t =
    Stored_data.write t.disk
      (Yojson.Basic.to_string (t_to_json t.users t.configuration))

  let read_data disk =
    Stored_data.read disk >|= function
    | Ok (Some s) ->
        let ( let* ) = Result.bind in
        let* json =
          try Ok (Yojson.Basic.from_string s)
          with Yojson.Json_error msg -> Error (`Msg ("Invalid json: " ^ msg))
        in
        let* t = t_of_json json in
        Ok t
    | Ok None -> Ok ([], Configuration.empty ())
    | Error e ->
        error_msgf "error while reading storage: %a" Stored_data.pp_error e

  let connect block =
    Stored_data.connect block >>= fun disk ->
    read_data disk >|= function
    | Error _ as e -> e
    | Ok (users, configuration) -> Ok { disk; users; configuration }

  let configuration { configuration; _ } = configuration

  let update_configuration t (configuration : Configuration.t) =
    let t' = { t with configuration } in
    write_data t' >|= function
    | Ok () ->
        t.configuration <- configuration;
        Ok ()
    | Error we ->
        error_msgf "error while writing storage: %a" Stored_data.pp_write_error
          we

  let add_user t user =
    let t' = { t with users = user :: t.users } in
    write_data t' >|= function
    | Ok () ->
        t.users <- user :: t.users;
        Ok ()
    | Error we ->
        error_msgf "error while writing storage: %a" Stored_data.pp_write_error
          we

  let update_user t (user : User_model.user) =
    let users =
      List.map
        (fun (u : User_model.user) ->
          match u.uuid = user.uuid with true -> user | false -> u)
        t.users
    in
    let t' = { t with users } in
    write_data t' >|= function
    | Ok () ->
        t.users <- users;
        Ok ()
    | Error we ->
        error_msgf "error while writing storage: %a" Stored_data.pp_write_error
          we

  let users { users; _ } = users

  let find_by_email store email =
    List.find_opt
      (fun user -> String.equal user.User_model.email email)
      store.users

  let find_by_name store name =
    List.find_opt
      (fun user -> String.equal user.User_model.name name)
      store.users

  let find_by_uuid store uuid =
    List.find_opt
      (fun user -> String.equal user.User_model.uuid uuid)
      store.users

  let find_by_cookie store cookie_value =
    List.fold_left
      (fun acc user ->
        match acc with
        | Some _ as s -> s
        | None -> (
            match
              List.find_opt
                (fun (cookie : User_model.cookie) ->
                  String.equal User_model.session_cookie cookie.User_model.name
                  && String.equal cookie_value cookie.value)
                user.User_model.cookies
            with
            | None -> None
            | Some c -> Some (user, c)))
      None store.users

  let count_users store = List.length store.users

  let find_email_verification_token store uuid =
    List.find_opt
      (fun user ->
        Option.fold ~none:false
          ~some:(fun uu -> Uuidm.equal uu uuid)
          user.User_model.email_verification_uuid)
      store.users

  let count_active store =
    List.length (List.filter (fun u -> u.User_model.active) store.users)

  let count_superusers store =
    List.length (List.filter (fun u -> u.User_model.super_user) store.users)
end