routing-method-combination.lisp

(defpackage :fwoar.mc-web
  (:use :cl )
  (:export ))
(in-package :fwoar.mc-web)

(defclass myway-server (hunchentoot:acceptor)
  ((%mapper :initform (myway:make-mapper) :reader mapper)))

(defvar *current-route*)
(define-method-combination routing
    ()
  ((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)
  (:method or ((acceptor myway-server) request)
           (setf (hunchentoot:return-code*) 404)
           (format nil "~s not found" (hunchentoot:script-name*))))

(defmethod hunchentoot:acceptor-dispatch-request ((acceptor myway-server) request)
  (let ((router (mapper acceptor)))
    (multiple-value-bind (result matched) (myway:dispatch router (hunchentoot:script-name*)
                                                          :method (hunchentoot:request-method*))
      (if matched
          result
          (resolve-request acceptor request)))))

(define-route-group main-routes ()
  "The main routes for the test server"
  (:route "/" () "this is a test")
  (:route "/a" () "this is the a route")
  (:route "/b" () "this is the b route"))

;;; ^^^ is equivalent to:
(defgeneric main-routes-using-defgeneric (server)
  (:method-combination routing)
  (:documentation "The main routes for the test server")
  (:method :route "/" (server) "this is a test")
  (:method :route "/a" (server) "this is the a route")
  (:method :route "/b" (server) "this is the b route"))

;;; TODO: should I warn if two different routes set the same paths?