Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
198 lines (168 sloc) 7.07 KB
(ql:quickload '#:cl-ppcre)
(ql:quickload '#:rutilsx)
(ql:quickload '#:hunchentoot)
(ql:quickload '#:named-readtables)
(ql:quickload '#:swank)
(defpackage #:hunch
(:use #:cl #:rutilsx #:named-readtables)
(:import-from #:hunchentoot #:acceptor-log-message)
(:local-nicknames (#:re #:ppcre)
(#:htt #:hunchentoot))
(:export #:*hunch-acceptor*
#:*port*
#:*swank-port*
#:*debug*
#:abort-request
#:start-web
#:restart-web
#:stop-web
#:url
#:fmt-url
#:list-urls
#:parse-url-template
#:argv))
(in-package #:hunch)
(in-readtable rutilsx-readtable)
;;; config
;; List of program's command-line arguments.
(define-symbol-macro *argv*
#+:sbcl (nthcdr 2 sb-ext:*posix-argv*)
#+:ccl (nthcdr 4 ccl:*command-line-argument-list*))
(defvar *hunch-acceptor* nil
"Hunch acceptor.")
(defvar *port* 8080
"Port at which the application will be started.")
(defvar *swank-port* nil
"Port for starting swank. If nil swank won't be started.")
(defvar *script* nil
"Script file to load.")
(defvar *debug* nil
"Start in debug mode.")
;; configure vars from command line
(loop :for args :on *argv* :do
(when (char= #\- (char (first args) 0))
(setf (symbol-value (mksym (sub (first args) 1) :format "*~A*"))
(let ((val (second args)))
(if (digit-char-p (char val 0 ))
(read-from-string val)
val)))))
(setf htt:*show-lisp-errors-p* *debug*)
;;; web
(defun start-web (&optional port)
(setf *hunch-acceptor* (make-instance 'htt:easy-acceptor
:port (or port *port*)
:error-template-directory nil))
(bt:make-thread #`(htt:start *hunch-acceptor*) :name "hunch-acceptor")
(acceptor-log-message *hunch-acceptor* :info
"Started hunch acceptor at port: ~A." (or port *port*)))
(defun stop-web ()
(when *hunch-acceptor*
(ignore-errors (htt:stop *hunch-acceptor*)))
(mapc #'bt:destroy-thread
(remove-if-not #`(member (bt:thread-name %) '("hunch-")
:test #`(starts-with %% %))
(bt:all-threads)))
(acceptor-log-message *hunch-acceptor* :info
"Stopped hunch acceptor at port: ~A."
(htt:acceptor-port *hunch-acceptor*))
(void *hunch-acceptor*))
(defun restart-web (&optional port)
(stop-web)
(sleep 0.1)
(start-web port))
;;; swank
(defun start-swank (&optional port)
(when-it (or port *swank-port*)
(let ((*debug-io* (make-broadcast-stream)))
(swank:create-server :port it
:dont-close t)
(acceptor-log-message *hunch-acceptor* :info
"Started swank at port: ~A." it))))
(defun stop-swank (&optional port)
(when-it (or port *swank-port*)
(swank:stop-server it)
(acceptor-log-message *hunch-acceptor* :info "Stopped swank at port: ~A." it)))
;;; URL routing
(defun parse-url-template (url)
"Split URL into parts of 2 types:
- constant string
- url parameter names (symbols)"
(let ((prev 0)
parts)
(do ((pos (position #\: url) (position #\: url :start prev)))
((or (null pos) (= pos prev))
(push (slice url prev) parts))
(unless (= prev pos)
(push (slice url prev pos) parts))
(:= prev (position-if ^(char= #\/ %) url :start (1+ pos)))
(push (mksym (slice url (1+ pos) prev)) parts)
(if prev
(when (= prev (1+ pos))
(error "Param name is blank in hunch url definition at: ~A" pos))
(return)))
(reverse parts)))
(defmacro url (url-template (&rest params) &body body)
"Define a handler function for URL-TEMPLATE
on top of HUNCHENTOOT:DEFINE-EASY-HANDLER.
The function will be called after HANDLE + <URL-TEMPLATE>
(like HANDLE-/FOO for url '/foo'). If the URL contains parameter names
(basically keywords, like in '/foo/:bar/baz' bar will be a parameter name)
they may be referenced in easy-handler url parameters."
(with-gensyms (req url parts cur pos end)
(let ((url-parts (parse-url-template url-template)))
`(htt:define-easy-handler
(,(mksym url-template :format "handle-~A")
:uri ,(if (rest url-parts)
`(lambda (,req)
(let ((,pos 0)
(,url (htt:request-uri ,req)))
(loop :for ,parts :on ',url-parts :do
(let ((,cur (first ,parts)))
(if (stringp ,cur)
(let ((,end (mismatch ,cur ,url :start2 ,pos)))
(cond
((or (not ,end)
(string= "/" (sub ,cur ,end)))
(return
(not (or (cddr ,parts)
(stringp (second ,parts))))))
((= ,end (length ,cur))
(:+ ,pos ,end))
(t (return))))
(let (,end)
(when-it (and (rest ,parts)
(stringp (second ,parts))
(search (second ,parts) ,url
:start2 ,pos
:test 'string=))
(:= ,end it
,parts (rest ,parts)))
(push (cons (string-downcase (string ,cur))
(sub ,url ,pos ,end))
(? ,req 'htt:get-parameters))
(if (rest ,parts)
(:= ,pos (1+ ,end))
(return t))))))))
url-template))
(,@(remove-if 'stringp params))
,@body))))
(defmacro fmt-url (handler &rest args &key &allow-other-keys)
"Return a string representation of HANDLER's url
with url-parameters substitutted for values of ARGS.
If some parameter is missing, UNBOUND-VARIABLE will be signalled."
`(let (,@(loop :for (var val) :on args :by #'cddr
:collect (list (mksym var) val)))
(strcat ,@(parse-url-template (sub (symbol-name handler)
#.(length "handle-"))))))
(defun print-urls ()
"Print defined urls with their handler functions."
(dolist (record htt::*easy-handler-alist*)
(format t "~A ~A~%" (first record) (third record))))
(defun abort-request (code)
"Abort request with a provided HTTP return CODE."
(:= (htt:return-code*) code)
(htt:abort-request-handler))
;;; main
(when *script*
(load *script* :external-format :utf-8))
(start-web)