commit 3703436d18e857a7c7e12f93a805c9a929e28eaf
Author: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date:   Wed Nov 13 23:38:38 2019 -0600

    initial commit

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 00000000..f6d0aa3d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+.git
+_build
+*.install
+.merlin
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 00000000..f0c19d6e
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,16 @@
+language: c
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh
+script: bash -ex .travis-docker.sh
+services:
+- docker
+env:
+  global:
+  - PINS="simplehttpserver"
+  - DISTRO="ubuntu-16.04"
+  - PACKAGE="simplehttpserver"
+  matrix:
+  - OCAML_VERSION="4.03"
+  - OCAML_VERSION="4.04"
+  - OCAML_VERSION="4.06"
+  - OCAML_VERSION="4.07"
+  - OCAML_VERSION="4.09"
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..39fceab8
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,20 @@
+
+
+all: build test
+
+build:
+	@dune build @install
+
+test:
+	@dune runtest --no-buffer --force
+
+clean:
+	@dune clean
+
+doc:
+	@dune build @doc
+
+watch:
+	@dune build @all -w
+
+.PHONY: benchs tests build watch
diff --git a/README.md b/README.md
new file mode 100644
index 00000000..978fbe64
--- /dev/null
+++ b/README.md
@@ -0,0 +1,62 @@
+
+# SimpleHTTPServer [![build status](https://travis-ci.org/c-cube/simplehttpserver.svg?branch=master)](https://travis-ci.org/c-cube/simplehttpserver) 
+
+Minimal HTTP server using good old threads and `Scanf` for routing.
+
+
+The basic echo server from `src/examples/echo.ml`:
+
+```ocaml
+
+module S = SimpleHTTPServer
+
+let () =
+  let server = S.create () in
+  (* say hello *)
+  S.add_path_handler ~meth:`GET server
+    "/hello/%s@/" (fun _req name () -> S.Response.make_ok ("hello " ^name ^"!\n"));
+  (* echo request *)
+  S.add_path_handler server
+    "/echo" (fun req () -> S.Response.make_ok (Format.asprintf "echo:@ %a@." S.Request.pp req));
+  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
+  match S.run server with
+  | Ok () -> ()
+  | Error e -> raise e
+```
+
+```sh
+$ ./echo.sh &
+listening on http://127.0.0.1:8080
+
+# the path "hello/name" greets you.
+$ curl -X GET http://localhost:8080/hello/quadrarotaphile
+hello quadrarotaphile!
+
+# the path "echo" just prints the request.
+$ curl -X GET http://localhost:8080/echo --data "coucou lol" 
+echo:
+{meth=GET;
+ headers=Host: localhost:8080
+         User-Agent: curl/7.66.0
+         Accept: */*
+         Content-Length: 10
+         Content-Type: application/x-www-form-urlencoded;
+ path="/echo"; body="coucou lol"}
+
+```
+
+## Why?
+
+Why not? If you just want a super basic local server (perhaps for exposing
+data from a local demon, like Cups or Syncthing do), no need for a ton of
+dependencies or high scalability libraries.
+
+## Documentation
+
+See https://c-cube.github.io/simplehttpserver/
+
+## License
+
+MIT.
+
+
diff --git a/dune-project b/dune-project
new file mode 100644
index 00000000..7655de07
--- /dev/null
+++ b/dune-project
@@ -0,0 +1 @@
+(lang dune 1.1)
diff --git a/echo.sh b/echo.sh
new file mode 100755
index 00000000..a7d0acd1
--- /dev/null
+++ b/echo.sh
@@ -0,0 +1,2 @@
+#!/bin/sh
+exec dune exec "src/examples/echo.exe" -- $@
diff --git a/simplehttpserver.opam b/simplehttpserver.opam
new file mode 100644
index 00000000..650c0538
--- /dev/null
+++ b/simplehttpserver.opam
@@ -0,0 +1,23 @@
+opam-version: "2.0"
+name: "simplehttpserver"
+version: "0.1"
+authors: ["Simon Cruanes"]
+maintainer: "simon.cruanes.2007@m4x.org"
+license: "MIT"
+description: "Minimal HTTP server using good old threads"
+build: [
+  ["dune" "build" "@install" "-p" name "-j" jobs]
+  ["dune" "build" "@doc" "-p" name] {with-doc}
+  ["dune" "runtest" "-p" name] {with-test}
+]
+depends: [
+  "dune" { >= "1.1" }
+  "base-threads"
+  "ocaml" { >= "4.03.0" }
+  "odoc" {with-doc}
+]
+tags: [ "http" "thread" "server" ]
+homepage: "https://github.com/c-cube/simplehttpserver/"
+doc: "https://c-cube.github.io/simplehttpserver/"
+bug-reports: "https://github.com/c-cube/simplehttpserver/issues"
+dev-repo: "git+https://github.com/c-cube/simplehttpserver.git"
diff --git a/src/SimpleHTTPServer.ml b/src/SimpleHTTPServer.ml
new file mode 100644
index 00000000..e2306b1b
--- /dev/null
+++ b/src/SimpleHTTPServer.ml
@@ -0,0 +1,234 @@
+
+exception Bad_req of int * string
+let bad_reqf c fmt = Printf.ksprintf (fun s ->raise (Bad_req (c,s))) fmt
+
+module Meth = struct
+  type t = [
+    | `GET
+    | `PUT
+    | `POST
+    | `HEAD
+  ]
+
+  let to_string = function
+    | `GET -> "GET"
+    | `PUT -> "PUT"
+    | `HEAD -> "HEAD"
+    | `POST -> "POST"
+  let pp out s = Format.pp_print_string out (to_string s)
+
+  let of_string = function
+    | "GET" -> `GET
+    | "PUT" -> `PUT
+    | "POST" -> `POST
+    | "HEAD" -> `HEAD
+    | s -> bad_reqf 400 "unknown method %S" s
+end
+
+module Headers = struct
+  type t = (string * string) list
+  let pp out l =
+    let pp_pair out (k,v) = Format.fprintf out "@[<h>%s: %s@]" k v in
+    Format.fprintf out "@[<v>%a@]" (Format.pp_print_list pp_pair) l
+
+  let parse_ (ic:in_channel) : t =
+    let rec loop acc =
+      let line = input_line ic in
+      if line = "\r" then (
+        List.rev acc
+      ) else (
+        let k,v =
+          try Scanf.sscanf line "%s@: %s@\r" (fun k v->k,v)
+          with _ -> bad_reqf 400 "invalid header line: %S" line
+        in
+        loop ((k,v)::acc)
+      )
+    in
+    loop []
+end
+
+module Response_code = struct
+  type t = int
+
+  let descr = function
+    | 200 -> "OK"
+    | 400 -> "Bad request"
+    | 403 -> "Forbidden"
+    | 404 -> "Not found"
+    | 500 -> "Internal server error"
+    | 503 -> "Service unavailable"
+    | _ -> "Unknown response" (* TODO *)
+end
+
+module Request = struct
+  type t = {
+    meth: Meth.t;
+    headers: Headers.t;
+    path: string;
+    body: string
+  }
+
+  let headers self = self.headers
+  let meth self = self.meth
+  let path self = self.path
+  let body self = self.body
+
+  let pp out self : unit =
+    Format.fprintf out "{@[meth=%s;@ headers=%a;@ path=%S;@ body=%S@]}"
+      (Meth.to_string self.meth) Headers.pp self.headers
+      self.path self.body
+
+  let read_body ic (n:int) : string =
+    let buf = Bytes.make n ' ' in
+    let i = ref 0 in
+    while !i < n do
+      let read = input ic buf !i (n- !i) in
+      if read=0 then bad_reqf 400 "body is too short";
+      i := !i + read
+    done;
+    Bytes.unsafe_to_string buf
+
+  let parse_ (ic:in_channel) : (t option, Response_code.t * string) result =
+    try
+      let line = input_line ic in
+      let meth, path =
+        try Scanf.sscanf line "%s %s HTTP/1.1\r" (fun x y->x,y)
+        with _ -> raise (Bad_req (400, "Invalid request line"))
+      in
+      let meth = Meth.of_string meth in
+      let headers = Headers.parse_ ic in
+      let body = match List.assoc "Content-Length" headers |> int_of_string with
+        | exception Not_found -> ""
+        | exception _ -> bad_reqf 400 "invalid content-length"
+        | 0 -> ""
+        | n -> read_body ic n
+      in
+      Ok (Some {meth; path; body; headers})
+    with
+    | End_of_file -> Ok None
+    | Bad_req (c,s) -> Error (c,s)
+    | e ->
+      Error (400, Printexc.to_string e)
+end
+
+module Response = struct
+  type t = {
+    code: Response_code.t;
+    headers: Headers.t;
+    body: string;
+  }
+
+  let make ?(headers=[]) ~code body : t =
+    (* add 'content length' to response *)
+    let headers = List.filter (fun (k,_) -> k <> "Content-Length") headers in
+    let headers = ("Content-Length", string_of_int (String.length body)) :: headers in
+    { code; headers; body; }
+
+  let make_ok ?headers body = make ~code:200 ?headers body
+  let make_not_found ?headers body = make ~code:404 ?headers body
+  let make_error ?headers body = make ~code:500 ?headers body
+
+  let pp out self : unit =
+    Format.fprintf out "{@[code=%d;@ headers=%a;@ body=%S@]}"
+      self.code Headers.pp self.headers self.body
+
+  let output_ (oc:out_channel) (self:t) : unit =
+    Printf.fprintf oc "HTTP/1.1 %d %s\r\n" self.code (Response_code.descr self.code);
+    List.iter (fun (k,v) -> Printf.fprintf oc "%s: %s\r\n" k v) self.headers;
+    Printf.fprintf oc "\r\n";
+    if self.body<>"" then (
+      output_string oc self.body;
+    );
+    flush oc
+end
+
+type t = {
+  addr: string;
+  port: int;
+  fork: (unit -> unit) -> unit;
+  masksigpipe: bool;
+  mutable handler: (Request.t -> Response.t);
+  mutable path_handlers : (Request.t -> (unit -> Response.t) option) list;
+  mutable running: bool;
+}
+
+let addr self = self.addr
+let port self = self.port
+
+let set_top_handler self f = self.handler <- f
+
+let add_path_handler ?meth self fmt f =
+  let ph req: (unit -> Response.t) option =
+    match meth with
+    | Some m when m <> req.Request.meth -> None (* ignore *)
+    | _ ->
+      try Some (Scanf.sscanf req.Request.path fmt (f req))
+      with _ -> None
+  in
+  self.path_handlers <- ph :: self.path_handlers
+
+let create
+    ?(masksigpipe=true)
+    ?(fork=(fun f -> ignore (Thread.create f () : Thread.t)))
+    ?(addr="127.0.0.1") ?(port=8080) () : t =
+  let handler _req = Response.make_not_found "no top handler" in
+  { fork; addr; port; masksigpipe; handler; running= true;
+    path_handlers=[]; }
+
+let stop s = s.running <- false
+
+let find_map f l =
+  let rec aux f = function
+    | [] -> None
+    | x::l' ->
+      match f x with
+        | Some _ as res -> res
+        | None -> aux f l'
+  in aux f l
+
+let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit =
+  let ic = Unix.in_channel_of_descr client_sock in
+  let oc = Unix.out_channel_of_descr client_sock in
+  let handler = self.handler in
+  let ph_handlers = self.path_handlers in
+  let continue = ref true in
+  while !continue && self.running do
+    match Request.parse_ ic with
+    | Ok None -> continue := false
+    | Error (c,s) ->
+      let res = Response.make ~code:c s in
+      Response.output_ oc res
+    | Ok (Some req) ->
+      let res =
+        let run_handler =
+          match find_map (fun ph -> ph req) ph_handlers with
+          | Some f -> f
+          | None -> (fun () -> handler req)
+        in
+        try run_handler()
+        with
+        | e ->
+          Response.make ~code:500 ("server error: " ^ Printexc.to_string e)
+      in
+      Response.output_ oc res
+    | exception Sys_error _ ->
+      continue := false; (* connection broken somehow *)
+      Unix.close client_sock;
+  done
+
+let run (self:t) : (unit,_) result =
+  try
+    if self.masksigpipe then (
+      ignore (Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigpipe] : _ list);
+    );
+    let sock = Unix.socket ~cloexec:true PF_INET Unix.SOCK_STREAM 0 in
+    let inet_addr = Unix.inet_addr_of_string self.addr in
+    Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port));
+    Unix.listen sock 10;
+    while self.running do
+      let client_sock, _ = Unix.accept sock in
+      self.fork
+        (fun () -> handle_client_ self client_sock);
+    done;
+    Ok ()
+  with e -> Error e
diff --git a/src/SimpleHTTPServer.mli b/src/SimpleHTTPServer.mli
new file mode 100644
index 00000000..f87d98da
--- /dev/null
+++ b/src/SimpleHTTPServer.mli
@@ -0,0 +1,88 @@
+
+module Meth : sig
+  type t = [
+    | `GET
+    | `PUT
+    | `POST
+    | `HEAD
+  ]
+
+  val pp : Format.formatter -> t -> unit
+  val to_string : t -> string
+end
+
+module Headers : sig
+  type t = (string * string) list
+  val pp : Format.formatter -> t -> unit
+end
+
+module Request : sig
+  type t
+
+  val pp : Format.formatter -> t -> unit
+
+  val headers : t -> Headers.t
+  val meth : t -> Meth.t
+  val path : t -> string
+  val body : t -> string
+end
+
+module Response_code : sig
+  type t = int
+
+  val descr : t -> string
+end
+
+module Response : sig
+  type t
+
+  val make :
+    ?headers:Headers.t ->
+    code:Response_code.t ->
+    string ->
+    t
+
+  val make_ok : ?headers:Headers.t -> string -> t
+  val make_not_found : ?headers:Headers.t -> string -> t
+  val make_error : ?headers:Headers.t -> string -> t
+
+  val pp : Format.formatter -> t -> unit
+end
+
+
+type t
+
+val create :
+  ?masksigpipe:bool ->
+  ?fork:((unit -> unit) -> unit) ->
+  ?addr:string ->
+  ?port:int ->
+  unit ->
+  t
+
+val addr : t -> string
+val port : t -> int
+  
+val set_top_handler : t -> (Request.t -> Response.t) -> unit
+(** Setup a handler called by default.
+    If not installed, unhandled paths will return a 404 not found. *)
+
+val add_path_handler :
+  ?meth:Meth.t ->
+  t ->
+  ('a, Scanf.Scanning.in_channel, 'b, 'c -> unit -> Response.t, 'a -> 'd, 'd) format6 ->
+  (Request.t -> 'c) -> unit
+(** [add_path_handler server "/some/path/%s@/%d/" f]
+    calls [f request "foo" 42 ()] when a request with path "some/path/foo/42/"
+    is received.
+    This uses {!Scanf}'s splitting, which has some gotchas (in particular,
+    ["%s"] is eager, so it's generally necessary to delimit its
+    scope with a ["@/"] delimiter. The "@" before a character indicates it's
+    a separator.
+    @param meth if provided, only accept requests with the given method
+*)
+
+val stop : t -> unit
+val run : t -> (unit, exn) result
+
+
diff --git a/src/dune b/src/dune
new file mode 100644
index 00000000..a80dee9f
--- /dev/null
+++ b/src/dune
@@ -0,0 +1,6 @@
+
+(library
+  (name simplehttpserver)
+  (public_name simplehttpserver)
+  (libraries threads)
+  (wrapped false))
diff --git a/src/examples/dune b/src/examples/dune
new file mode 100644
index 00000000..bdcdcd7a
--- /dev/null
+++ b/src/examples/dune
@@ -0,0 +1,4 @@
+
+(executables
+  (names echo)
+  (libraries simplehttpserver))
diff --git a/src/examples/echo.ml b/src/examples/echo.ml
new file mode 100644
index 00000000..60723081
--- /dev/null
+++ b/src/examples/echo.ml
@@ -0,0 +1,15 @@
+
+module S = SimpleHTTPServer
+
+let () =
+  let server = S.create () in
+  (* say hello *)
+  S.add_path_handler ~meth:`GET server
+    "/hello/%s@/" (fun _req name () -> S.Response.make_ok ("hello " ^name ^"!\n"));
+  (* echo request *)
+  S.add_path_handler server
+    "/echo" (fun req () -> S.Response.make_ok (Format.asprintf "echo:@ %a@." S.Request.pp req));
+  Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server);
+  match S.run server with
+  | Ok () -> ()
+  | Error e -> raise e