From df511a3683c81a7ced69a3b421336e3633af8b21 Mon Sep 17 00:00:00 2001
From: BenjiReis <benjamin.reis@vates.fr>
Date: Mon, 28 Nov 2022 13:42:03 +0100
Subject: [PATCH] Redirect fileserver towards https

- Add `location` to `Http.Request.Hdr`
- Add `response_redirect` method to `http-svr`
- When `GET` is received by the fileserver and `website-https-only` is true:
    - if `host` is filled in the request, redirect towards the same URI but in HTTPS
    - if `host` is not present, reply with a forbidden as before

Solves https://github.com/xapi-project/xen-api/issues/4856

Signed-off-by: BenjiReis <benjamin.reis@vates.fr>
---
 ocaml/libs/http-svr/http.ml      | 2 ++
 ocaml/libs/http-svr/http.mli     | 2 ++
 ocaml/libs/http-svr/http_svr.ml  | 9 +++++++++
 ocaml/libs/http-svr/http_svr.mli | 2 ++
 ocaml/xapi/fileserver.ml         | 9 ++++++++-
 5 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/ocaml/libs/http-svr/http.ml b/ocaml/libs/http-svr/http.ml
index 08ac0c683ed..d97313953b1 100644
--- a/ocaml/libs/http-svr/http.ml
+++ b/ocaml/libs/http-svr/http.ml
@@ -122,6 +122,8 @@ module Hdr = struct
   let content_disposition = "content-disposition"
 
   let accept = "accept"
+
+  let location = "location"
 end
 
 let output_http fd headers =
diff --git a/ocaml/libs/http-svr/http.mli b/ocaml/libs/http-svr/http.mli
index 53dd5d96f8a..6e5d119d679 100644
--- a/ocaml/libs/http-svr/http.mli
+++ b/ocaml/libs/http-svr/http.mli
@@ -225,6 +225,8 @@ module Hdr : sig
   val content_disposition : string
 
   val accept : string
+
+  val location : string
 end
 
 val output_http : Unix.file_descr -> string list -> unit
diff --git a/ocaml/libs/http-svr/http_svr.ml b/ocaml/libs/http-svr/http_svr.ml
index 112c26a1eae..cc9b4e5237a 100644
--- a/ocaml/libs/http-svr/http_svr.ml
+++ b/ocaml/libs/http-svr/http_svr.ml
@@ -210,6 +210,15 @@ let response_method_not_implemented ?req s =
   in
   response_error_html ?version s "501" "Method not implemented" [] body
 
+let response_redirect ?req s dest =
+  let version = Option.fold ~none:"1.1" ~some:get_return_version req in
+  let location = (Http.Hdr.location, dest) in
+  let res =
+    Http.Response.make ~version ~headers:[location] ~body:"" "301"
+      "Moved Permanently"
+  in
+  Unixext.really_write_string s (Http.Response.to_wire_string res)
+
 let response_file ?mime_content_type s file =
   let size = (Unix.LargeFile.stat file).Unix.LargeFile.st_size in
   let mime_header =
diff --git a/ocaml/libs/http-svr/http_svr.mli b/ocaml/libs/http-svr/http_svr.mli
index 323511bf446..dd55ba6c22f 100644
--- a/ocaml/libs/http-svr/http_svr.mli
+++ b/ocaml/libs/http-svr/http_svr.mli
@@ -119,6 +119,8 @@ val response_internal_error :
 val response_method_not_implemented :
   ?req:Http.Request.t -> Unix.file_descr -> unit
 
+val response_redirect : ?req:Http.Request.t -> Unix.file_descr -> string -> unit
+
 val response_file :
   ?mime_content_type:string -> Unix.file_descr -> string -> unit
 
diff --git a/ocaml/xapi/fileserver.ml b/ocaml/xapi/fileserver.ml
index 000cdeda942..a2c8bc56a6b 100644
--- a/ocaml/xapi/fileserver.ml
+++ b/ocaml/xapi/fileserver.ml
@@ -90,7 +90,14 @@ let send_file (uri_base : string) (dir : string) (req : Request.t)
   let s = Buf_io.fd_of bio in
   Buf_io.assert_buffer_empty bio ;
   if access_forbidden req s then
-    Http_svr.response_forbidden ~req s
+    match req.Request.host with
+    | Some host ->
+        (* Redirect towards HTTPS *)
+        let path = String.concat "" [uri_base; req.Request.uri] in
+        let dest = Uri.make ~scheme:"https" ~host ~path () |> Uri.to_string in
+        Http_svr.response_redirect ~req s dest
+    | None ->
+        Http_svr.response_forbidden ~req s
   else
     let uri = req.Request.uri in
     try