Source file database.ml

(* TODO [jerben] remove this file, move everything into customer project *)

type pool = (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt.Pool.t
type connection = (module Caqti_lwt.CONNECTION)

module Id = struct
  type t = Uuidm.t

  let pp = Uuidm.pp
  let equal = Uuidm.equal
  let random () = Uuidm.v `V4

  let of_string id_string =
    match id_string |> Uuidm.of_string with
    | Some id -> Ok id
    | None ->
      Error
        (Printf.sprintf
           "Invalid id %s provided, can not convert string to uuidv4"
           id_string)
  ;;

  let of_bytes id_bytes =
    let msg =
      Printf.sprintf "Invalid id %s provided, can not convert bytes to uuidv4" id_bytes
    in
    id_bytes |> Uuidm.of_bytes |> Option.to_result ~none:msg
  ;;

  let to_string id = Uuidm.to_string id
  let to_bytes id = Uuidm.to_bytes id
  let is_valid_str id_string = id_string |> of_string |> Result.is_ok

  let t_string =
    let ( let* ) = Result.bind in
    let encode uuid =
      let* uuid = of_string uuid in
      Ok (to_bytes uuid)
    in
    let decode uuid =
      let* uuid = of_bytes uuid in
      Ok (to_string uuid)
    in
    Caqti_type.(custom ~encode ~decode string)
  ;;

  let t =
    let ( let* ) = Result.bind in
    let encode uuid = Ok (to_bytes uuid) in
    let decode uuid =
      let* uuid = of_bytes uuid in
      Ok uuid
    in
    Caqti_type.(custom ~encode ~decode octets)
  ;;

  module Uuidm = Uuidm
end

module Ql = struct
  open Sexplib.Std

  module Filter = struct
    type op =
      | Eq
      | Like
    [@@deriving show, eq, sexp, yojson]

    type criterion =
      { key : string
      ; value : string
      ; op : op
      }
    [@@deriving show, eq, sexp, yojson]

    type t =
      | And of t list
      | Or of t list
      | C of criterion
    [@@deriving show, eq, sexp, yojson]
  end

  module Sort = struct
    type criterion =
      | Asc of string
      | Desc of string
    [@@deriving show, eq, sexp, yojson]

    type t = criterion list [@@deriving show, eq, sexp, yojson]

    let criterion_value = function
      | Asc value -> value
      | Desc value -> value
    ;;
  end

  module Page = struct
    type t =
      { limit : int option [@sexp.option]
      ; offset : int option [@sexp.option]
      }
    [@@deriving show, eq, sexp, yojson]

    let empty = { limit = None; offset = None }
    let set_limit limit page = { page with limit = Some limit }
    let set_offset offset page = { page with offset = Some offset }
    let get_limit page = page.limit
    let get_offset page = page.offset

    let of_string str =
      if String.equal str ""
      then Ok empty
      else (
        let sexp = Sexplib.Sexp.of_string str in
        Ok (t_of_sexp sexp))
    ;;

    let to_string query =
      let sexp = query |> sexp_of_t in
      Sexplib.Sexp.to_string sexp
    ;;
  end

  type t =
    { filter : Filter.t option [@sexp.option]
    ; sort : Sort.t option [@sexp.option]
    ; page : Page.t
    }
  [@@deriving show, eq, sexp, yojson]

  let get_page query = query.page
  let get_limit query = query.page.limit
  let get_offset query = query.page.offset

  module Sql = struct
    let is_field_whitelisted whitelist field =
      whitelist |> List.find_opt (String.equal field) |> Option.is_some
    ;;

    let limit limit = "LIMIT ?", [ Int.to_string limit ]
    let offset offset = "OFFSET ?", [ Int.to_string offset ]

    let sort whitelist sort =
      let sorts =
        sort
        |> List.filter (fun criterion ->
               criterion |> Sort.criterion_value |> is_field_whitelisted whitelist)
        |> List.map (function
               | Sort.Asc value -> Printf.sprintf "%s ASC" value
               | Sort.Desc value -> Printf.sprintf "%s DESC" value)
        |> String.concat ", "
      in
      if String.equal "" sorts then "" else Printf.sprintf "ORDER BY %s" sorts
    ;;

    let filter_criterion_to_string criterion =
      let op_string =
        Filter.(
          match criterion.op with
          | Eq -> "="
          | Like -> "LIKE")
      in
      Printf.sprintf "%s %s ?" criterion.key op_string
    ;;

    let is_filter_whitelisted whitelist filter =
      match filter with
      | Filter.C criterion -> is_field_whitelisted whitelist Filter.(criterion.key)
      | _ -> true
    ;;

    let filter whitelist filter =
      let values = ref [] in
      let rec to_string filter =
        Filter.(
          match filter with
          | C criterion ->
            values := List.concat [ !values; [ criterion.value ] ];
            filter_criterion_to_string criterion
          | And [] -> ""
          | Or [] -> ""
          | And filters ->
            let whitelisted_filters =
              filters |> List.filter (is_filter_whitelisted whitelist)
            in
            let criterions_string =
              whitelisted_filters |> List.map to_string |> String.concat " AND "
            in
            if List.length whitelisted_filters > 1
            then Printf.sprintf "(%s)" criterions_string
            else Printf.sprintf "%s" criterions_string
          | Or filters ->
            let whitelisted_filters =
              filters |> List.filter (is_filter_whitelisted whitelist)
            in
            let criterions_string =
              whitelisted_filters |> List.map to_string |> String.concat " OR "
            in
            if List.length whitelisted_filters > 1
            then Printf.sprintf "(%s)" criterions_string
            else Printf.sprintf "%s" criterions_string)
      in
      let result = to_string filter in
      let result =
        if String.equal "" result then "" else Printf.sprintf "WHERE %s" result
      in
      result, !values
    ;;

    let to_fragments field_whitelist query =
      let filter_qs, filter_values =
        query.filter
        |> Option.map (filter field_whitelist)
        |> Option.value ~default:("", [])
      in
      let sort_qs =
        query.sort |> Option.map (sort field_whitelist) |> Option.value ~default:""
      in
      let limit_fragment = get_limit query |> Option.map limit in
      let offset_fragment = get_offset query |> Option.map offset in
      let pagination_qs, pagination_values =
        (match limit_fragment, offset_fragment with
        | Some (limit_query, limit_value), Some (offset_query, offset_value) ->
          Some
            (limit_query ^ " " ^ offset_query, List.concat [ limit_value; offset_value ])
        | _ -> None)
        |> Option.value ~default:("", [])
      in
      filter_qs, sort_qs, pagination_qs, List.concat [ filter_values; pagination_values ]
    ;;

    let to_string field_whitelist query =
      let filter_fragment, sort_fragment, pagination_fragment, values =
        to_fragments field_whitelist query
      in
      let qs =
        List.filter
          (fun str -> not (String.equal "" str))
          [ filter_fragment; sort_fragment; pagination_fragment ]
        |> String.concat " "
      in
      qs, values
    ;;
  end

  let of_string str =
    if String.equal str ""
    then Ok { filter = None; sort = None; page = { limit = None; offset = None } }
    else (
      let sexp = Sexplib.Sexp.of_string str in
      Ok (t_of_sexp sexp))
  ;;

  let to_string query =
    let sexp = query |> sexp_of_t in
    Sexplib.Sexp.to_string sexp
  ;;

  let to_sql = Sql.to_string
  let to_sql_fragments = Sql.to_fragments
  let empty = { filter = None; sort = None; page = { limit = None; offset = None } }
  let set_filter filter query = { query with filter = Some filter }

  let set_filter_and criterion query =
    let open Filter in
    let new_filter =
      match query.filter with
      | Some filter -> And (List.append [ filter ] [ C criterion ])
      | None -> C criterion
    in
    { query with filter = Some new_filter }
  ;;

  let set_sort sort query = { query with sort = Some sort }

  let set_limit limit query =
    let page = { query.page with limit = Some limit } in
    { query with page }
  ;;

  let set_offset offset query =
    let page = { query.page with offset = Some offset } in
    { query with page }
  ;;
end

module Meta = struct
  type t = { total : int } [@@deriving show, eq, fields, make]
end

module Dynparam = struct
  type t = Pack : 'a Caqti_type.t * 'a -> t

  let empty = Pack (Caqti_type.unit, ())
  let add t x (Pack (t', x')) = Pack (Caqti_type.tup2 t' t, (x', x))
end