first commit

src/server.ml

@@ -0,0 +1,159 @@
+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) -> Fmt.failwith "%s" msg
+    | Ok config -> config
+
+  open Scfg.Query
+
+  let port =
+    let directive = get_dir "port" config in
+    match directive with
+    | None -> Fmt.failwith "configuration file is missing a port directive"
+    | 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