git.fiddlerwoaroof.com
mc-web.lisp
55a3cfc9
 (defpackage :fwoar.mc-web
   (:use :cl)
   (:export
    #:myway-server
    #:*current-route*
    #:routing
    #:define-route-group
    #:resolve-request))
 (in-package :fwoar.mc-web)
 
 (defclass myway-acceptor (hunchentoot:acceptor)
   ((%mapper :initform (myway:make-mapper) :reader mapper)))
 
 (defvar *current-route*)
 (define-method-combination route-group
     ()
   ((routes (:route *)))
   (:arguments server)
   `(progn
      ,@(mapcar (lambda (method)
                  `(let ((*method-route* ,(cadr (method-qualifiers method))))
                     (myway:connect (mapper ,server) *method-route*
                                    (call-method ,method))))
                (stable-sort routes #'<
                             :key (alexandria:compose #'length
                                                      #'cadr
                                                      #'method-qualifiers)))))
 
 (defmacro define-route-group (name (&rest args) &body body)
   (let* ((docstring (when (and body (stringp (car body)))
                       (car body)))
          (body (if docstring
                    (cdr body)
                    body)))
     (alexandria:with-gensyms (server)
       `(defgeneric ,name (,server ,@args)
          (:method-combination routing)
          (:documentation ,docstring)
          ,@(mapcar (serapeum:op `(:method
                                      ,@(subseq _1 0 2)
                                    (,server ,@(elt _1 2))
                                    ,@(subseq _1 3)))
                    body)))))
 
 (defgeneric resolve-request (acceptor request)
   (:method-combination or :most-specific-first)
   (:method or ((acceptor myway-acceptor) request)
            (setf (hunchentoot:return-code*) 404)
            (format nil "~s not found" (hunchentoot:script-name*))))
 
 (defmethod hunchentoot:acceptor-dispatch-request ((acceptor myway-acceptor) request)
   (let ((router (mapper acceptor)))
     (multiple-value-bind (result matched) (myway:dispatch router (hunchentoot:script-name*)
                                                           :method (hunchentoot:request-method*))
       (if matched
           result
           (or (resolve-request acceptor request)
               (call-next-method))))))