Source file util.ml

open! Values
open! Core
open! Async

let default_max_results = 20

let list_user_pools cfg ?(max_results = default_max_results) () =
  Log.Global.debug "list-user-pools" ~tags:[ "max_results", Int.to_string max_results ];
  let maxResults = PoolQueryLimitType.make max_results in
  match%bind Io.list_user_pools ~cfg (ListUserPoolsRequest.make ~maxResults ()) with
  | Error _ -> failwithf "idp.list_user_pools" ()
  | Ok x -> return x
;;

let user_pools_to_json t = UserPoolListType.to_json t

let user_pools_to_string t =
  let x = user_pools_to_json t in
  Yojson.Safe.to_string x
;;

module Attribute = struct
  module Unsafe = struct
    include AttributeType
    module Name = AttributeNameType
    module Value = AttributeValueType
  end

  module Safe = struct
    include Awso_cognito_idp.User.Attribute

    let value_string ?here ?message ?error value =
      let v = Option.value_exn ?here ?message ?error value |> Unsafe.Value.to_value in
      match v with
      | `String s -> s
      | _ ->
        failwith
          (match message with
           | None -> "value not a string shape"
           | Some m -> m)
    ;;

    let value_string_opt ?message value =
      let x =
        match value with
        | Some x ->
          let x = Unsafe.Value.to_value x in
          Some x
        | None -> None
      in
      Option.map x ~f:(function
        | `String s -> s
        | _boto_value ->
          failwith
            (match message with
             | None -> "value not a string shape"
             | Some m -> m))
    ;;

    let of_unsafe { Unsafe.name; value } =
      match Unsafe.Name.to_value name with
      | `String "email" ->
        value_string ?here:None ?error:None ~message:"email must be a string shape" value
        |> fun x -> `Email x
      | `String "name" ->
        value_string ?here:None ?error:None ~message:"name must be a string shape" value
        |> fun x -> `Name x
      | `String "preferred_user_name" ->
        value_string_opt ~message:"prefered user name must be a string shape" value
        |> fun x -> `Preferred_user_name x
      | `String s -> (
        match String.split s ~on:':' with
        | "custom" :: rest ->
          let name = String.concat ~sep:":" rest in
          value_string_opt value |> fun value -> `Custom { name; value }
        | _ -> value_string_opt value |> fun value -> `Unknown { name = s; value })
      | _ -> failwith "not a valid shape for attribute key"
    ;;
  end
end

module User = Awso_cognito_idp.User

type get_user_error = GetUserResponse.error

exception
  (* Convenience exception for [get_user] AWS calls which wraps the many error
     condition variants *)
    Get_user_error of
    { message : string option
    ; cause : get_user_error
    }

let get_user_failwith ?message cause = raise (Get_user_error { message; cause })

let get_user ?retry_delay ?retry_cnt cfg ~access_token () =
  Awso_async.Import.with_retries ?retry_delay ?retry_cnt
  @@ fun () ->
  let accessToken = TokenModelType.make access_token in
  let request = GetUserRequest.make ~accessToken () in
  match%map Io.get_user ~cfg request with
  | Error e -> Error e
  | Ok ({ GetUserResponse.username; userAttributes; _ } as response) ->
    let x = GetUserResponse.to_json response in
    let resp_str = Yojson.Safe.to_string x in
    Log.Global.debug "response body is %s" resp_str;
    let username =
      match Option.map username ~f:UsernameType.to_value with
      | Some (`String username) -> username
      | _ -> failwith "get_user: username missing or not a string"
    in
    let userAttributes = Option.value userAttributes ~default:[] in
    List.map ~f:Attribute.Safe.of_unsafe userAttributes
    |> fun attributes -> Ok User.{ username; attributes; access_token }
;;

let admin_get_user ?retry_delay ?retry_cnt cfg ~user_pool_id ~username () =
  Awso_async.Import.with_retries ?retry_delay ?retry_cnt
  @@ fun () ->
  Io.admin_get_user
    ~cfg
    (AdminGetUserRequest.make
       ~userPoolId:(UserPoolIdType.make user_pool_id)
       ~username:(UsernameType.make username)
       ())
  >>= fun response ->
  match response with
  | Error response -> return (Error response)
  | Ok
      ({ AdminGetUserResponse.username
       ; userAttributes
       ; mFAOptions = _
       ; userCreateDate = _
       ; userLastModifiedDate = _
       ; enabled = _
       ; userStatus = _
       ; preferredMfaSetting = _
       ; userMFASettingList = _
       } as response) ->
    let userAttributes = Option.value userAttributes ~default:[] in
    let x = AdminGetUserResponse.to_json response in
    let resp_str = Yojson.Safe.to_string x in
    Log.Global.debug "response body is %s" resp_str;
    let username =
      match Option.map username ~f:UsernameType.to_value with
      | Some (`String username) -> username
      | _ -> failwith "admin_get_user: username missing or not a string"
    in
    List.map ~f:Attribute.Safe.of_unsafe userAttributes
    |> fun attributes -> return (Ok User.{ username; attributes; access_token = "" })
;;