diff --git a/.ocamlformat b/.ocamlformat index 1701629..d0abae2 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.28.1 +version=0.29.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/example/dune b/example/dune index a342d72..b70aa87 100644 --- a/example/dune +++ b/example/dune @@ -3,4 +3,4 @@ (modules main) (flags (:standard -open Prelude)) - (libraries drame fmt prelude scfg)) + (libraries drame fmt htmlit prelude scfg)) diff --git a/example/main.ml b/example/main.ml index 47a6399..feded65 100644 --- a/example/main.ml +++ b/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 styles = - List.map - (fun s -> link ~rel:[ `Stylesheet ] ~href:(Fmt.str "/assets/css/%s" s) ()) - [ "style.css" ] - in - let head = head (Html.title title) styles in - let body = Html.body [ main [ h1 [ title ]; body ] ] in - let a = [ a_lang "en" ] in - let tyxml_doc = html ~a head body in - Html_doc.of_tyxml tyxml_doc +let template_html (_request : Drame.Request.t) ~title ~body = + let open Htmlit in + El.html + ~at:[ At.lang "en" ] + [ El.head + [ El.title [ El.txt title ] + ; El.link + ~at:[ At.rel "stylesheet"; At.href "/assets/css/style.css" ] + () + ] + ; El.body [ El.main [ El.h1 [ El.txt title ]; body ] ] + ] -let hello = - let body = txt "How are you doing?" in - fun ~name -> - let title = Fmt.kstr txt "Hello %s!" name in - fun request -> - 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 +let hello ~name request = + let title = Fmt.str "Hello %s!" name in + let body = Htmlit.El.txt "How are you doing?" in + let doc = template_html request ~title ~body in + let content = Drame.Content.Html doc in Ok content -let config = - let title = txt "Configuration" in - let body = Fmt.kstr txt "%a" Scfg.Pp.config Server.config in - 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} +let hello_q request = + let name = + Drame.Request.query request "name" |> Option.value ~default:"World" in - let content = Content.Unsafe { content = sheet; mimetype = Text_css } in - fun _request -> Ok content + let title = Fmt.str "Hello %s!" name in + 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" diff --git a/shell.nix b/shell.nix index 92a5619..f6c7c51 100644 --- a/shell.nix +++ b/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 diff --git a/src/content.ml b/src/content.ml deleted file mode 100644 index 3c372e7..0000000 --- a/src/content.ml +++ /dev/null @@ -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 diff --git a/src/content.mli b/src/content.mli index 4d36cb1..fc58f6e 100644 --- a/src/content.mli +++ b/src/content.mli @@ -1,13 +1,8 @@ type t = - (* - | Css of string Css.css - *) - | Html of Html_doc.t + | Html of Htmlit.El.html | JavaScript of Js_of_ocaml_compiler.Javascript.program | Txt of string | Unsafe of { content : string ; mimetype : Mimetype.t } - -val to_mimetype : t -> Mimetype.t diff --git a/src/dune b/src/dune index 063c261..53f1da5 100644 --- a/src/dune +++ b/src/dune @@ -5,7 +5,6 @@ cookie form handler - html_doc meth mimetype request @@ -13,8 +12,8 @@ route server session - status - syntax) + status) + (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) - (re_export tyxml) - (re_export tyxml.functor) + scfg htmlit unix uri diff --git a/src/form.ml b/src/form.ml index d9fc92f..1ba80ef 100644 --- a/src/form.ml +++ b/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") ) diff --git a/src/form.mli b/src/form.mli index 7555aa0..e7a7433 100644 --- a/src/form.mli +++ b/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 diff --git a/src/handler.ml b/src/handler.ml deleted file mode 100644 index 9e2e974..0000000 --- a/src/handler.ml +++ /dev/null @@ -1 +0,0 @@ -type t = Route.t -> Request.t -> Response.t diff --git a/src/html_doc.ml b/src/html_doc.ml deleted file mode 100644 index 3059671..0000000 --- a/src/html_doc.ml +++ /dev/null @@ -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 diff --git a/src/html_doc.mli b/src/html_doc.mli deleted file mode 100644 index 1dc4a84..0000000 --- a/src/html_doc.mli +++ /dev/null @@ -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 diff --git a/src/meth.ml b/src/meth.ml deleted file mode 100644 index b26d980..0000000 --- a/src/meth.ml +++ /dev/null @@ -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 diff --git a/src/meth.mli b/src/meth.mli index 50bb802..4e6385a 100644 --- a/src/meth.mli +++ b/src/meth.mli @@ -8,5 +8,3 @@ type t = | Put | Trace | Other of string - -val of_httpcats : H2.Method.t -> t diff --git a/src/mimetype.mli b/src/mimetype.mli index 47f928c..3987f07 100644 --- a/src/mimetype.mli +++ b/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 diff --git a/src/request.ml b/src/request.ml index 650b130..c2b8522 100644 --- a/src/request.ml +++ b/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 } diff --git a/src/response.ml b/src/response.ml deleted file mode 100644 index e6c1dbb..0000000 --- a/src/response.ml +++ /dev/null @@ -1 +0,0 @@ -type t = (Content.t, Status.error * Html_doc.t) Result.t diff --git a/src/response.mli b/src/response.mli index e6c1dbb..f73ef85 100644 --- a/src/response.mli +++ b/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 diff --git a/src/route.mli b/src/route.mli index 8bd415d..a04e9cb 100644 --- a/src/route.mli +++ b/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 diff --git a/src/server.ml b/src/server.ml index 13dbd82..e1ddf57 100644 --- a/src/server.ml +++ b/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_type = Content.to_mimetype content |> Mimetype.to_string in + let content_to_mimetype : Content.t -> Mimetype.t = function + | 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 - match Content.to_mimetype content with + | 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 @@ -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 diff --git a/src/session.ml b/src/session.ml index 05ebd00..3309196 100644 --- a/src/session.ml +++ b/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 = - Mutex.lock mutex; - Fun.protect ~finally (fun () -> find_opt tbl key) + let add key value = Mutex.protect mutex (fun () -> H.replace tbl key value) - let add key value = - Mutex.lock mutex; - Fun.protect ~finally (fun () -> replace tbl key value) - - let remove key = - Mutex.lock mutex; - Fun.protect ~finally (fun () -> remove tbl key) + let remove key = Mutex.protect mutex (fun () -> H.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 - match session_id with - | None -> None - | Some session_id -> ( - match Id.of_string session_id with - | None -> None - | Some session_id -> ( - match Tbl.find session_id with - | None -> None - | Some { id; expires_at; _ } as session -> - let is_valid = Ptime.is_earlier now ~than:expires_at in - if is_valid then session - else begin - Tbl.remove id; - None - end ) ) + let ( let* ) = Option.bind in + let* session_id = Cookie.get ~decrypt:false request "drame.session" in + let* session_id = Id.of_string session_id in + let* ({ id; expires_at; _ } as session) = Tbl.find session_id in + let is_valid = Ptime.is_earlier now ~than:expires_at in + if is_valid then Some 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 { id; expires_at; payload } = load request in +let pp fmt { id; expires_at; payload } = Fmt.pf fmt "id = %a ; expires_at = %a ; payload:@\n @[" Id.pp id Ptime.pp expires_at; Fmt.list diff --git a/src/session.mli b/src/session.mli index d62ec1d..d9c72c7 100644 --- a/src/session.mli +++ b/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 diff --git a/src/status.ml b/src/status.ml deleted file mode 100644 index 1569d57..0000000 --- a/src/status.ml +++ /dev/null @@ -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 diff --git a/src/status.mli b/src/status.mli index 635ba9b..77e801d 100644 --- a/src/status.mli +++ b/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 - -val to_httpcats : error -> Httpcats.Status.t + | Internal_server_error + | Moved_permanently of string + | Not_found + | Not_implemented + | Request_timeout + | See_other of string + | Service_unavailable + | Too_many_requests + | Unauthorized diff --git a/src/syntax.ml b/src/syntax.ml deleted file mode 100644 index aea9713..0000000 --- a/src/syntax.ml +++ /dev/null @@ -1,3 +0,0 @@ -let ( let* ) = Result.bind - -let ( let+ ) r f = Result.map f r