web-request-peer-details
This commit is contained in:
parent
16d9dd27c9
commit
7b5b866a6d
|
@ -11,6 +11,7 @@
|
||||||
append-resource-path
|
append-resource-path
|
||||||
|
|
||||||
(struct-out web-request)
|
(struct-out web-request)
|
||||||
|
(struct-out web-request-peer-details)
|
||||||
(struct-out web-request-header)
|
(struct-out web-request-header)
|
||||||
(struct-out web-request-cookie)
|
(struct-out web-request-cookie)
|
||||||
web-request-header-content-type
|
web-request-header-content-type
|
||||||
|
@ -77,6 +78,7 @@
|
||||||
(struct web-resource (virtual-host path) #:prefab)
|
(struct web-resource (virtual-host path) #:prefab)
|
||||||
|
|
||||||
(struct web-request (id direction header* body) #:prefab)
|
(struct web-request (id direction header* body) #:prefab)
|
||||||
|
(struct web-request-peer-details (id local-ip local-port remote-ip remote-port) #:prefab)
|
||||||
(struct web-request-header (method resource headers query) #:prefab)
|
(struct web-request-header (method resource headers query) #:prefab)
|
||||||
(struct web-request-cookie (id name value domain path) #:prefab)
|
(struct web-request-cookie (id name value domain path) #:prefab)
|
||||||
|
|
||||||
|
@ -119,7 +121,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Ground-level communication messages
|
;; Ground-level communication messages
|
||||||
|
|
||||||
(struct web-raw-request (id port connection req control-ch) #:prefab)
|
(struct web-raw-request (id port connection addresses req control-ch) #:prefab)
|
||||||
(struct web-raw-client-conn (id connection) #:prefab)
|
(struct web-raw-client-conn (id connection) #:prefab)
|
||||||
(struct web-incoming-message (id message) #:prefab)
|
(struct web-incoming-message (id message) #:prefab)
|
||||||
|
|
||||||
|
@ -291,7 +293,7 @@
|
||||||
(channel-get k-ch)
|
(channel-get k-ch)
|
||||||
(log-syndicate/drivers/web-info "Stopped HTTP listener on port ~v" port))
|
(log-syndicate/drivers/web-info "Stopped HTTP listener on port ~v" port))
|
||||||
|
|
||||||
(on (message (inbound (web-raw-request $id port $conn $lowlevel-req $control-ch)))
|
(on (message (inbound (web-raw-request $id port $conn $addresses $lowlevel-req $control-ch)))
|
||||||
(define web-req (web-request id
|
(define web-req (web-request id
|
||||||
'inbound
|
'inbound
|
||||||
(web-request-header
|
(web-request-header
|
||||||
|
@ -307,6 +309,8 @@
|
||||||
(for [(c (request-cookies lowlevel-req))]
|
(for [(c (request-cookies lowlevel-req))]
|
||||||
(match-define (client-cookie n v d p) c)
|
(match-define (client-cookie n v d p) c)
|
||||||
(assert (web-request-cookie id n v d p)))
|
(assert (web-request-cookie id n v d p)))
|
||||||
|
(match-let ([(list Lip Lport Rip Rport) addresses])
|
||||||
|
(assert (web-request-peer-details id Lip Lport Rip Rport)))
|
||||||
(on-start (send! (set-timer (list 'web-req id) 100 'relative))
|
(on-start (send! (set-timer (list 'web-req id) 100 'relative))
|
||||||
(send! web-req))
|
(send! web-req))
|
||||||
;; TODO: protocol for 500 Internal server error
|
;; TODO: protocol for 500 Internal server error
|
||||||
|
@ -402,6 +406,9 @@
|
||||||
;; via synchronous channels.
|
;; via synchronous channels.
|
||||||
(define conn
|
(define conn
|
||||||
(new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
|
(new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f))
|
||||||
|
(define addresses
|
||||||
|
(let-values (((Lip Lport Rip Rport) (tcp-addresses i #t)))
|
||||||
|
(list Lip Lport Rip Rport)))
|
||||||
(define control-ch (make-channel))
|
(define control-ch (make-channel))
|
||||||
(let do-request ()
|
(let do-request ()
|
||||||
(define-values (req initial-headers) ;; TODO initial-headers?!?!
|
(define-values (req initial-headers) ;; TODO initial-headers?!?!
|
||||||
|
@ -410,7 +417,7 @@
|
||||||
(when req
|
(when req
|
||||||
(define id (gensym 'web))
|
(define id (gensym 'web))
|
||||||
(define start-ms (current-inexact-milliseconds))
|
(define start-ms (current-inexact-milliseconds))
|
||||||
(send-ground-message (web-raw-request id listen-port conn req control-ch))
|
(send-ground-message (web-raw-request id listen-port conn addresses req control-ch))
|
||||||
(sync (handle-evt control-ch
|
(sync (handle-evt control-ch
|
||||||
(lambda (msg)
|
(lambda (msg)
|
||||||
(define delay-ms (inexact->exact
|
(define delay-ms (inexact->exact
|
||||||
|
|
Loading…
Reference in New Issue