progress progress

5 files changed, 143 insertions, 0 deletions

diff --git a/bs5/server/DreamRSC.ml b/bs5/server/DreamRSC.ml
index 0b35071..40fa9a8 100644
--- a/bs5/server/DreamRSC.ml
+++ b/bs5/server/DreamRSC.ml
@@ -1 +1,134 @@
+open Function_references
+
 let debug = Sys.getenv_opt "DEMO_ENV" == Some "development"
+
+let handle_form_request action_id form_data =
+  let form_data =
+    let form_data_js = Js.FormData.make () in
+    form_data
+    |> List.iter (fun (name, value) ->
+           (* For now we're only supporting strings. *)
+           let _filename, value = value |> List.hd in
+           Js.FormData.append form_data_js name (`String value));
+    form_data_js
+  in
+
+  let args, form_data = ReactServerDOM.decodeFormDataReply form_data in
+
+  let action_id =
+    match action_id with
+    | Some action_id -> action_id
+    | None -> failwith "We don't support progressive enhancement yet."
+  in
+
+  let handler =
+    match FunctionReferences.get action_id with
+    | Some (FormData handler) -> handler
+    | _ -> assert false
+  in
+  handler args form_data
+
+let handle_request_body request action_id =
+  let%lwt body = Dream.body request in
+  let action_id =
+    match action_id with
+    | Some action_id -> action_id
+    | None ->
+        failwith
+          "Missing action ID, this request was not created by \
+           server-reason-react"
+  in
+  let handler =
+    match FunctionReferences.get action_id with
+    | Some (Body handler) -> handler
+    | _ -> assert false
+  in
+
+  handler (ReactServerDOM.decodeReply body)
+
+let handle_request request =
+  let action_id = Dream.header request "ACTION_ID" in
+  let content_type = Dream.header request "Content-Type" in
+
+  match content_type with
+  | Some content_type
+    when String.starts_with content_type ~prefix:"multipart/form-data" -> (
+      let%lwt result = Dream.multipart request ~csrf:false in
+      match result with
+      | `Ok form_data -> handle_form_request action_id form_data
+      | _ ->
+          failwith
+            "Missing form data, this request was not created by \
+             server-reason-react")
+  | _ -> handle_request_body request action_id
+
+let stream_function_response request =
+  Dream.stream
+    ~headers:[ ("Content-Type", "application/react.action") ]
+    (fun stream ->
+      let%lwt () =
+        ReactServerDOM.create_action_response
+          ~subscribe:(fun chunk ->
+            Dream.log "Action response";
+            Dream.log "%s" chunk;
+            let%lwt () = Dream.write stream chunk in
+            Dream.flush stream)
+          (handle_request request)
+      in
+
+      Dream.flush stream)
+
+let is_react_component_header str =
+  String.equal str "application/react.component"
+
+let stream_model ~location app =
+  Dream.stream
+    ~headers:
+      [
+        ("Content-Type", "application/react.component");
+        ("X-Content-Type-Options", "nosniff");
+        ("X-Location", location);
+      ]
+    (fun stream ->
+      let%lwt () =
+        ReactServerDOM.render_model ~debug
+          ~subscribe:(fun chunk ->
+            Dream.log "Chunk";
+            Dream.log "%s" chunk;
+            let%lwt () = Dream.write stream chunk in
+            Dream.flush stream)
+          app
+      in
+
+      Dream.flush stream)
+
+let stream_html ~bootstrap_script_content ~bootstrap_scripts ~bootstrap_modules
+    app =
+  Dream.stream
+    ~headers:[ ("Content-Type", "text/html") ]
+    (fun stream ->
+      let%lwt html, subscribe =
+        ReactServerDOM.render_html
+          ~bootstrapScriptContent:bootstrap_script_content
+          ~bootstrapScripts:bootstrap_scripts
+          ~bootstrapModules:bootstrap_modules ~debug app
+      in
+      let%lwt () = Dream.write stream html in
+      let%lwt () = Dream.flush stream in
+      let%lwt () =
+        subscribe (fun chunk ->
+            Dream.log "Chunk";
+            Dream.log "%s" chunk;
+            let%lwt () = Dream.write stream chunk in
+            Dream.flush stream)
+      in
+      Dream.flush stream)
+
+let create_from_request ?(bootstrap_modules = []) ?(bootstrap_scripts = [])
+    ?(bootstrap_script_content = "") app request =
+  match Dream.header request "Accept" with
+  | Some accept when is_react_component_header accept ->
+      stream_model ~location:(Dream.target request) app
+  | _ ->
+      stream_html ~bootstrap_script_content ~bootstrap_scripts
+        ~bootstrap_modules app
diff --git a/bs5/server/dune b/bs5/server/dune
index f1e713e..3438c1c 100644
--- a/bs5/server/dune
+++ b/bs5/server/dune
@@ -8,6 +8,7 @@
   ; local
   middleware
   api
+  function_references
   ;
   dream
   server-reason-react.belt
diff --git a/bs5/server/fref/FunctionReferences.ml b/bs5/server/fref/FunctionReferences.ml
new file mode 100644
index 0000000..e0da7c3
--- /dev/null
+++ b/bs5/server/fref/FunctionReferences.ml
@@ -0,0 +1,5 @@
+type t = (string, ReactServerDOM.server_function) Hashtbl.t
+
+let registry = Hashtbl.create 10
+let register = Hashtbl.add registry
+let get = Hashtbl.find_opt registry
diff --git a/bs5/server/fref/FunctionReferences.mli b/bs5/server/fref/FunctionReferences.mli
new file mode 100644
index 0000000..74fa681
--- /dev/null
+++ b/bs5/server/fref/FunctionReferences.mli
@@ -0,0 +1 @@
+include ReactServerDOM.FunctionReferences
diff --git a/bs5/server/fref/dune b/bs5/server/fref/dune
new file mode 100644
index 0000000..7d7744d
--- /dev/null
+++ b/bs5/server/fref/dune
@@ -0,0 +1,3 @@
+(library
+ (name function_references)
+ (libraries server-reason-react.reactDom))