correctly handle x-forwarded-for

src/http/dispatcher.lisp

@@ -37,7 +37,8 @@
 	   (respond-http con done :code  404 :banner  "Not found"
 			 :body (funcall (my error-responder) me path params))))
       (error (e)
-	(format *error-output* "ERROR ~A~&--- ~A~&" (strcat (my canonical-name) path) (backtrace-description e))
+	(format *error-output* "ERROR ~A~&--- ~A~&" (strcat (my canonical-name) path) 
+		(backtrace-description e))
 	(respond-http con done
 		      :body (with-sendbuf () "<h1>I programmed this thoughtlessly. Sorry for the inconvenience.</h1>")
 		      :code 500

src/http/serve.lisp

@@ -6,6 +6,14 @@
 (defun http-serve-wait-timeout ()
   120)
 
+(defconstant-bv +http-param-origin+ (force-byte-vector 'http-peer-info!))
+
+(defun match-x-forwarded-for (value)
+  (match-bind
+   (+ (and (char) (progn host (or (progn "," (* (space))) (last)))))
+   value
+   host))
+
 (defprotocol http-serve (con)
   (reset-timeout con (http-serve-wait-timeout))
   (match-bind (method (+ (space)) url (or (last) (+ (space)))
@@ -14,6 +22,7 @@
     (reset-timeout con (http-serve-timeout))
     (let ((request-content-length 0)
 	  host
+	  (request-origin (con-peer-info con))
 	  (connection-close (not (or (< 1 version-major) (and (= 1 version-major) (< 0 version-minor))))))
 	(io 'process-headers con (without-call/cc (lambda(name value)
 						    (unless (zerop (length value))
@@ -27,16 +36,19 @@
 												    (lambda(word)
 												      (case-match-fold-ascii-case word
 																  ("close" (setf connection-close t))
-																  ("keep-alive" (setf connection-close nil))) ))))))))
+																  ("keep-alive" (setf connection-close nil))) )))
+										  ("x-forwarded-for" 
+										   (setf request-origin
+											 (match-x-forwarded-for value))))))))
       (let ((request-body
 	     (unless (zerop request-content-length)
 	       (io 'recv con request-content-length))))
-	(io 'parse-and-dispatch con url :request-body request-body :host host))
+	(io 'parse-and-dispatch con url :request-body request-body :host host :origin request-origin))
       (if connection-close
 	  (hangup con)
 	  (io 'http-serve con)))))
 
-(defprotocol parse-and-dispatch (con path-and-args &key request-body host)
+(defprotocol parse-and-dispatch (con path-and-args &key request-body host origin)
   (let (params tmp)
     (without-call/cc
       (flet ((parse-params (str)
@@ -49,6 +61,13 @@
 	    path-and-args
 	  (parse-params q)
 	  (parse-params request-body)
-	  (setf tmp path))))
+	  (setf tmp path)))
+      (push (cons +http-param-origin+ origin) params)) ; makes sure it's first so it can't be overridden by the user
     (io 'dispatch con tmp :params params :host host)))
 
+
+
+(defun http-start-server (port)
+  (let ((socket (tpd2.io:make-con-listen :port port)))
+    (tpd2.io:launch-io 'tpd2.io:accept-forever socket 'tpd2.http:http-serve)
+    socket))

src/io/con.lisp

@@ -2,7 +2,7 @@
 
 (defstruct (con (:constructor %make-con))
   socket
-  peer-info
+  (peer-info nil :type (or null byte-vector))
   (recv (make-recvbuf) :type recvbuf)
   timeout
 

src/io/posix-socket.lisp

@@ -47,7 +47,7 @@
 		 (set-fd-nonblock s)
 		 (make-con 
 		  :socket s
-		  :peer-info (sockaddr-address-string sa))))))))
+		  :peer-info (sockaddr-address-bv sa))))))))
 
 
 (defmethod socket-close ( (fd integer) )

src/io/syscalls.lisp

@@ -467,7 +467,15 @@
   (defun sockaddr-address-string (sa)
     (declare (optimize speed (safety 0)))
     (let ((addr (cffi:foreign-slot-value sa 'sockaddr_in 'addr)))
-      #.`(strcat ,@(loop for i below 4 unless (= i 0) collect "." collect `(the simple-string (aref octet-to-string (ldb (byte 8 (* 8 ,i)) addr) )))))))
+      #.`(strcat ,@(loop for i below 4 unless (= i 0) collect "." collect `(the simple-string (aref octet-to-string (ldb (byte 8 (* 8 ,i)) addr))))))))
+
+(let ((octet-to-bv (make-array 256 :element-type 'simple-byte-vector :initial-contents (loop for i from 0 below 256 collect (force-byte-vector (princ-to-string i))))))
+  (defun sockaddr-address-bv (sa)
+    (declare (optimize speed (safety 0)))
+    (let ((addr (cffi:foreign-slot-value sa 'sockaddr_in 'addr)))
+      #.`(byte-vector-cat 
+	  ,@(loop for i below 4 unless (= i 0) collect (force-byte-vector ".") 
+		  collect `(the simple-byte-vector (aref octet-to-bv (ldb (byte 8 (* 8 ,i)) addr))))))))
 
 (defun new-socket-helper (&key 
 			  port 

src/lib/one-liners.lisp

@@ -66,4 +66,9 @@
 (defmacro defconstant-string (name value &optional documentation)
   `(define-constant ,name ,value
      :test 'string=
-     ,@(when documentation `((:documentation ,documentation)))))
+     ,@(when documentation `((:documentation ,documentation)))))
+
+(defmacro defconstant-bv  (name value &optional documentation)
+  `(define-constant ,name (force-byte-vector ,value)
+     :test 'equalp
+     ,@(when documentation `((:documentation ,documentation)))))

src/packages.lisp

@@ -50,6 +50,7 @@
    #:once-only
    #:define-constant
    #:defconstant-string
+   #:defconstant-bv
 
    #:copy-byte-vector
    #:make-byte-vector
@@ -216,7 +217,11 @@
    #:*default-dispatcher*
    #:dispatcher-add-alias
    #:find-or-make-dispatcher
-   #:http-parse-and-generate-response))
+   #:http-parse-and-generate-response
+   #:+http-param-origin+
+
+   #:http-start-server
+   ))
 
 (defpackage #:teepeedee2.ml
   (:nicknames #:tpd2.ml)
@@ -312,6 +317,7 @@
    #:with-compile-time-site
    #:defsite
    #:current-site
+
    ))
 
 

src/webapp/html-constants.lisp

@@ -12,6 +12,5 @@
 (defconstant-string +html-class-scroll-to-bottom+ "-scroll-to-bottom-")
 (defconstant-string +html-class-collapsed+ "-collapsed-")
 
-(alexandria:define-constant +http-header-html-content-type+
-    (byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)
-  :test 'equalp)
+(defconstant-bv +http-header-html-content-type+
+    (byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+))

src/webapp/page.lisp

@@ -1,8 +1,10 @@
 (in-package #:tpd2.webapp)
 
 (defvar *webapp-frame*)
-(define-constant +webapp-frame-id-param+ (force-byte-vector ".webapp-frame.")
-  :test 'equalp)
+(defconstant-bv +webapp-frame-id-param+ ".webapp-frame.")
+
+(defun-speedy get-http-param (params name)
+  (alist-get params name :test #'byte-vector=-fold-ascii-case))
 
 (define-constant +web-safe-chars+ 
   (force-byte-vector 
@@ -17,29 +19,29 @@
 	(arg-values (mapcar (lambda(x)(second (force-list x))) defaulting-lambda-list)))
     (flet ((xlate (name)
 	     (case name 
-	       (all-http-params! params-var)
-	       (http-peer-info! `(con-peer-info ,con-var)))))
+	       (all-http-params! params-var))))
      (loop for name in arg-names
 	   for value in arg-values
 	   for xlated = (xlate name)
 	   collect (intern (force-string name) :keyword)
 	   if xlated
 	   collect xlated 
 	   else
-	   collect (let ((val-form `(alist-get ,params-var ,(force-byte-vector name) 
-					       :test #'byte-vector=-fold-ascii-case)))
+	   collect (let ((val-form `(get-http-param ,params-var ,(force-byte-vector name))))
 		     (if value
 			 `(or ,val-form
 			      ,value)
 			 val-form))))))
 
-(defmacro with-webapp-frame ((con params &key (create-frame t)) &body body)
-  (check-symbols params con)
+(defmacro with-webapp-frame ((params &key (create-frame t)) &body body)
+  (check-symbols params)
   `(let ((*webapp-frame*
-	  (awhen (alist-get ,params +webapp-frame-id-param+ :test #'byte-vector=-fold-ascii-case)
+	  (awhen (get-http-param ,params +webapp-frame-id-param+)
 		 (find-frame it))))
      (when ,(if create-frame t `(webapp-frame-available-p))
-       (setf (frame-trace-info (webapp-frame :site (current-site))) (con-peer-info con))
+       (setf (frame-trace-info (webapp-frame :site (current-site))) 
+	     (get-http-param
+	      ,params tpd2.http:+http-param-origin+))
        (frame-reset-timeout (webapp-frame)))
      (locally
 	 ,@body)))
@@ -53,7 +55,7 @@
 					 :defaulting-lambda-list defaulting-lambda-list))))
 
 (defmacro apply-page-call ((&key con function create-frame) &rest args)
-  `(with-webapp-frame (,con all-http-params! :create-frame ,create-frame)
+  `(with-webapp-frame (all-http-params! :create-frame ,create-frame)
      (apply-page-call-without-frame ,con ,function ,@args)))
 
 (defmacro defpage-lambda (path function &key defaulting-lambda-list (create-frame t))