lisp/drivethru.lisp @ a65fd2691c94 default tip

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload
    '(:adopt :with-user-abort :iterate :losh :hunchentoot :lparallel)
    :silent t))

(defpackage :drivethru
  (:use :cl :iterate :losh)
  (:export :toplevel :*ui*))

(in-package :drivethru)

;;;; State --------------------------------------------------------------------
(defvar *acceptor* nil)

;; in: (req . promise)
;;              ↑
;; out: (status . body)
(defvar *q* (lparallel.queue:make-queue))


;;;; Server -------------------------------------------------------------------
(defun prompt (message)
  (write-string message)
  (finish-output))

(defun handle ()
  (let ((p (lparallel:promise)))
    (lparallel.queue:push-queue (cons hunchentoot:*request* p) *q*)
    (destructuring-bind (status . body) (lparallel:force p)
      (setf (hunchentoot:return-code*) status)
      body)))

(defun serve (r)
  (destructuring-bind (request . promise) r
    (let ((auth (multiple-value-list (hunchentoot:authorization request))))
      (format t "~%~C[1;96m;;;; ~A ~A --------------~%~C[0m"
              #\esc
              (hunchentoot:request-method request)
              (hunchentoot:request-uri request)
              #\esc)
      (when auth
        (format t ";; User: ~S~%;; Pass: ~S~%" (first auth) (second auth))))
    (let ((status (progn (prompt "Reponse code: ")
                         (parse-integer (read-line))))
          (body (progn (prompt "Reponse body: ")
                       (read-line))))
      (lparallel:fulfill promise (cons status body)))))

(defun dispatch (request)
  (declare (ignore request))
  #'handle)


;;;; Run ----------------------------------------------------------------------
(defun run (port)
  (setf hunchentoot:*dispatch-table* '(dispatch)
        *acceptor* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor
                                        :port port)))
  (unwind-protect (loop (serve (lparallel.queue:pop-queue *q*)))
    (hunchentoot:stop *acceptor*)))


;;;; User Interface -----------------------------------------------------------
(defparameter *option-help*
  (adopt:make-option 'help
    :help "Display help and exit."
    :long "help"
    :short #\h
    :reduce (constantly t)))

(defparameter *option-port*
  (adopt:make-option 'port
    :help "Listen on port N (default 33455)."
    :parameter "N"
    :long "port"
    :short #\p
    :reduce #'adopt:last
    :key #'parse-integer
    :initial-value 33455))

(adopt:define-string *help-text*
  "drivethru listens for HTTP requests and lets you give responses by hand on ~
   the fly, as a low-tech mock when testing an API.")

(defparameter *examples*
  '(("Run on port 80:" . "drivethru -p 80")))

(defparameter *ui*
  (adopt:make-interface
    :name "drivethru"
    :usage "[OPTIONS]"
    :summary "serve HTTP requests by hand"
    :help *help-text*
    :examples *examples*
    :contents (list *option-port*
                    *option-help*)))


(defmacro exit-on-ctrl-c (&body body)
  `(handler-case
       (with-user-abort:with-user-abort (progn ,@body))
     (with-user-abort:user-abort () (adopt:exit 130))))


(defun toplevel ()
  (exit-on-ctrl-c
    (multiple-value-bind (arguments options) (adopt:parse-options-or-exit *ui*)
      (handler-case
          (if (gethash 'help options)
            (adopt:print-help-and-exit *ui*)
            (progn
              (assert (null arguments))
              (run (gethash 'port options))))
        (error (e) (adopt:print-error-and-exit e))))))