git.fiddlerwoaroof.com
router.lisp
8e62a213
 (in-package :araneus.routes)
 
 (defgeneric resolve-route (url method content-type &key headers)
   (:documentation "The most generic method for resolving a route.
                    
                    Specialize with a keyword eql-specializer for method or content-type
                    to define a particular understanding of either"))
 
 (defgeneric match-token (url token)
   (:documentation "Match a url against a given token."))
 
 (defclass match-tree ()
   ((-token :initarg :token :accessor token)
    (-children :accessor children :initform (make-array 5 :adjustable t :fill-pointer 0))
    (-name :initarg :name :accessor name :initform nil)))
 
 
 
 (defun token= (tok1 tok2)
   (if (typep tok1 'match-tree)
     (setf tok1 (token tok1)))
 
   (if (typep tok2 'match-tree)
     (setf tok2 (token tok2)))
 
   (equal tok1 tok2))
 
 (defgeneric add-to-tree (match-tree token)
   (:method ((match-tree match-tree) (tokens list))
     (loop with current = match-tree
           for token in tokens
           do (setf current (add-to-tree current token))))
 
   (:method ((match-tree match-tree) (token integer))
    (with-accessors ((children children)) match-tree
      (if (eql (token match-tree) token)
        match-tree
        (prog1 (elt children
                    (or (position token (children match-tree) :test #'token=)
                        (vector-push-extend (make-instance 'match-tree :token token)
                                            children)))
          (setf children (stable-sort children #'< :key #'token)))))))
 
 (define-modify-macro orf (it) or)
 
 (defgeneric match-match-tree (match-tree item)
   (:method ((match-tree match-tree) (tokens list))
     (let ((current match-tree))
       (dolist (token tokens current)
         (let ((next (match-match-tree current token)))
           (setf current next)))
       ))
   (:method ((match-tree match-tree) (token integer))
     (find token
           (children match-tree)
           :test #'token=)))
 
 (defun random-match-tree (&optional (iters 10))
   (flet ((random-list (len lim) (loop repeat len collect (1+ (random lim)))))
     (let ((result (make-instance 'match-tree :token nil)))
       (loop repeat iters
             do (add-to-tree result
                             (random-list (1+ (random 5)) (1+ (random 10))))
             finally (return result)))))
 
 (defun print-match-tree (match-tree &optional (level 0))
   (format t "~&~v,2,1,'-<~>~a~%" level (token match-tree))
   (loop for child across (children match-tree)
         do (print-match-tree child (1+ level))))
 
 (coalesce-lists
   (coalesce-lists '(1 2 3) '(1 2 3 4))
   (coalesce-lists '(1 2 4) '(1 3 4)))
 ; => '(1 (2 3) (3 4))
 
 (defun match-url)