example.lisp

(in-package :tp)

;; example

;;; utilities

(defun pair* (&rest fns)
  #'(lambda (&rest args)
      (labels ((rec (fns acc)
                 (if (null fns)
                     (nreverse acc)
                     (rec (cdr fns) (cons (apply (car fns) args) acc)))))
        (rec fns nil))))

;;; borrowed from shibuya.lisp

(defmacro zap (op place &rest args)
  `(setf ,place (apply (function ,op) ,place (LIST ,@args))))

;; test web server

(defvar *testing-dispatch-table* nil)

(defvar *testing-acceptor*
  (aprog1 (make-instance 'hunchentoot:acceptor :port 4242)
    (zap (lambda (d)
           #'(lambda (x)
               (let ((hunchentoot:*dispatch-table* *testing-dispatch-table*))
                 (funcall d x))))
         (hunchentoot:acceptor-request-dispatcher it))))

(asdf:oos 'asdf:load-op :hunchentoot-test)

(sunless *testing-dispatch-table*
  (setf it (copy-tree hunchentoot:*dispatch-table*)))

;; the server

(defvar *proxy-acceptor*
  (make-instance 'proxy-acceptor
                 :request-class 'proxy-request
                 :port 4243))

(defun setup ()
  (setq hunchentoot:*message-log-pathname* #p"/tmp/log.txt")
  (setq hunchentoot:*hunchentoot-default-external-format*
        hunchentoot::+utf-8+)
  (setq hunchentoot:*default-content-type* "text/html; charset=utf-8")
  (let ((hs (open "/tmp/h.txt" :direction :output :if-exists :supersede)))
    ;;(setq hunchentoot:*header-stream* hs)
    (setq drakma:*header-stream* hs))
  (setq drakma:*drakma-default-external-format* :utf-8)
  (setq hunchentoot:*dispatch-table*
        (list
         (hunchentoot:create-prefix-dispatcher
          "/testing" (constantly "testing"))
         (hunchentoot:create-prefix-dispatcher
          "/hunchentoot" #'handle-proxy-request)))
  )

(setup)

(dolist (a `(,*testing-acceptor* ,*proxy-acceptor*)) (hunchentoot:start a))

(defun down ()
  (mapc (pair* (compose #'hunchentoot:stop #'symbol-value)
               #'makunbound)
        '(*testing-acceptor* *proxy-acceptor*)))

;;(down)

package.lisp

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :alexandria)
  (require :anaphora)
  (require :chunga)
  (require :cl-ppcre)
  (require :drakma)
  (require :hunchentoot)
  )

(defpackage #:hunchentoot-proxy
  (:nicknames #:tp)
  (:use #:cl #:anaphora #:hunchentoot)
  (:import-from #:alexandria
                with-unique-names compose disjoin curry rcurry))

proxy.lisp

(in-package :tp)

;; turn off the session handling

(defclass proxy-request (request) ())

(defmethod session-verify ((_ proxy-request)) nil)

(defclass proxy-acceptor (acceptor) ())

(defmethod session-cookie-name ((_ proxy-acceptor)) nil)

;; create http-request within a request

(defvar *cookie-jar* nil
  "The current cookie-jar while in the context of a request.")

(defun make-proxy-http-request-0 (request clean-header)
  (let* ((headers (headers-in request))
         (header-dirty-p (funcall clean-header headers)))
    (curry #'drakma:http-request (request-uri request)
           :method (request-method request)
           :accept nil
           :user-agent nil
           :cookie-jar *cookie-jar*
           :additional-headers (compute-headers headers header-dirty-p))))

(defun compute-headers (headers dirtyp)
  (loop :for (k . v) :in headers
        :unless (funcall dirtyp k)
        :collect (cons (chunga:as-capitalized-string k) (url-decode v))))

(defvar *hop-by-hop*
  '(:connection :keep-alive :proxy-authenticate :upgrade
    :proxy-authorization :authorization :te :trailers :transfer-encoding))

(defvar *should-not-transfer*
  '(:set-cookie :proxy-connection
    :content-type :content-length :host))

(defun basic-clean-header-function (headers)
  (disjoin (rcurry 'member *hop-by-hop*)
           (rcurry 'member *should-not-transfer*)
           (compose (rcurry 'member
                            (loop :for (k . v) :in headers
                                  :when (eq k :connection)
                                  :nconc (cl-ppcre:split ",\\s+" v))
                            :test 'equal)
                    (compose 'string-downcase 'symbol-name))))

(defun make-proxy-http-request
    (request &optional (clean-header #'basic-clean-header-function))
  (let ((request-function (make-proxy-http-request-0 request clean-header)))
    (case (request-method request)
      ((:post) (curry request-function
                      :parameters
                      (collect-parameters 'post-parameters request)))
      (t request-function))))

(defun collect-parameters (parameter-function request)
  (loop :for cell :in (funcall parameter-function request)
        :if (listp (cdr cell))
        :collect (destructuring-bind (path file-name type) (cdr cell)
                   `(,(car cell) ,path
                      :content-type ,type
                      :filename ,file-name))
        :else
        :collect cell))

(defun call-with-proxy-request (function &optional make-http-request)
  (sunless make-http-request (setf it #'make-proxy-http-request))
  (let ((*cookie-jar* (make-instance 'drakma:cookie-jar)))
    (funcall function (funcall make-http-request *request*))))

(defmacro with-proxy-request ((content status-code headers) &body body)
  (with-unique-names (http-request uri http-stream must-close status-text)
    `(call-with-proxy-request
      #'(lambda (,http-request)
          (multiple-value-bind
                (,content ,status-code ,headers
                 ,uri ,http-stream ,must-close ,status-text)
              (funcall ,http-request)
            (declare (ignore ,uri ,http-stream ,must-close ,status-text))
            ,@body)))))

;; the handler

(defun basic-proxy-handler (body status-code headers)
  (prog1 body
   (setf (return-code*) status-code)
   (setf (content-type*) (cdr (assoc :content-type headers)))
   (loop :for (k . v) :in headers
         :unless (member k '(:set-cookie :content-type :content-length))
         :do (setf (header-out k) v))
   (loop :for c :in (drakma:cookie-jar-cookies *cookie-jar*)
         :do (set-cookie (drakma:cookie-name c)
                 :value (drakma:cookie-value c)
                 :expires (drakma:cookie-expires c)
                 :path (drakma:cookie-path c)
                 :domain (drakma:cookie-domain c)
                 :secure (drakma:cookie-securep c)
                 :http-only (drakma:cookie-http-only-p c)))))

(defmacro with-proxy-handling ((content status-code headers) &body body)
  `(with-proxy-request (,content ,status-code ,headers)
     (basic-proxy-handler ,content ,status-code ,headers)
     ,@body))

(defun handle-proxy-request ()
  (with-proxy-handling (body _status-code _headers)
    body))