Welcome to the CHICKEN Scheme pasting service

(module feathers-http-parser

;; exports
(read-request
 http-connection
 destroy-connection!
 make-request
 request-method
 request-method-set!
 request-url
 request-url-set!
 request-path
 request-path-set!
 request-query
 request-query-set!
 request-headers
 request-headers-set!
 request-headers-ref
 request-port
 request-port-set!
 request-keep-alive
 request-keep-alive-set!
 split-path-string
 http-chunk-size)

(import scheme chicken foreign)

(use lolevel
     ports
     srfi-13
     srfi-69
     defstruct
     data-structures
     uri-common
     miscmacros)

(define http-chunk-size (make-parameter 1024))

(foreign-declare "#include \"http-parser/http_parser.h\"")

(define HTTP_REQUEST
  (foreign-value "HTTP_REQUEST" int))

(define PAUSED
  (foreign-value "HPE_PAUSED" int))

(define-syntax method
  (syntax-rules ()
    ((_ name symbol)
     (cons (foreign-value name int) (quote symbol)))))

(define METHODS
  (alist->hash-table
    (list
      ;; Request Methods
      (method "HTTP_DELETE" DELETE)
      (method "HTTP_GET" GET)
      (method "HTTP_HEAD" HEAD)
      (method "HTTP_POST" POST)
      (method "HTTP_PUT" PUT)
      ;; pathological
      (method "HTTP_CONNECT" CONNECT)
      (method "HTTP_OPTIONS" OPTIONS)
      (method "HTTP_TRACE" TRACE)
      ;; WebDAV
      (method "HTTP_COPY" COPY)
      (method "HTTP_LOCK" LOCK)
      (method "HTTP_MKCOL" MKCOL)
      (method "HTTP_MOVE" MOVE)
      (method "HTTP_PROPFIND" PROPFIND)
      (method "HTTP_PROPPATCH" PROPPATCH)
      (method "HTTP_SEARCH" SEARCH)
      (method "HTTP_UNLOCK" UNLOCK)
      (method "HTTP_BIND" BIND)
      (method "HTTP_REBIND" REBIND)
      (method "HTTP_UNBIND" UNBIND)
      (method "HTTP_ACL" ACL)
      ;; subversion
      (method "HTTP_REPORT" REPORT)
      (method "HTTP_MKACTIVITY" MKACTIVITY)
      (method "HTTP_CHECKOUT" CHECKOUT)
      (method "HTTP_MERGE" MERGE)
      ;; upnp
      (method "HTTP_MSEARCH" MSEARCH)
      (method "HTTP_NOTIFY" NOTIFY)
      (method "HTTP_SUBSCRIBE" SUBSCRIBE)
      (method "HTTP_UNSUBSCRIBE" UNSUBSCRIBE)
      ;; RFC-5789
      (method "HTTP_PATCH" PATCH)
      (method "HTTP_PURGE" PURGE)
      ;; CalDAV
      (method "HTTP_MKCALENDAR" MKCALENDAR))
    size: 31
    hash: number-hash
    test: =))

(define method->symbol
  (cut hash-table-ref METHODS <>))

(define parser-request
  (foreign-lambda* scheme-object
    (((nonnull-c-pointer (struct http_parser)) parser))
    "C_return(CHICKEN_gc_root_ref(parser->data));"))

(define parser-method
  (foreign-lambda* unsigned-int
    (((nonnull-c-pointer (struct http_parser)) parser))
    "C_return(parser->method);"))

(define parser-error
  (foreign-lambda* unsigned-int
    (((const (nonnull-c-pointer (struct http_parser))) parser))
    "C_return(parser->http_errno);"))

(define error-description
  (foreign-lambda* c-string ((int errno))
    "C_return(http_errno_description(errno));"))

(define-external
  (on_message_begin ((nonnull-c-pointer (struct http_parser)) parser)) int
  ;(print "message_begin")
  0)

(define-external
  (on_url ((nonnull-c-pointer (struct http_parser)) parser)
          ((const c-string) at)
          (size_t len)) int
  ;(printf "url: ~S~n" (string-take at len))
  (let ((req (parser-request parser)))
    (request-url-set! req
      (string-append/shared (request-url req) (string-take at len))))
  0)

(define-external
  (on_header_field ((nonnull-c-pointer (struct http_parser)) parser)
                   ((const c-string) at)
                   (size_t len)) int
  ;(printf "header_field: ~S~n" (string-take at len))
  (let* ((req (parser-request parser))
         (h (request-headers req)))
    (if (and (not (null? h)) (string? (car h)))
      (set-car! h (string-append/shared
                    (car (request-headers req))
                    (string-downcase! (string-take at len))))
      (request-headers-set! req
        (cons (string-downcase! (string-take at len)) h))))
  0)

(define-external
  (on_header_value ((nonnull-c-pointer (struct http_parser)) parser)
                   ((const c-string) at)
                   (size_t len)) int
  ;(printf "header_value: ~S~n" (string-take at len))
  (let* ((req (parser-request parser))
         (h (request-headers req))
         (curr (car h)))
    (if (pair? curr)
      (set-cdr! curr (string-append/shared (cdr curr) (string-take at len)))
      (set-car! h (cons (string->symbol curr)
                        (string-take at len)))))
  0)

(define http-should-keep-alive
  (foreign-lambda bool "http_should_keep_alive"
    (const (nonnull-c-pointer (struct http_parser)))))

(define (split-path-string str)
  (cons '/ (map uri-decode-string (string-split str "/"))))

(define-external
  (on_headers_complete ((nonnull-c-pointer (struct http_parser)) parser)) int
  ;(print "headers_complete")
  (let ((req (parser-request parser)))
    (request-headers-complete-set! req #t)
    (request-keep-alive-set! req (http-should-keep-alive parser))
    (request-method-set! req (method->symbol (parser-method parser)))
    (let* ((url (request-url req))
           (qi (string-index url #\?)))
      (request-path-set! req
        (split-path-string (if qi (substring url 0 qi) url)))
      (when qi
        (request-query-set! req (form-urldecode (substring url (+ qi 1)))))))
  ;(parser-pause parser 1)
  0)

(define-external
  (on_body ((nonnull-c-pointer (struct http_parser)) parser)
           ((const c-string) at)
           (size_t len)) int
  ;(printf "body: ~S~n" (string-take at len))
  (let ((req (parser-request parser)))
    (request-chunk-position-set! req 0)
    (request-chunk-length-set! req len)
    (request-chunk-data-set! req (string-take at len)))
  0)

(define-external
  (on_message_complete ((nonnull-c-pointer (struct http_parser)) parser)) int
  ;(print "message_complete")
  (let ((req (parser-request parser)))
    (request-complete-set! req #t))
  (parser-pause parser 1)
  0)

(define make-settings
  (foreign-lambda* (nonnull-c-pointer (struct http_parser_settings)) ()
    "struct http_parser_settings *settings = malloc(
       sizeof(struct http_parser_settings)
     );
     memset(settings, 0, sizeof(*settings));
     settings->on_message_begin = on_message_begin;
     settings->on_url = on_url;
     settings->on_header_field = on_header_field;
     settings->on_header_value = on_header_value;
     settings->on_headers_complete = on_headers_complete;
     settings->on_body = on_body;
     settings->on_message_complete = on_message_complete;
     C_return(settings);"))

(define SETTINGS (make-settings))

(define make-parser
  (foreign-lambda* (nonnull-c-pointer (struct http_parser))
    (((enum http_parser_type) parser_type))
    "struct http_parser *parser = malloc(sizeof(struct http_parser));
     http_parser_init(parser, parser_type);
     C_return(parser);"))

(define parse
  (foreign-safe-lambda* size_t
    (((nonnull-c-pointer (struct http_parser)) parser)
     ((const (nonnull-c-pointer (struct http_parser_settings))) settings)
     (c-string buf)
     (int len)
     (scheme-object req))
    "size_t result;
     parser->data = CHICKEN_new_gc_root();
     CHICKEN_gc_root_set(parser->data, req);
     result = http_parser_execute(parser, settings, buf, len);
     CHICKEN_delete_gc_root(parser->data);
     C_return(result);"))

(define parser-pause
  (foreign-lambda void "http_parser_pause"
    (nonnull-c-pointer (struct http_parser))
    int))

(defstruct connection
  parser
  buffer
  buffer-length
  request
  port)

(define-record-printer (connection x out)
  (fprintf out "#" (connection-port x)))

(define (destroy-connection! conn)
  (free (connection-parser conn)))

(define (http-connection port)
  (make-connection
    port: port
    parser: (make-parser HTTP_REQUEST)))

(defstruct request
  method
  (url "")
  path
  (query '())
  (headers '())
  (chunk-position 0)
  (chunk-length 0)
  chunk-data
  headers-complete
  complete
  keep-alive
  port)

(define-record-printer (request x out)
  (fprintf out "#" (request-method x) (request-url x)))

(define (request-headers-ref req name)
  (alist-ref name (request-headers req)))

(define (read-http-chunk p limit)
  (##sys#check-input-port p #t 'read-http-chunk)
  (let ((buffer (##sys#make-string limit)))
    (let loop ((i 0))
      (if (and limit (fx>= i limit))
        (values (##sys#substring buffer 0 i) i)
        (if (or ((##sys#slot (##sys#slot p 2) 6) p) ; char-ready?
                (fx= i 0))
          (let ((c (##sys#read-char-0 p)))
            (if (eof-object? c)
              (if (fx= i 0)
                (values c i)
                (values (##sys#substring buffer 0 i) i))
              (begin
                (##core#inline "C_setsubchar" buffer i c)
                (loop (fx+ i 1)))))
          (values (##sys#substring buffer 0 i) i))))))

(define (connection-read-line conn)
  (let ((buf (connection-buffer conn)))
    (if buf
      (begin
        (connection-buffer-set! conn #f)
        (values buf (connection-buffer-length conn)))
      (read-http-chunk (connection-port conn)
                       (http-chunk-size)))))

(define (parser-execute conn req str len)
  (let* ((parser (connection-parser conn))
         (parsed (parse parser SETTINGS str len req)))
    (when (< parsed len)
      (let ((errno (parser-error parser)))
        (if (= PAUSED errno)
          (begin
            (connection-buffer-set! conn (substring/shared str parsed))
            (connection-buffer-length-set! conn (- len parsed))
            (parser-pause (connection-parser conn) 0))
          (abort (error-description errno)))))))

(define (body-char-ready? req)
  (or (request-complete req)
      (< (request-chunk-position req)
         (request-chunk-length req))))

(define (body-read-char req conn)
  (cond
    ((< (request-chunk-position req) (request-chunk-length req))
     (begin0
       (string-ref (request-chunk-data req) (request-chunk-position req))
       (request-chunk-position-set! req (+ 1 (request-chunk-position req)))))
    ((request-complete req) #!eof)
    (else
      (receive (buf len) (connection-read-line conn)
        (if (= 0 len)
          #!eof
          (begin
            (parser-execute conn req buf len)
            (body-read-char req conn)))))))

(define (make-body-port req conn)
  (make-input-port
    (cut body-read-char req conn) ;; read-char
    (cut body-char-ready? req) ;; char-ready?
    (cut close-input-port (connection-port conn)) ;; close
    #f ;; peek-char
    #f ;; read-string!
    #f ;; read-line
    ))

(define (skip-body req conn)
  (until (request-complete req)
    (receive (buf len) (connection-read-line conn)
      (if (= 0 len)
        (abort "Unexpected end of input")
        (parser-execute conn req buf len)))))

(define (read-headers req conn)
  (until (request-headers-complete req)
    (receive (buf len) (connection-read-line conn)
      (if (= 0 len)
        (abort "Unexpected end of input")
        (parser-execute conn req buf len)))))

(define (read-request conn)
  (when (connection-request conn)
    (skip-body (connection-request conn) conn))
  (let ((req (make-request)))
    (connection-request-set! conn req)
    (read-headers req conn)
    (request-port-set! req (make-body-port req conn))
    req))

)