drame/src/server.ml

module Make (App_id : sig
  val qualifier : string

  val organization : string

  val application : string
end) =
struct
  module Project = struct
    include Directories.Project_dirs (App_id)

    let force_dir d name =
      match d with
      | None -> Fmt.failwith "can not compute %s directory path" name
      | Some dir -> dir

    let cache_dir = force_dir cache_dir "cache"

    let config_dir = force_dir config_dir "config"

    let data_dir = force_dir data_dir "data"

    let data_local_dir = force_dir data_local_dir "data local"

    let preference_dir = force_dir preference_dir "preference"

    let runtime_dir = force_dir runtime_dir "runtime"

    let state_dir = force_dir state_dir "state"
  end

  let config =
    let filename = Fpath.(Project.config_dir / "config.scfg") in
    match Scfg.Parse.from_file filename with
    | Error (`Msg _msg) ->
      (* TODO: warn to say there is no config file! *)
      []
    | Ok config -> config

  open Scfg.Query

  let port =
    let directive = get_dir "port" config in
    match directive with
    | None ->
      (* TODO: warn to say we use a default port! *)
      8080
    | Some directive -> (
      let param = get_param_int 0 directive in
      match param with
      | Error (`Msg msg) -> Fmt.failwith "%s" msg
      | Ok port -> port )

  let listen () =
    let inet_addr = Unix.inet_addr_any in
    let sockaddr = Unix.ADDR_INET (inet_addr, port) in
    sockaddr

  let stop = Httpcats.Server.stop ()

  let prepare_content content =
    let content_type = Content.to_mimetype content |> Mimetype.to_string in
    let content =
      match content with
      (* | Content.Css sheet -> Fmt.str "%a@\n" Css.pp_string_css sheet *)
      | Html doc -> Html_doc.to_string doc
      | JavaScript program ->
        let open Js_of_ocaml_compiler in
        let accept_unnamed_var = true in
        let buffer = Buffer.create 4096 in
        let pp = Pretty_print.to_buffer buffer in
        let _source_map : Source_map.info =
          Js_output.program ~accept_unnamed_var pp program
        in
        (* setting a charset is invalid for JavaScript ! *)
        Buffer.contents buffer
      | Txt txt -> txt
      | Unsafe { content; _ } -> content
    in
    let content_length = String.length content in
    let headers =
      [ ("content-type", content_type)
      ; ("content-length", string_of_int content_length)
      ]
    in
    (headers, content)

  let status_of_response = function
    | Ok _ -> `OK
    | Error (status, _) -> Status.to_httpcats status

  let status_headers_of_response = function
    | Ok content -> begin
      match Content.to_mimetype content with
      | Audio_aac | Audio_midi | Audio_mp3 | Audio_wav | Audio_weba | Image_jpeg
      | Image_png | Image_gif | Image_bmp | Image_ico | Image_svg | Image_webp
      | Font_ttf | Text_css | Text_javascript
      | Unsafe (_, true) ->
        [ ("Cache-Control", "max-age=151200") ]
      | Text_html | Text_plain
      | Unsafe (_, false)
      | Application_epub | Application_json | Application_jsonld
      | Application_gz | Application_tar | Application_xml
      | Application_atom_xml | Application_zip | Application_7z | Text_csv
      | Video_avi | Video_mp4 | Video_webm ->
        []
    end
    | Error
        ( ( Status.See_other redirect
          | Found redirect
          | Moved_permanently redirect )
        , _ ) ->
      [ ("Location", redirect) ]
    | Error _ -> []

  let content_of_response = function
    | Ok content -> content
    | Error (_, content) -> Content.Html content

  (* TODO :/ *)
  let downgrade_status : Httpcats.Status.t -> H1.Status.t = function
    | `Misdirected_request -> assert false
    | `Code _ -> assert false
    | #H1.Status.standard as t -> t

  let respond reqd headers status content =
    match reqd with
    | `V1 reqd ->
      let open H1 in
      let headers = Headers.of_list headers in
      let status = downgrade_status status in
      let resp = Response.create ~headers status in
      Reqd.respond_with_string reqd resp content
    | `V2 reqd ->
      let open H2 in
      let headers = Headers.of_list headers in
      let resp = Response.create ~headers status in
      Reqd.respond_with_string reqd resp content

  let mk_server ~(handler : Handler.t) =
    let handler (_ : [ `Tcp of Miou_unix.file_descr | `Tls of _ ])
      (reqd : Httpcats.Server.reqd) =
      let ({ Request.route; _ } as request) = Request.of_reqd reqd in
      let response = handler route request in
      let status = status_of_response response in
      let status_headers = status_headers_of_response response in
      let content = content_of_response response in
      let session = Session.load request in
      let session_headers = Session.make_send_headers session in
      let content_headers, content = prepare_content content in
      let headers = session_headers @ content_headers @ status_headers in
      respond reqd headers status content
    in
    let file_descr = listen () in
    Httpcats.Server.clear ~stop ~handler file_descr;
    ()

  let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore

  let run ~(handler : Handler.t) =
    let server () = mk_server ~handler in
    Miou_unix.run server
end