(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2023 Inria                                           *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

open Lwt.Syntax
open Belenios
open Belenios_web_api
open Belenios_storage_api
open Belenios_server_core
open Web_common

let ( let& ) = Option.bind

type token = { expiration : float; account : account; user : user }

let tokens = ref SMap.empty

let new_token account user : auth_token Lwt.t =
  let token = generate_token ~length:22 () in
  let expiration = Unix.gettimeofday () +. 86400. in
  tokens := SMap.add token { expiration; account; user } !tokens;
  Lwt.return { token; expiration }

let filter tokens =
  let now = Unix.gettimeofday () in
  SMap.filter (fun _ { expiration; _ } -> now < expiration) tokens

let lookup_token token =
  tokens := filter !tokens;
  let& { account; user; _ } = SMap.find_opt token !tokens in
  Some (account, user)

let invalidate_token token = tokens := SMap.remove token !tokens

let () =
  let@ a = Accounts.add_update_hook in
  let f { expiration; account; user } =
    let account = if a.id = account.id then a else account in
    { expiration; account; user }
  in
  tokens := SMap.map f !tokens;
  Lwt.return_unit

exception Error of Belenios_web_api.error

type generic_content = String of string | Path of string
type generic = { mime : string; content : generic_content }

type result =
  [ `Json of int * string
  | `Bel of string
  | `Sealing_log of string
  | `Generic of generic ]

type body = { run : 'a. (string -> 'a) -> ('a -> result Lwt.t) -> result Lwt.t }

let return_json code x = Lwt.return @@ `Json (code, x)
let return_yojson code x = return_json code (Yojson.Safe.to_string x)
let return_generic x = Lwt.return @@ `Generic x
let ok = return_json 200 "{}"
let bad_request = return_json 400 {|"Bad Request"|}
let unauthorized = return_json 401 {|"Unauthorized"|}
let forbidden = return_json 403 {|"Forbidden"|}
let not_found = return_json 404 {|"Not Found"|}
let method_not_allowed = return_json 405 {|"Method Not Allowed"|}
let precondition_failed = return_json 412 {|"Precondition Failed"|}
let conflict = return_json 409 {|"Conflict"|}
let request_entity_too_large = return_json 413 {|"Request Entity Too Large"|}
let service_unavailable = return_json 503 {|"Service Unavailable"|}

let handle_ifmatch ifmatch current cont =
  match ifmatch with
  | None -> cont ()
  | Some x ->
      let* current = current () in
      if sha256_b64 current = x then cont () else precondition_failed

let handle_generic_error f =
  Lwt.catch f (function
    | Error error ->
        let request_status = { code = 400; status = "Bad Request"; error } in
        return_json 400 (string_of_request_status request_status)
    | Readonly_storage ->
        let request_status =
          {
            code = 503;
            status = "Service Unavailable";
            error = `ReadonlyStorage;
          }
        in
        return_json 503 (string_of_request_status request_status)
    | exn ->
        let error = `GenericError (Printexc.to_string exn) in
        let request_status =
          { code = 500; status = "Internal Server Error"; error }
        in
        return_json 500 (string_of_request_status request_status))

let handle_get get =
  let@ () = handle_generic_error in
  let* x = get () in
  return_json 200 x

let handle_get_option get =
  let@ () = handle_generic_error in
  let* x = get () in
  match x with None -> not_found | Some x -> return_json 200 x

let get_configuration_uris () =
  {
    home = !Web_config.prefix ^ "/";
    belenios = Belenios_ui.Links.belenios;
    tos = !Web_config.tos;
  }

let get_configuration () =
  let open Defaults in
  {
    restricted_mode = !Web_config.restricted_mode;
    vendor = !Web_config.vendor;
    tos_last_update = !Web_config.tos_last_update;
    uris = get_configuration_uris ();
    belenios_version = Version.version;
    belenios_build = Version.build;
    spec_version = Version.spec;
    api_version = 6;
    supported_crypto_versions =
      (let open Belenios.Election in
       List.map
         (function Version v -> int_of_version v)
         supported_crypto_versions);
    supported_booth_versions;
    authentications =
      List.map
        (function
          | Web_config.BuiltinCAS -> `CAS
          | Export a ->
              `Configured
                {
                  configured_instance = a.config.auth_instance;
                  configured_system = a.config.auth_system;
                  configured_descr = a.descr;
                })
        !Web_config.exported_auth_config;
    default_group = !Web_config.default_group;
    default_nh_group = !Web_config.nh_group;
    max_voters = !Web_config.maxmailsatonce;
    languages = Language.available;
    election_sealing = !Web_config.election_sealing;
    grace_period = !Web_config.grace_period;
  }

let get_account (a : account) (u : user) =
  let service = u.user_domain in
  let portal =
    let rec loop = function
      | [] -> None
      | { auth_instance; auth_portal; _ } :: xs ->
          if auth_instance = service then auth_portal else loop xs
    in
    loop !Web_config.site_auth_config
  in
  {
    id = a.id;
    authentication_method = { service; username = u.user_name; portal };
    name = a.name;
    address = a.email;
    language = a.language;
    default_voter_languages = a.default_voter_languages;
    default_contact = a.default_contact;
    voters_limit = a.voters_limit;
  }

let put_account ((a, set) : account updatable) (u : user) (b : api_account) =
  if b.address <> a.email then raise (Error (`CannotChange "address"));
  if b.id <> a.id then raise (Error (`CannotChange "id"));
  if
    not
      (b.authentication_method.service = u.user_domain
      && b.authentication_method.username = u.user_name)
  then raise (Error (`CannotChange "authentication_method"));
  let a =
    {
      a with
      name = b.name;
      language = b.language;
      default_voter_languages = b.default_voter_languages;
      default_contact = b.default_contact;
    }
  in
  set a

module HMap = Map.Make (Hash)

let msgcache = ref HMap.empty

let filter_msgcache ~now cache =
  HMap.filter (fun _ timestamp -> now < timestamp +. 600.) cache

let post_send_message ?internal ~key (m : Belenios_messages.message_payload) =
  let now = Unix.gettimeofday () in
  let cache = filter_msgcache ~now !msgcache in
  msgcache := cache;
  if now < m.timestamp +. 600. then
    match m.hmac with
    | Some hmac ->
        if HMap.mem hmac cache then forbidden
        else if Belenios_messages.check_message ~key m then
          let* r = Send_message.send ?internal m.message in
          match r with
          | Ok hint ->
              let cache = HMap.add hmac m.timestamp cache in
              msgcache := cache;
              `String hint |> Yojson.Safe.to_string |> return_json 200
          | Error () -> service_unavailable
        else forbidden
    | None -> forbidden
  else forbidden
