<commit_before>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; embedded HTTP/1.1 server
package: std/net

(import :gerbil/gambit/threads
        :gerbil/gambit/exceptions
        :gerbil/gambit/os
        :std/os/socket
        :std/net/server
        :std/net/bio
        :std/actor/message
        :std/actor/proto
        :std/misc/sync
        :std/text/utf8
        :std/logger
        :std/sugar
        :std/error
        :std/pregexp
        (only-in :std/srfi/1 reverse!)
        (only-in :std/srfi/13 string-titlecase!)
        (only-in :std/srfi/19 date->string current-date))

(export http-request?
        http-request-method http-request-url http-request-path http-request-params
        http-request-proto http-request-client
        http-request-body
        http-response?
        http-response-write
        http-response-begin http-response-chunk http-response-end
        http-response-force-output
        current-http-server
        start-http-server!
        stop-http-server!
        http-register-handler
        set-httpd-request-timeout!
        set-httpd-response-timeout!)

(defstruct http-request (buf client method url path params proto headers data)
  final: #t)
(defstruct http-response (buf output close?)
  final: #t)

(defproto httpd
  (register path handler)
  event:
  (join thread)
  (shutdown))

(def current-http-server
  (make-parameter #f))

(def (start-http-server! addr . addrs)
  (start-logger!)
  (let* ((socksrv (start-socket-server!))
         (sas (map socket-address (cons addr addrs)))
         (socks (map (cut server-listen socksrv <>) sas)))
    (spawn http-server socks sas)))

(def (stop-http-server! httpd)
  (!!httpd.shutdown httpd)
  (thread-join! httpd))

;; handler: lambda (request response)
(def (http-register-handler httpd path handler)
  (if (string? path)
    (if (procedure? handler)
      (!!httpd.register httpd path handler)
      (error "Bad handler; expected procedure" handler))
    (error "Bad path; expected string" path)))

;;; implementation
(def (http-server socks sas)
  (def handlers
    (make-sync-hash (make-hash-table)))

  (def acceptors
    (map (lambda (sock sa)
           (spawn http-server-accept handlers sock (socket-address-family sa)))
         socks sas))

  (def (shutdown!)
    (for-each server-close socks))

  (def (monitor thread)
    (def (join server thread)
      (with-catch void (cut thread-join! thread))
      (!!httpd.join server thread))
    (spawn/name 'http-server-monitor join (current-thread) thread))

  (def (loop)
    (<- ((!httpd.register path handler k)
         (sync-hash-put! handlers path handler)
         (!!value (void) k)
         (loop))
        ((!httpd.shutdown)
         (void))
        ((!httpd.join thread)
         (try
          (thread-join! thread)
          (warning "acceptor thread ~a exited unexpectedly" (thread-name thread))
          (catch (uncaught-exception? e)
            (log-error "acceptor error" (uncaught-exception-reason e)))
          (catch (e)
            (log-error "acceptor error" e)))
         (loop))
        (bogus
         (warning "unexpected message ~a" bogus)
         (loop))))

  (try
   (for-each monitor acceptors)
   (loop)
   (catch (e)
     (log-error "unhandled exception" e)
     (raise e))
   (finally
    (shutdown!))))

(def (http-server-accept handlers sock safamily)
  (def cliaddr (make-socket-address safamily))
  (while #t
    (try
     (let (clisock (server-accept sock cliaddr))
       (spawn http-request-handler handlers clisock (socket-address->address cliaddr)))
     (catch (os-exception? e)
       (log-error "error accepting connection" e)))))


(def (http-request-handler handlers sock addr)
  (def ibuf (open-server-input-buffer sock))
  (def obuf (open-server-output-buffer sock))

  (def (get-handler path)
    (sync-hash-do handlers
      (lambda (ht)
        (let lp ((path path))<commit_msg>std/net/httpd: use spawn/name, a lot faster than spawn<commit_after>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; embedded HTTP/1.1 server
package: std/net

(import :gerbil/gambit/threads
        :gerbil/gambit/exceptions
        :gerbil/gambit/os
        :std/os/socket
        :std/net/server
        :std/net/bio
        :std/actor/message
        :std/actor/proto
        :std/misc/sync
        :std/text/utf8
        :std/logger
        :std/sugar
        :std/error
        :std/pregexp
        (only-in :std/srfi/1 reverse!)
        (only-in :std/srfi/13 string-titlecase!)
        (only-in :std/srfi/19 date->string current-date))

(export http-request?
        http-request-method http-request-url http-request-path http-request-params
        http-request-proto http-request-client
        http-request-body
        http-response?
        http-response-write
        http-response-begin http-response-chunk http-response-end
        http-response-force-output
        current-http-server
        start-http-server!
        stop-http-server!
        http-register-handler
        set-httpd-request-timeout!
        set-httpd-response-timeout!)

(defstruct http-request (buf client method url path params proto headers data)
  final: #t)
(defstruct http-response (buf output close?)
  final: #t)

(defproto httpd
  (register path handler)
  event:
  (join thread)
  (shutdown))

(def current-http-server
  (make-parameter #f))

(def (start-http-server! addr . addrs)
  (start-logger!)
  (let* ((socksrv (start-socket-server!))
         (sas (map socket-address (cons addr addrs)))
         (socks (map (cut server-listen socksrv <>) sas)))
    (spawn http-server socks sas)))

(def (stop-http-server! httpd)
  (!!httpd.shutdown httpd)
  (thread-join! httpd))

;; handler: lambda (request response)
(def (http-register-handler httpd path handler)
  (if (string? path)
    (if (procedure? handler)
      (!!httpd.register httpd path handler)
      (error "Bad handler; expected procedure" handler))
    (error "Bad path; expected string" path)))

;;; implementation
(def (http-server socks sas)
  (def handlers
    (make-sync-hash (make-hash-table)))

  (def acceptors
    (map (lambda (sock sa)
           (spawn http-server-accept handlers sock (socket-address-family sa)))
         socks sas))

  (def (shutdown!)
    (for-each server-close socks))

  (def (monitor thread)
    (def (join server thread)
      (with-catch void (cut thread-join! thread))
      (!!httpd.join server thread))
    (spawn/name 'http-server-monitor join (current-thread) thread))

  (def (loop)
    (<- ((!httpd.register path handler k)
         (sync-hash-put! handlers path handler)
         (!!value (void) k)
         (loop))
        ((!httpd.shutdown)
         (void))
        ((!httpd.join thread)
         (try
          (thread-join! thread)
          (warning "acceptor thread ~a exited unexpectedly" (thread-name thread))
          (catch (uncaught-exception? e)
            (log-error "acceptor error" (uncaught-exception-reason e)))
          (catch (e)
            (log-error "acceptor error" e)))
         (loop))
        (bogus
         (warning "unexpected message ~a" bogus)
         (loop))))

  (try
   (for-each monitor acceptors)
   (loop)
   (catch (e)
     (log-error "unhandled exception" e)
     (raise e))
   (finally
    (shutdown!))))

(def (http-server-accept handlers sock safamily)
  (def cliaddr (make-socket-address safamily))
  (while #t
    (try
     (let (clisock (server-accept sock cliaddr))
       (spawn/name 'http-request-handler
                   http-request-handler handlers clisock (socket-address->address cliaddr)))
     (catch (os-exception? e)
       (log-error "error accepting connection" e)))))


(def (http-request-handler handlers sock addr)
  (def ibuf (open-server-input-buffer sock))
  (def obuf (open-server-output-buffer sock))

  (def (get-handler path)
    (sync-hash-do handlers
      (lambda (ht)
        (let lp ((path path))
{'fraction_non_alphanumeric': 0.13546578310182236, 'fraction_numerical': 0.0020389957945711737, 'mean_word_length': 2.472566371681416, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4079657', 'n_tokens_mistral': 2554, 'n_tokens_neox': 2514, 'n_words': 645}