geminid

A Sandboxed Gemini server
git clone git@git.mpah.dev/geminid.git
Log | Files | Refs | README

server.ml (2411B)

      1 open Lwt
      2 open Lwt.Syntax
      3 open Config
      4 open Response
      5 
      6 exception Bad of string
      7 
      8 let init_socket config =
      9   let open Lwt_unix in
     10   let sock = config.sock in
     11   setsockopt sock SO_REUSEADDR true;
     12   let addr = ADDR_INET (config.host, config.port) in
     13   bind sock addr >|= fun () -> listen sock config.max_req
     14 
     15 let init_ssl config =
     16   let+ cert = X509_lwt.private_of_pems ~cert:config.cert ~priv_key:config.key in
     17   Tls.Config.server ~reneg:true ~certificates:(`Single cert) ~version:config.tls ()
     18 
     19 let receive server config = Tls_lwt.Unix.accept server config.sock
     20 
     21 let read session =
     22   let buf = Cstruct.create (1024 + 2) in
     23   let+ len = Tls_lwt.Unix.read session buf in
     24   let msg = Cstruct.to_string @@ Cstruct.sub buf 0 len in
     25   let req =
     26     if Text.ends_with msg "\r\n"
     27     then (
     28       match Text.check @@ Uri.pct_decode @@ msg with
     29       | None   -> msg
     30       | Some _ -> raise (Bad "Bad Request Encoding"))
     31     else "" (* request is too long, so we send an empty one *)
     32   in
     33   Uri.of_string @@ Text.strip req
     34 
     35 let pipe fdin fdout =
     36   let open Lwt_io in
     37   write_lines fdout
     38   @@ read_lines
     39   @@ of_unix_fd ~mode:Input
     40   @@ Unix.descr_of_in_channel fdin
     41 
     42 (** The status line is a single UTF-8 line formatted as:
     43     <STATUS><SPACE><META><CR><LF> *)
     44 let write_header session status meta =
     45   Tls_lwt.Unix.write session
     46   @@ Cstruct.of_string
     47   @@ Text.encode ~encoding:"utf-8"
     48   @@ Printf.sprintf "%d %s\r\n" (int_of_status status) meta
     49 
     50 let write_body session status meta fd =
     51   write_header session status meta >>= fun () -> pipe fd (snd @@ Tls_lwt.of_t session)
     52 
     53 let write_response session resp =
     54   (match resp with
     55   | Head (status, meta)     -> write_header session status meta
     56   | Body (status, meta, fd) -> write_body session status meta fd)
     57   >>= fun () -> Tls_lwt.Unix.close_tls session
     58 
     59 
     60 let initialize config =
     61   let* _ = init_socket config in
     62   let* s = init_ssl config in
     63   let _ = Sys.chdir config.dir in
     64   Lwt.return s
     65 
     66 let main (config) =
     67   let* server = initialize config in
     68   let rec loop () =
     69     let* session, addr = receive server config in
     70     let a = match addr with 
     71     | Unix.ADDR_INET (a, _) -> (Unix.string_of_inet_addr a) ^ ":" ^ (string_of_int config.port)
     72     |  _ -> failwith "not INET" in
     73     let* request = read session in
     74     print_endline (a ^ "    " ^ Uri.path request);
     75     let resp = handle request in
     76     let* res = write_response session resp in
     77     loop res
     78   in
     79   loop ()