Dream.redirect

docs/web/postprocess/index.ml

@@ -564,6 +564,21 @@ let json_replacement = {|
 </pre>
 |}
 
+let val_redirect_expected = {|<div class="spec value" id="val-redirect">
+ <a href="#val-redirect" class="anchor"></a><code><span><span class="keyword">val</span> redirect : <span>?status:<a href="#type-status">status</a> <span class="arrow">-&gt;</span></span> <span>?code:int <span class="arrow">-&gt;</span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-&gt;</span></span>
+<span>string <span class="arrow">-&gt;</span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
+</div>
+|}
+
+let val_redirect_replacement = {|
+<pre><span class="keyword">val</span> redirect :
+  <span class="optional">?status:<a href="#type-status">status</a> ->
+  ?code:int ->
+  ?headers:(string * string) list -></span>
+    string -> <a href="#type-response">response</a> <a href="#type-promise">promise</a>
+</pre>
+|}
+
 let stream_expected = {|<div class="spec value" id="val-stream">
  <a href="#val-stream" class="anchor"></a><code><span><span class="keyword">val</span> stream : <span>?status:<a href="#type-status">status</a> <span class="arrow">-&gt;</span></span> <span>?code:int <span class="arrow">-&gt;</span></span> <span>?headers:<span><span>(string * string)</span> list</span> <span class="arrow">-&gt;</span></span>
 <span><span>(<span><a href="#type-response">response</a> <span class="arrow">-&gt;</span></span> <span>unit <a href="#type-promise">promise</a></span>)</span> <span class="arrow">-&gt;</span></span> <span><a href="#type-response">response</a> <a href="#type-promise">promise</a></span></span></code>
@@ -1536,6 +1551,7 @@ let pretty_print_signatures soup =
 
   multiline "#val-html" html_expected html_replacement;
   multiline "#val-json" json_expected json_replacement;
+  multiline "#val-redirect" val_redirect_expected val_redirect_replacement;
 
   let stream = soup $ "#val-stream" in
   if_expected

example/d-form/README.md

@@ -89,6 +89,18 @@ constructors typically correspond to bugs or attacks, only.
 
 <br>
 
+This example replied to the form POST directly with HTML. In most cases, it is
+better to use [`Dream.redirect`](https://aantron.github.io/dream/#val-redirect)
+instead, to forward the browser to another page that will display the outcome.
+Using a redirection prevents form resubmission on refresh. This is especially
+important on login forms and other sensitive pages.
+
+However, this server is so simple that it doesn't store the data anywhere, and
+the data is not sensitive, so we took a shortcut. See
+[**`h-sql`**](../h-sql#files) for an example with a proper redirection.
+
+<br>
+
 **Next steps:**
 
 - [**`e-json`**](../e-json#files) receives and sends JSON.

example/h-sql/README.md

@@ -54,8 +54,7 @@ let () =
       match%lwt Dream.form request with
       | `Ok ["text", text] ->
         let%lwt () = Dream.sql (add_comment text) request in
-        let%lwt comments = Dream.sql list_comments request in
-        Dream.html (render comments request)
+        Dream.redirect "/"
       | _ ->
         Dream.empty `Bad_Request);
 

example/h-sql/sql.eml.ml

@@ -47,8 +47,7 @@ let () =
       match%lwt Dream.form request with
       | `Ok ["text", text] ->
         let%lwt () = Dream.sql (add_comment text) request in
-        let%lwt comments = Dream.sql list_comments request in
-        Dream.html (render comments request)
+        Dream.redirect "/"
       | _ ->
         Dream.empty `Bad_Request);
 

src/dream.mli

@@ -423,6 +423,16 @@ val json :
     [Content-Type:] is absent from [~headers]. See
     {!Dream.application_json}. *)
 
+val redirect :
+  ?status:status ->
+  ?code:int ->
+  ?headers:(string * string) list ->
+    string -> response promise
+(** Creates a new {!type-response}. Adds a [Location:] header with the given
+    string, if [Location:] is absent from [~headers]. The default status code is
+    [303 See Other], for a temporary redirection. Use
+    [~status:`Moved_Permanently] for a permanent redirection. *)
+
 val empty :
   ?headers:(string * string) list ->
     status -> response promise

src/pure/inmost.ml

@@ -495,6 +495,21 @@ let json ?status ?code ?headers body =
   in
   Lwt.return response
 
+let redirect ?status ?code ?headers location =
+  let status =
+    match status, code with
+    | None, None -> Some (`See_Other)
+    | _ -> status
+  in
+  let response = response ?status ?code ?headers location in
+  let response =
+    if has_header "Location" response then
+      response
+    else
+      add_header "Location" location response
+  in
+  Lwt.return response
+
 let stream ?status ?code ?headers f =
   let response =
     response ?status ?code ?headers ""