Server behaviour tests, running on every platform (incl. Windows)

.github/workflows/workflow.yml

@@ -53,6 +53,10 @@ jobs:
 
       - run: opam exec -- make all
 
+      - name: Run the test suite
+        timeout-minutes: 5
+        run: opam exec -- dune runtest
+
       - run: opam install .
 
   # lint-doc:

ocsigenserver.opam

@@ -68,3 +68,10 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 install:[make "install.files"]
+# Temporary: conduit sets SO_REUSEADDR on AF_UNIX sockets, which breaks bind on
+# Windows (EOPNOTSUPP). Pin a fork with that fix until it is released upstream.
+pin-depends: [
+  ["conduit.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+  ["conduit-lwt.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+  ["conduit-lwt-unix.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+]

ocsigenserver.opam.template

@@ -30,3 +30,10 @@ build: [
   ["dune" "build" "-p" name "-j" jobs]
 ]
 install:[make "install.files"]
+# Temporary: conduit sets SO_REUSEADDR on AF_UNIX sockets, which breaks bind on
+# Windows (EOPNOTSUPP). Pin a fork with that fix until it is released upstream.
+pin-depends: [
+  ["conduit.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+  ["conduit-lwt.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+  ["conduit-lwt-unix.8.0.0" "git+https://github.com/hhugo/ocaml-conduit.git#fix-afunix-reuseaddr"]
+]

src/baselib/Ocsigen_base/lib.ml

@@ -73,7 +73,10 @@ end
 (*****************************************************************************)
 
 let make_cryptographic_safe_string =
-  let rng = Cryptokit.Random.device_rng "/dev/urandom" in
+  (* Use the OS-provided cryptographically secure RNG. This is portable (it maps
+     to /dev/urandom or getrandom on Unix and to the crypto provider on Windows),
+     unlike opening "/dev/urandom" directly, which fails on Windows. *)
+  let rng = Cryptokit.Random.secure_rng in
   fun () ->
     let random_part =
       let random_number = Cryptokit.Random.string rng 20 in
@@ -86,10 +89,10 @@ let make_cryptographic_safe_string =
     random_part ^ sequential_part
 
 (* The string is produced from the concatenation of two components:
-   a 160-bit random sequence obtained from /dev/urandom, and a
+   a 160-bit random sequence obtained from the OS secure RNG, and a
    64-bit sequential component derived from the system clock.  The
    former is supposed to prevent session spoofing.  The assumption
-   is that given the high cryptographic quality of /dev/urandom, it
+   is that given the high cryptographic quality of the OS RNG, it
    is impossible for an attacker to deduce the sequence of random
    numbers produced.  As for the latter component, it exists to
    prevent a theoretical (though infinitesimally unlikely) session

src/files/ocsigenserver.conf/gen.ml

@@ -91,7 +91,14 @@ let deps () =
   let inp = Unix.open_process_in cmd in
   (try
      while true do
-       deps := input_line inp :: !deps
+       (* Trim the line: on Windows ocamlfind's output ends in CRLF and
+          input_line keeps the trailing '\r', which would otherwise make the
+          package names in builtin_packages fail to match the (clean) names
+          the loader gets from Findlib, so already-linked packages would be
+          dynamically reloaded. *)
+       match String.trim (input_line inp) with
+       | "" -> ()
+       | dep -> deps := dep :: !deps
      done
    with End_of_file -> ());
   match Unix.close_process_in inp with

src/ocsigenserver.ml

@@ -19,6 +19,8 @@ let fatal fmt =
 let serve_dir = ref None
 let serve_port = ref None
 let directory_listing = ref false
+let serve_command_pipe = ref None
+let serve_command = ref None
 let config_given = ref false
 
 let set_serve_dir d =
@@ -37,6 +39,10 @@ let () =
   and serve_msg = "Serve the static files of DIR without a configuration file"
   and port_msg = "Port to listen on in serve mode (default 8080)"
   and listing_msg = "List directory contents in serve mode (when no index file)"
+  and command_pipe_msg =
+    "Command pipe to control the server in serve mode (FIFO on Unix, named pipe on Windows)"
+  and command_msg =
+    "Send CMD to a running server through its --command-pipe and exit (e.g. \"shutdown\")"
   and silent_msg = "Silent mode (error messages in errors.log only)"
   and pid_msg = "Specify a file where to write the PIDs of servers"
   and daemon_msg = "Daemon mode (detach the process)"
@@ -52,6 +58,10 @@ let () =
       ; "-P", Arg.Int (fun p -> serve_port := Some p), port_msg
       ; "--port", Arg.Int (fun p -> serve_port := Some p), port_msg
       ; "--directory-listing", Arg.Set directory_listing, listing_msg
+      ; ( "--command-pipe"
+        , Arg.String (fun s -> serve_command_pipe := Some s)
+        , command_pipe_msg )
+      ; "--command", Arg.String (fun s -> serve_command := Some s), command_msg
       ; "-s", Arg.Unit Ocsigen.Config.set_silent, silent_msg
       ; "--silent", Arg.Unit Ocsigen.Config.set_silent, silent_msg
       ; "-p", Arg.String Ocsigen.Config.set_pidfile, pid_msg
@@ -86,14 +96,28 @@ let check_serve_dir dir =
   | exception Sys_error _ -> fatal "no such directory: %s" dir
 
 let () =
-  match !serve_dir with
-  | Some dir ->
-      if !config_given
-      then fatal "-c/--config cannot be combined with serve mode";
-      let dir = check_serve_dir dir in
-      Ocsigen.Server.serve ~dir ?port:!serve_port
-        ~directory_listing:!directory_listing ()
-  | None ->
-      if !serve_port <> None || !directory_listing
-      then fatal "--port and --directory-listing require a directory to serve";
-      Ocsigen.Server.exec (Ocsigen.Parseconfig.parse_config ())
+  match !serve_command with
+  | Some command -> (
+    (* Client mode: send a command to a running server and exit. *)
+    match !serve_command_pipe with
+    | None -> fatal "--command requires --command-pipe"
+    | Some command_pipe -> (
+      try Ocsigen.Server.send_command ~command_pipe command
+      with Failure msg -> fatal "could not send command: %s" msg))
+  | None -> (
+    match !serve_dir with
+    | Some dir ->
+        if !config_given
+        then fatal "-c/--config cannot be combined with serve mode";
+        let dir = check_serve_dir dir in
+        Ocsigen.Server.serve ~dir ?port:!serve_port
+          ~directory_listing:!directory_listing
+          ?command_pipe:!serve_command_pipe ()
+    | None ->
+        if
+          !serve_port <> None || !directory_listing
+          || !serve_command_pipe <> None
+        then
+          fatal
+            "--port, --directory-listing and --command-pipe require a directory to serve";
+        Ocsigen.Server.exec (Ocsigen.Parseconfig.parse_config ()))

src/server/Ocsigen/local_files.ml

@@ -57,10 +57,17 @@ let rec check_symlinks_parent_directories
           ~no_check_for
           (policy : symlink_policy)
   =
-  if filename = "/" || filename = "." || Some filename = no_check_for
+  let dirname = Filename.dirname filename in
+  if
+    filename = "/" || filename = "."
+    || Some filename = no_check_for
+    (* Stop at a filesystem root. On Windows [Filename.dirname "C:\\"] returns
+       "C:\\" (a fixed point), so without this the recursion below would loop
+       forever -- the Unix root "/" is handled above but Windows roots are
+       not. *)
+    || dirname = filename
   then true
   else
-    let dirname = Filename.dirname filename in
     check_symlinks_aux dirname policy
     && check_symlinks_parent_directories ~filename:dirname ~no_check_for policy
 
@@ -81,9 +88,14 @@ let check_symlinks ~no_check_for ~filename policy =
         (* We remove an eventual trailing slash, in order to avoid a
            needless recursion in check_symlinks_parent_directories, and so
            that Unix.lstat returns the correct result (Unix.lstat "foo/" and
-           Unix.lstat "foo" return two different results...)  *)
+           Unix.lstat "foo" return two different results...). On Windows the
+           separator is '\\', so accept it too -- otherwise the trailing
+           separator left by [Filename.concat dir ""] makes the parent-directory
+           recursion skip [no_check_for] and loop. *)
         let len = String.length filename - 1 in
-        if filename.[len] = '/' then String.sub filename 0 len else filename
+        if filename.[len] = '/' || filename.[len] = Filename.dir_sep.[0]
+        then String.sub filename 0 len
+        else filename
       in
       check_symlinks_aux filename policy
       && check_symlinks_parent_directories ~filename ~no_check_for policy
@@ -167,7 +179,13 @@ let resolve
     let filename, stat =
       if stat.Unix.LargeFile.st_kind = Unix.S_DIR
       then
-        if filename.[String.length filename - 1] <> '/'
+        (* Does [filename] already end with a directory separator? On Windows
+           Filename.concat appends '\\' rather than '/', so accept either. *)
+        if
+          let n = String.length filename in
+          n > 0
+          && filename.[n - 1] <> '/'
+          && filename.[n - 1] <> Filename.dir_sep.[0]
         then (
           Logs.info
             ~src:

src/server/Ocsigen/response.ml

@@ -65,10 +65,12 @@ let respond_file ?headers ?(status = `OK) fname =
   (* Copied from [cohttp-lwt-unix] and adapted to [Body]. *)
   Lwt.catch
     (fun () ->
-       (* Check this isn't a directory first *)
+       (* Check this is a regular file, and take its size from the stat. Using
+          Lwt_io.length would seek to the end of the channel, which fails on
+          Windows ("Lwt_io.length: seek failed"). *)
+       let* s = Lwt_unix.LargeFile.stat fname in
        let* () =
-         let* s = Lwt_unix.stat fname in
-         if Unix.(s.st_kind <> S_REG)
+         if s.Unix.LargeFile.st_kind <> Unix.S_REG
          then raise Isnt_a_file
          else Lwt.return_unit
        in
@@ -77,8 +79,7 @@ let respond_file ?headers ?(status = `OK) fname =
          Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input
            fname
        in
-       let* len = Lwt_io.length ic in
-       let encoding = Http.Transfer.Fixed len in
+       let encoding = Http.Transfer.Fixed s.Unix.LargeFile.st_size in
        let stream write =
          let rec cat_loop () =
            Lwt.bind (Lwt_io.read ~count ic) (function