update

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.28.1
+version=0.29.0
 assignment-operator=end-line
 break-cases=fit
 break-fun-decl=wrap

example/dune

@@ -3,4 +3,4 @@
  (modules main)
  (flags
   (:standard -open Prelude))
- (libraries drame fmt prelude scfg))
+ (libraries drame fmt htmlit prelude scfg))

example/main.ml

@@ -1,7 +1,3 @@
-open Drame
-open Tyxml
-open Tyxml.Html
-
 module App_id = struct
   let qualifier = "org"
 
@@ -10,64 +6,65 @@ module App_id = struct
   let application = "drame"
 end
 
-module Server = Server.Make (App_id)
+module Server = Drame.Server.Make (App_id)
 
-let template_html (_request : Request.t) ~title ~body =
+let template_html (_request : Drame.Request.t) ~title ~body =
-  let styles =
+  let open Htmlit in
-    List.map
+  El.html
-      (fun s -> link ~rel:[ `Stylesheet ] ~href:(Fmt.str "/assets/css/%s" s) ())
+    ~at:[ At.lang "en" ]
-      [ "style.css" ]
+    [ El.head
-  in
+        [ El.title [ El.txt title ]
-  let head = head (Html.title title) styles in
+        ; El.link
-  let body = Html.body [ main [ h1 [ title ]; body ] ] in
+            ~at:[ At.rel "stylesheet"; At.href "/assets/css/style.css" ]
-  let a = [ a_lang "en" ] in
+            ()
-  let tyxml_doc = html ~a head body in
+        ]
-  Html_doc.of_tyxml tyxml_doc
+    ; El.body [ El.main [ El.h1 [ El.txt title ]; body ] ]
+    ]
 
-let hello =
+let hello ~name request =
-  let body = txt "How are you doing?" in
+  let title = Fmt.str "Hello %s!" name in
-  fun ~name ->
+  let body = Htmlit.El.txt "How are you doing?" in
-    let title = Fmt.kstr txt "Hello %s!" name in
+  let doc = template_html request ~title ~body in
-    fun request ->
+  let content = Drame.Content.Html doc in
-      let doc = template_html request ~title ~body in
-      let content = Content.Html doc in
-      Ok content
-
-let hello_q request =
-  let name = Request.query request "name" in
-  let name = Option.value name ~default:"World" in
-  let msg = Fmt.kstr txt "Hello %s!" name in
-  let doc = template_html request ~title:msg ~body:msg in
-  let content = Content.Html doc in
   Ok content
 
-let config =
+let hello_q request =
-  let title = txt "Configuration" in
+  let name =
-  let body = Fmt.kstr txt "%a" Scfg.Pp.config Server.config in
+    Drame.Request.query request "name" |> Option.value ~default:"World"
-  fun request ->
-    let doc = template_html request ~title ~body in
-    let content = Content.Html doc in
-    Ok content
-
-let not_found =
-  let title = txt "404 Not Found" in
-  let body = txt "Ooops :S" in
-  fun request ->
-    let content = template_html request ~title ~body in
-    Error (Status.Not_found, content)
-
-let style =
-  let sheet =
-    {css|body {
-  color: #ebb2bf;
-  background-color: #0f1312;
-}|css}
   in
-  let content = Content.Unsafe { content = sheet; mimetype = Text_css } in
+  let title = Fmt.str "Hello %s!" name in
-  fun _request -> Ok content
+  let body = Htmlit.El.txt title in
+  let doc = template_html request ~title ~body in
+  let content = Drame.Content.Html doc in
+  Ok content
+
+let config request =
+  let title = "Configuration" in
+  let body = Fmt.kstr Htmlit.El.txt "%a" Scfg.Pp.config Server.config in
+  let doc = template_html request ~title ~body in
+  let content = Drame.Content.Html doc in
+  Ok content
+
+let not_found request =
+  let title = "404 Not Found" in
+  let body = Htmlit.El.txt "Ooops :S" in
+  let content = template_html request ~title ~body in
+  Error (Drame.Status.Not_found, content)
+
+let style _request =
+  let sheet =
+    {css|
+      body {
+        color: #ebb2bf;
+        background-color: #0f1312;
+      }
+    |css}
+  in
+  let content = Drame.Content.Unsafe { content = sheet; mimetype = Text_css } in
+  Ok content
 
 let handler route =
-  Fmt.pr "[request] %a@\n" Route.pp route;
+  Fmt.pr "[request] %a@\n" Drame.Route.pp route;
   Fmt.flush Fmt.stdout ();
   match route with
   | [||] -> hello ~name:"World"

shell.nix

@@ -3,39 +3,23 @@
   }) {}
 }:
 
-let
-  ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_4.overrideScope (self: super: {
-    htmlit = ocamlPackages.buildTopkgPackage rec {
-      pname = "htmlit";
-      version = "0.2.0";
-
-      minimalOCamlVersion = "4.14.0";
-
-      src = pkgs.fetchzip {
-        url = "https://erratique.ch/software/htmlit/releases/htmlit-${version}.tbz";
-        hash = "sha256-vE6XY7INMCwQztZqKhJaxpNF0o5+NeutJM5XobshClE=";
-      };
-    };
-  });
-in
-
 pkgs.mkShell {
-  nativeBuildInputs = with ocamlPackages; [
+  nativeBuildInputs = with pkgs.ocamlPackages; [
     dune_3
     findlib
     merlin
     ocaml
     ocamlformat
     odoc
+    ocp-browser
   ];
-  buildInputs = with ocamlPackages; [
+  buildInputs = with pkgs.ocamlPackages; [
     httpcats
     js_of_ocaml-compiler
     miou
     ptime
     htmlit
     scfg
-    tyxml
     uri
     uuidm
     directories

src/content.ml

@@ -1,18 +0,0 @@
-type t =
-  (*
-  | Css of string Css.css
-  *)
-  | Html of Html_doc.t
-  | JavaScript of Js_of_ocaml_compiler.Javascript.program
-  | Txt of string
-  | Unsafe of
-      { content : string
-      ; mimetype : Mimetype.t
-      }
-
-let to_mimetype = function
-  (* | Css _ -> Mimetype.Text_css *)
-  | Html _ -> Mimetype.Text_html
-  | JavaScript _ -> Mimetype.Text_javascript
-  | Txt _ -> Mimetype.Text_plain
-  | Unsafe { mimetype; _ } -> mimetype

src/content.mli

@@ -1,13 +1,8 @@
 type t =
-  (*
+  | Html of Htmlit.El.html
-  | Css of string Css.css
-  *)
-  | Html of Html_doc.t
   | JavaScript of Js_of_ocaml_compiler.Javascript.program
   | Txt of string
   | Unsafe of
       { content : string
       ; mimetype : Mimetype.t
       }
-
-val to_mimetype : t -> Mimetype.t

src/dune

@@ -5,7 +5,6 @@
   cookie
   form
   handler
-  html_doc
   meth
   mimetype
   request
@@ -13,8 +12,8 @@
   route
   server
   session
-  status
+  status)
-  syntax)
+ (modules_without_implementation content handler meth response status)
  (libraries
   bigstringaf
   bstr
@@ -24,15 +23,13 @@
   h1
   h2
   httpcats
-  (re_export js_of_ocaml-compiler)
+  js_of_ocaml-compiler
   miou
   miou.unix
   prelude
   ptime
   ptime.clock.os
-  (re_export scfg)
+  scfg
-  (re_export tyxml)
-  (re_export tyxml.functor)
   htmlit
   unix
   uri

src/form.ml

@@ -1,6 +1,6 @@
 let form request =
   match Request.header request "Content-Type" with
-  | None -> Error "missing content type"
+  | None -> Error (`Bad_request "missing content type")
   | Some content_type -> (
     match String.split_on_char ';' content_type with
     | "application/x-www-form-urlencoded" :: _tl ->
@@ -10,4 +10,4 @@ let form request =
         List.map (fun (name, values) -> (name, String.concat "," values)) query
       in
       Ok (List.sort (Pair.compare String.compare String.compare) form)
-    | _content_type -> Error "wrong content type" )
+    | _content_type -> Error (`Bad_request "wrong content type") )

src/form.mli

@@ -1 +1,2 @@
-val form : Request.t -> ((string * string) list, string) result
+val form :
+  Request.t -> ((string * string) list, [> `Bad_request of string ]) result

src/handler.ml

@@ -1 +0,0 @@
-type t = Route.t -> Request.t -> Response.t

src/html_doc.ml

@@ -1,9 +0,0 @@
-type t = string
-
-let to_string = Fun.id
-
-let of_tyxml doc =
-  let indent = false in
-  Fmt.str "%a@\n" (Tyxml.Html.pp ~indent ()) doc
-
-let of_htmlit doc = Htmlit.El.to_string ~doctype:true doc

src/html_doc.mli

@@ -1,7 +0,0 @@
-type t
-
-val to_string : t -> string
-
-val of_tyxml : Tyxml.Html.doc -> t
-
-val of_htmlit : Htmlit.El.html -> t

src/meth.ml

@@ -1,21 +0,0 @@
-type t =
-  | Connect
-  | Delete
-  | Get
-  | Head
-  | Options
-  | Post
-  | Put
-  | Trace
-  | Other of string
-
-let of_httpcats = function
-  | `CONNECT -> Connect
-  | `DELETE -> Delete
-  | `GET -> Get
-  | `HEAD -> Head
-  | `OPTIONS -> Options
-  | `POST -> Post
-  | `PUT -> Put
-  | `TRACE -> Trace
-  | `Other s -> Other s

src/meth.mli

@@ -8,5 +8,3 @@ type t =
   | Put
   | Trace
   | Other of string
-
-val of_httpcats : H2.Method.t -> t

src/mimetype.mli

@@ -32,6 +32,6 @@ type t =
   | Video_mp4
   | Video_webm
 
-val pp : Format.formatter -> t -> unit
+val pp : t Fmt.t
 
 val to_string : t -> string

src/request.ml

@@ -114,6 +114,17 @@ let of_reqd reqd =
   in
   let route = Uri.path target |> Route.of_string in
   let headers = H2.Headers.to_list headers in
-  let meth = Meth.of_httpcats meth in
+  let meth : Meth.t =
+    match meth with
+    | `CONNECT -> Connect
+    | `DELETE -> Delete
+    | `GET -> Get
+    | `HEAD -> Head
+    | `OPTIONS -> Options
+    | `POST -> Post
+    | `PUT -> Put
+    | `TRACE -> Trace
+    | `Other s -> Other s
+  in
   let get_body () = get_body reqd in
   { route; meth; query; headers; get_body }

src/response.ml

@@ -1 +0,0 @@
-type t = (Content.t, Status.error * Html_doc.t) Result.t

src/response.mli

@@ -1 +1 @@
-type t = (Content.t, Status.error * Html_doc.t) Result.t
+type t = (Content.t, Status.error * Htmlit.El.html) Result.t

src/route.mli

@@ -1,5 +1,5 @@
 type t = string array
 
-val pp : Format.formatter -> t -> unit
+val pp : t Fmt.t
 
 val of_string : string -> t

src/server.ml

@@ -32,7 +32,9 @@ struct
   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
+    | Error (`Msg _msg) ->
+      (* TODO: warn to say there is no config file! *)
+      []
     | Ok config -> config
 
   open Scfg.Query
@@ -40,7 +42,9 @@ struct
   let port =
     let directive = get_dir "port" config in
     match directive with
-    | None -> Fmt.failwith "configuration file is missing a port directive"
+    | None ->
+      (* TODO: warn to say we use a default port! *)
+      8080
     | Some directive -> (
       let param = get_param_int 0 directive in
       match param with
@@ -54,12 +58,18 @@ struct
 
   let stop = Httpcats.Server.stop ()
 
-  let prepare_content content =
+  let content_to_mimetype : Content.t -> Mimetype.t = function
-    let content_type = Content.to_mimetype content |> Mimetype.to_string in
+    | Html _ -> Mimetype.Text_html
+    | JavaScript _ -> Mimetype.Text_javascript
+    | Txt _ -> Mimetype.Text_plain
+    | Unsafe { mimetype; _ } -> mimetype
+
+  let prepare_content (content : Content.t) =
+    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
+      | Html doc -> Htmlit.El.to_string ~doctype:true doc
       | JavaScript program ->
         let open Js_of_ocaml_compiler in
         let accept_unnamed_var = true in
@@ -83,11 +93,28 @@ struct
 
   let status_of_response = function
     | Ok _ -> `OK
-    | Error (status, _) -> Status.to_httpcats status
+    | Error ((status : Status.error), _) ->
+      begin match status with
+      | Bad_request -> `Bad_request
+      | Bad_gateway -> `Bad_gateway
+      | Conflict -> `Conflict
+      | Forbidden -> `Forbidden
+      | Found _url -> `Found
+      | Gateway_timeout -> `Gateway_timeout
+      | Internal_server_error -> `Internal_server_error
+      | Moved_permanently _url -> `Moved_permanently
+      | Not_found -> `Not_found
+      | Not_implemented -> `Not_implemented
+      | Request_timeout -> `Request_timeout
+      | See_other _url -> `See_other
+      | Service_unavailable -> `Service_unavailable
+      | Too_many_requests -> `Enhance_your_calm
+      | Unauthorized -> `Unauthorized
+      end
 
   let status_headers_of_response = function
-    | Ok content -> begin
+    | Ok content ->
-      match Content.to_mimetype content with
+      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
@@ -100,7 +127,7 @@ struct
       | Application_atom_xml | Application_zip | Application_7z | Text_csv
       | Video_avi | Video_mp4 | Video_webm ->
         []
-    end
+      end
     | Error
         ( ( Status.See_other redirect
           | Found redirect

src/session.ml

@@ -31,25 +31,17 @@ module Tbl : sig
 
   val remove : Id.t -> unit
 end = struct
-  include Hashtbl.Make (Id)
+  module H = Hashtbl.Make (Id)
 
-  let tbl = create 512
+  let tbl = H.create 512
 
   let mutex = Mutex.create ()
 
-  let finally () = Mutex.unlock mutex
+  let find key = Mutex.protect mutex (fun () -> H.find_opt tbl key)
 
-  let find key =
+  let add key value = Mutex.protect mutex (fun () -> H.replace tbl key value)
-    Mutex.lock mutex;
-    Fun.protect ~finally (fun () -> find_opt tbl key)
 
-  let add key value =
+  let remove key = Mutex.protect mutex (fun () -> H.remove tbl key)
-    Mutex.lock mutex;
-    Fun.protect ~finally (fun () -> replace tbl key value)
-
-  let remove key =
-    Mutex.lock mutex;
-    Fun.protect ~finally (fun () -> remove tbl key)
 end
 
 let now () = Ptime.v (Ptime_clock.now_d_ps ())
@@ -76,22 +68,16 @@ let create () =
 let load request =
   let now = now () in
   let valid_session =
-    let session_id = Cookie.get ~decrypt:false request "drame.session" in
+    let ( let* ) = Option.bind in
-    match session_id with
+    let* session_id = Cookie.get ~decrypt:false request "drame.session" in
-    | None -> None
+    let* session_id = Id.of_string session_id in
-    | Some session_id -> (
+    let* ({ id; expires_at; _ } as session) = Tbl.find session_id in
-      match Id.of_string session_id with
+    let is_valid = Ptime.is_earlier now ~than:expires_at in
-      | None -> None
+    if is_valid then Some session
-      | Some session_id -> (
+    else begin
-        match Tbl.find session_id with
+      Tbl.remove id;
-        | None -> None
+      None
-        | Some { id; expires_at; _ } as session ->
+    end
-          let is_valid = Ptime.is_earlier now ~than:expires_at in
-          if is_valid then session
-          else begin
-            Tbl.remove id;
-            None
-          end ) )
   in
   match valid_session with
   | None ->
@@ -140,8 +126,7 @@ let make_send_headers session =
   let max_age = Option.some @@ Ptime.Span.to_float_s max_age in
   Cookie.make_set_headers ~encrypt:false ~max_age ~key:"drame.session" ~value
 
-let pp fmt request =
+let pp fmt { id; expires_at; payload } =
-  let { id; expires_at; payload } = load request in
   Fmt.pf fmt "id = %a ; expires_at = %a ; payload:@\n  @[<v>" Id.pp id Ptime.pp
     expires_at;
   Fmt.list

src/session.mli

@@ -10,7 +10,7 @@ val set : Request.t -> string -> string -> unit
 
 val drop : Request.t -> string -> unit
 
-val pp : Format.formatter -> Request.t -> unit
+val pp : t Fmt.t
 
 (* Internal *)
 val make_send_headers : t -> (string * string) list

src/status.ml

@@ -1,31 +0,0 @@
-type error =
-  | Moved_permanently of string
-  | Found of string
-  | See_other of string
-  | Bad_request
-  | Unauthorized
-  | Forbidden
-  | Not_found
-  | Request_timeout
-  | Too_many_requests
-  | Internal_server_error
-  | Not_implemented
-  | Bad_gateway
-  | Service_unavailable
-  | Gateway_timeout
-
-let to_httpcats = function
-  | Moved_permanently _url -> `Moved_permanently
-  | Found _url -> `Found
-  | See_other _url -> `See_other
-  | Bad_request -> `Bad_request
-  | Unauthorized -> `Unauthorized
-  | Forbidden -> `Forbidden
-  | Not_found -> `Not_found
-  | Request_timeout -> `Request_timeout
-  | Too_many_requests -> `Enhance_your_calm
-  | Internal_server_error -> `Internal_server_error
-  | Not_implemented -> `Not_implemented
-  | Bad_gateway -> `Bad_gateway
-  | Service_unavailable -> `Service_unavailable
-  | Gateway_timeout -> `Gateway_timeout

src/status.mli

@@ -1,17 +1,16 @@
 type error =
-  | Moved_permanently of string
-  | Found of string
-  | See_other of string
-  | Bad_request
-  | Unauthorized
-  | Forbidden
-  | Not_found
-  | Request_timeout
-  | Too_many_requests
-  | Internal_server_error
-  | Not_implemented
   | Bad_gateway
-  | Service_unavailable
+  | Bad_request
+  | Conflict
+  | Forbidden
+  | Found of string
   | Gateway_timeout
-
+  | Internal_server_error
-val to_httpcats : error -> Httpcats.Status.t
+  | Moved_permanently of string
+  | Not_found
+  | Not_implemented
+  | Request_timeout
+  | See_other of string
+  | Service_unavailable
+  | Too_many_requests
+  | Unauthorized

src/syntax.ml

@@ -1,3 +0,0 @@
-let ( let* ) = Result.bind
-
-let ( let+ ) r f = Result.map f r