Source file `server.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
module Server_core = Cohttp_lwt.Make_server (Io)
include Server_core
open Lwt.Infix

let src =
  Logs.Src.create "cohttp.lwt.server" ~doc:"Cohttp Lwt Unix server module"

module Log = (val Logs.src_log src : Logs.LOG)

let resolve_file ~docroot ~uri = Cohttp.Path.resolve_local_file ~docroot ~uri

exception Isnt_a_file

let respond_file ?headers ~fname () =
  Lwt.catch
    (fun () ->
      (* Check this isn't a directory first *)
      ( fname |> Lwt_unix.stat >>= fun s ->
        if Unix.(s.st_kind <> S_REG) then raise Isnt_a_file else Lwt.return_unit
      )
      >>= fun () ->
      let count = 16384 in
      Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input fname
      >>= fun ic ->
      Lwt_io.length ic >>= fun len ->
      let encoding = Http.Transfer.Fixed len in
      let stream =
        Lwt_stream.from (fun () ->
            Lwt.catch
              (fun () ->
                Lwt_io.read ~count ic >|= function
                | "" -> None
                | buf -> Some buf)
              (fun exn ->
                Log.warn (fun m ->
                    m "Error resolving file %s (%s)" fname
                      (Printexc.to_string exn));
                Lwt.return_none))
      in
      Lwt.on_success (Lwt_stream.closed stream) (fun () ->
          Lwt.ignore_result
          @@ Lwt.catch
               (fun () -> Lwt_io.close ic)
               (fun e ->
                 Log.warn (fun f ->
                     f "Closing channel failed: %s" (Printexc.to_string e));
                 Lwt.return_unit));
      let body = Cohttp_lwt.Body.of_stream stream in
      let mime_type = Magic_mime.lookup fname in
      let headers =
        Http.Header.add_opt_unless_exists headers "content-type" mime_type
      in
      let res = Cohttp.Response.make ~status:`OK ~encoding ~headers () in
      Lwt.return (res, body))
    (function
      | Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file ->
          respond_not_found ()
      | exn -> Lwt.reraise exn)

let log_on_exn = function
  | Unix.Unix_error (error, func, arg) ->
      Log.warn (fun m ->
          m "Client connection error %s: %s(%S)" (Unix.error_message error) func
            arg)
  | exn -> Log.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn)

let create ?timeout ?backlog ?stop ?(on_exn = log_on_exn)
    ?(ctx = Lazy.force Net.default_ctx) ?(mode = `TCP (`Port 8080)) spec =
  Conduit_lwt_unix.serve ?backlog ?timeout ?stop ~on_exn ~ctx:ctx.Net.ctx ~mode
    (fun flow ic oc ->
      let ic = Input_channel.create ic in
      callback spec flow ic oc)