(eval-when (:load-toplevel :compile-toplevel :execute) (require 'hunchentoot)) (defpackage :ht-rest (:use :common-lisp :hunchentoot)) (in-package :ht-rest) (defun add-dispatcher (dispatcher-fn) "Helper function to add dispatcher functions to dispatch table" (nconc *dispatch-table* (list dispatcher-fn))) (defun create-dispatcher (url-prefix handler &key (regexp nil)) "Creates a dispatcher and add it to dispatch table given the url prefix and handler function. The url prefix can be a regular expression (in this case set the :regexp keyword)." (let ((dispatcher-fn (funcall (if regexp 'create-regexex-dispatcher 'create-prefix-dispatcher) url-prefix handler))) (add-dispatcher dispatcher-fn))) (defun handle-rest () "Simply delegate to appropriate handler" (handle (request-method))) (defgeneric handle (request-method) (:documentation "Generic REST handler")) (defmethod handle :before (request-method) (log-message :info "REST in: [method ~a] [target ~a] [qs ~s]" (request-method) (script-name) (query-string))) (defmethod handle :after (request-method) (log-message :info "REST out: [code ~a] [method ~a] [target ~a] [qs ~s]" (return-code) (request-method) (script-name) (query-string))) (defvar *data-id* "e8d8993494ffc11:b8e") (defun get-data-id (target) "get the last id for requested data" *data-id*) (defmethod handle :around (request-method) "ETag support for all methods" (let ((data-id (get-data-id (script-name))) (last-id (header-in :If-None-Match))) (setf (header-out :ETag) data-id) (if (and last-id (equalp last-id data-id)) (setf (return-code) +http-not-modified+) (call-next-method)))) (defmethod handle ((request-method (eql :get))) (string (request-method))) (defmethod handle ((request-method (eql :post))) (string (request-method))) (defmethod handle ((request-method (eql :put))) (string (request-method))) (defmethod handle ((request-method (eql :delete))) (string (request-method))) (defmethod handle (request-method) (setf (return-code) +http-method-not-allowed+)) (defvar *ht-server* nil) (defun setup () (create-dispatcher "/rest" 'handle-rest)) (defun start (&optional (setup-p t)) (prog1 (setq *show-lisp-errors-p* t *show-lisp-backtraces-p* t *dispatch-table* (list 'dispatch-easy-handlers) *ht-server* (start-server :port 8080)) (when setup-p (setup)))) (defun stop () (stop-server *ht-server*)) (defun re-start () (progn (stop) (start nil)))