http_response.ml

(** HTTPレスポンス生成の純粋関数モジュール

    このモジュールはHTTPレスポンス生成ロジックを純粋関数として提供します。
    すべての関数は副作用を持たず、ユニットテストが可能です。
*)

open Piaf
open Blossom_core

(** レスポンスの種類を表すバリアント型 *)
type response_kind =
  | Success_blob of { data: string; mime_type: string; size: int }
    (** Blobデータの取得成功（メモリ上のデータ） *)
  | Success_blob_stream of { body: Body.t; mime_type: string; size: int }
    (** Blobデータの取得成功（ストリーミング） *)
  | Success_metadata of { mime_type: string; size: int }
    (** Blobメタデータの取得成功（HEADリクエスト用） *)
  | Success_upload of Domain.blob_descriptor
    (** Blobアップロード成功 *)
  | Success_list of Domain.blob_descriptor list
    (** Blob list取得成功（BUD-12 GET /list/<pubkey>） *)
  | Success_delete
    (** Blob削除成功 *)
  | Success_upload_check
    (** アップロード事前チェック成功（HEAD /upload用） *)
  | Cors_preflight
    (** CORSプリフライトレスポンス *)
  | Error_not_found of string
    (** 404 Not Found *)
  | Error_unauthorized of string
    (** 401 Unauthorized *)
  | Error_forbidden of string
    (** 403 Forbidden *)
  | Error_bad_request of string
    (** 400 Bad Request *)
  | Error_length_required of string
    (** 411 Length Required *)
  | Error_payload_too_large of string
    (** 413 Payload Too Large *)
  | Error_unsupported_media_type of string
    (** 415 Unsupported Media Type *)
  | Error_internal of string
    (** 500 Internal Server Error *)
  | Error_bad_gateway of string
    (** 502 Bad Gateway *)

(** CORSヘッダーのリスト

    @koa/cors 相当の全面適用:
    - Access-Control-Allow-Origin: *
    - Access-Control-Allow-Methods: * (全メソッド許可)
    - Access-Control-Allow-Headers: Authorization, Content-Type, Content-Length, *
    - Access-Control-Expose-Headers: * (全ヘッダー公開)
    - Access-Control-Max-Age: 86400 (プリフライトキャッシュ24時間)
*)
let cors_headers = [
  ("access-control-allow-origin", "*");
  ("access-control-allow-methods", "*");
  ("access-control-allow-headers", "Authorization, Content-Type, Content-Length, *");
  ("access-control-expose-headers", "*");
  ("access-control-max-age", "86400");
]

(** NIP-94タグ ([("k", "v"); ...]) を JSON 配列 [["k","v"],...] に変換 *)
let nip94_tags_to_yojson (tags : (string * string) list) : Yojson.Basic.t =
  `List (List.map (fun (k, v) -> `List [`String k; `String v]) tags)

(** blob descriptorをYojson値に変換する純粋関数

    [include_nip94] が true のとき、BUD-08 に従って [nip94] フィールドを追加する。
    [/upload], [/mirror] のレスポンスでのみ true を渡す。 *)
let descriptor_to_yojson ?(include_nip94 = false) (descriptor : Domain.blob_descriptor) : Yojson.Basic.t =
  let base = [
    ("url", `String descriptor.url);
    ("sha256", `String descriptor.sha256);
    ("size", `Int descriptor.size);
    ("type", `String descriptor.mime_type);
    ("uploaded", `Int (Int64.to_int descriptor.uploaded));
  ] in
  let fields =
    if include_nip94 then
      base @ [("nip94", nip94_tags_to_yojson (Nip94.tags_of_descriptor descriptor))]
    else
      base
  in
  `Assoc fields

(** blob descriptorをJSON文字列に変換する純粋関数 *)
let descriptor_to_json ?(include_nip94 = false) (descriptor : Domain.blob_descriptor) =
  descriptor_to_yojson ~include_nip94 descriptor |> Yojson.Basic.to_string

(** レスポンスの種類から実際のHTTPレスポンスを生成する純粋関数

    この関数はパターンマッチを使用してすべてのresponse_kindを網羅的に処理します。
    新しいレスポンス種別を追加した場合、コンパイラが未処理のケースを警告します。
    全レスポンスにCORSヘッダーが自動的に付与されます。
*)
let create = function
  | Success_blob { data; mime_type; size } ->
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", mime_type);
        ("content-length", string_of_int size);
      ]) in
      Response.create ~headers ~body:(Body.of_string data) `OK

  | Success_blob_stream { body; mime_type; size } ->
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", mime_type);
        ("content-length", string_of_int size);
      ]) in
      Response.create ~headers ~body `OK

  | Success_metadata { mime_type; size } ->
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", mime_type);
        ("content-length", string_of_int size);
      ]) in
      Response.create ~headers `OK

  | Success_upload descriptor ->
      (* BUD-08: /upload と /mirror のレスポンスには nip94 フィールドを含める *)
      let json = descriptor_to_json ~include_nip94:true descriptor in
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", "application/json");
      ]) in
      Response.create ~headers ~body:(Body.of_string json) `OK

  | Success_list descriptors ->
      let json =
        `List (List.map descriptor_to_yojson descriptors)
        |> Yojson.Basic.to_string
      in
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", "application/json");
      ]) in
      Response.create ~headers ~body:(Body.of_string json) `OK

  | Success_delete ->
      let json = `Assoc [("message", `String "Deleted")] |> Yojson.Basic.to_string in
      let headers = Headers.of_list (cors_headers @ [
        ("content-type", "application/json");
      ]) in
      Response.create ~headers ~body:(Body.of_string json) `OK

  | Success_upload_check ->
      let headers = Headers.of_list cors_headers in
      Response.create ~headers `OK

  | Cors_preflight ->
      let headers = Headers.of_list cors_headers in
      Response.create ~headers `No_content

  | Error_not_found message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Not_found

  | Error_unauthorized message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Unauthorized

  | Error_forbidden message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Forbidden

  | Error_bad_request message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Bad_request

  | Error_length_required message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Length_required

  | Error_payload_too_large message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Payload_too_large

  | Error_unsupported_media_type message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Unsupported_media_type

  | Error_internal message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Internal_server_error

  | Error_bad_gateway message ->
      let headers = Headers.of_list (cors_headers @ [("x-reason", message)]) in
      Response.create ~headers ~body:(Body.of_string message) `Bad_gateway