You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
350 lines
16 KiB
350 lines
16 KiB
;;;; router.lisp
|
|
;;;;
|
|
;;;; This file is part of Nite
|
|
;;;; Author: Pavel Penev (Lispegistus) <lispegistus@strangestack.com>
|
|
;;;; Released under the Gnu Public License version 3
|
|
;;;;
|
|
;;;; Nite is free software: you can redistribute it and/or modify
|
|
;;;; it under the terms of the GNU General Public License as published by
|
|
;;;; the Free Software Foundation, either version 3 of the License, or
|
|
;;;; (at your option) any later version.
|
|
;;;;
|
|
;;;; Nite is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;;; GNU General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU General Public License
|
|
;;;; along with Nite. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;; router
|
|
|
|
(defpackage #:nite.router
|
|
(:use #:cl #:iterate)
|
|
(:import-from #:bind
|
|
#:bind)
|
|
(:import-from #:alexandria
|
|
#:hash-table-keys
|
|
#:make-keyword)
|
|
(:export
|
|
#:parse-string-template
|
|
#:unparse-string-template
|
|
#:concatenate-string-template
|
|
#:node
|
|
#:node-route
|
|
#:node-children
|
|
#:node-path-component
|
|
#:merge-nodes
|
|
#:build-path
|
|
#:add-route-at-path
|
|
#:merge-node-at-path
|
|
#:walk-nodes
|
|
#:param-capture-children-p
|
|
#:param-capture
|
|
#:find-child
|
|
#:find-path
|
|
;; high-level API
|
|
#:*router*
|
|
#:router
|
|
#:router-route-map
|
|
#:router-route-name-map
|
|
#:rebuild-route-map
|
|
#:find-route
|
|
#:find-route-uri
|
|
#:connect
|
|
#:mount
|
|
#:route-map-pretty))
|
|
|
|
(in-package #:nite.router)
|
|
|
|
;; Low-level implementation of the router tree
|
|
|
|
(defun parse-string-template (string-template)
|
|
"Parses a string URI template to a list of path components. Input can include parameter capture variables
|
|
and a special * wildcard variable. The * must be at the end of the path, anything after it will be ignored.
|
|
Example:
|
|
\"/foo/bar\" -> (\"\" \"foo\" \"bar\")
|
|
\"/foo/:name|string/:id|integer\" -> (\"\" \"foo\" (:name :string) (:id :integer))
|
|
\"/foo/:name/:id|integer\" -> (\"\" \"foo\" (:name :string) (:id :integer))
|
|
\"/foo/*\" -> (\"\" \"foo\" (:* :wild)"
|
|
(iter (for path-component in (str:split "/" string-template))
|
|
(when (string= "*" path-component)
|
|
(collect (cons :* :wild))
|
|
(finish))
|
|
(if (str:starts-with-p ":" path-component)
|
|
(bind (((name &optional (parser-name "string")) (str:split "|" path-component)))
|
|
(collect (cons (make-keyword (str:upcase (string-left-trim ":" name)))
|
|
(make-keyword (str:upcase parser-name)))))
|
|
(collect path-component))))
|
|
|
|
(defun unparse-string-template (list-template &optional params)
|
|
"Generate a string template from a parsed list template"
|
|
(str:join "/" (iter (for path-component in list-template)
|
|
(collect (if (stringp path-component)
|
|
path-component
|
|
(if (eql :* (car path-component))
|
|
"*"
|
|
(format nil ":~A|~A" (car path-component) (cdr path-component))))))))
|
|
|
|
(defun concatenate-string-template (prefix template)
|
|
"Concatenate two template strings while keeping slashes consistent"
|
|
(let* ((trailing-slash (str:ends-with-p "/" template))
|
|
(prefix (string-trim "/" prefix))
|
|
(template (string-trim "/" template)))
|
|
(cond ((and (str:emptyp prefix)
|
|
(str:emptyp template))
|
|
"/")
|
|
((str:emptyp prefix)
|
|
(str:concat "/" template (if trailing-slash "/" "")))
|
|
((str:emptyp template)
|
|
(str:concat "/" prefix (if trailing-slash "/" "")))
|
|
(t (str:concat "/" prefix "/" template (if trailing-slash "/" ""))))))
|
|
|
|
;; tree code
|
|
|
|
(defclass node ()
|
|
((route :accessor node-route
|
|
:initarg :route
|
|
:initform nil
|
|
:type (or null cons)
|
|
:documentation "Route object, either nil or (cons <route-handler> <route-name>)")
|
|
(children :accessor node-children
|
|
:initform (make-hash-table :test #'equalp)
|
|
:type hash-table
|
|
:documentation "Table of child nodes.")
|
|
(path-component :accessor node-path-component
|
|
:initarg :path-component
|
|
:initform nil
|
|
:type (or null cons string)
|
|
:documentation "The path-component the node represents in the tree.")))
|
|
|
|
(defun merge-nodes (node1 node2 &optional path-component)
|
|
"Create a new node and recursively node1 and node2 into it with node2 taking priority.
|
|
Optionally you can set the path-component of the new node manually, otherwise the path component
|
|
of node2 will be used."
|
|
(bind (((:labels copy-node (node))
|
|
(let ((new-node (make-instance 'node
|
|
:path-component (node-path-component node)
|
|
:route (node-route node))))
|
|
(iter (for (key child) in-hashtable (node-children node))
|
|
(setf (gethash key (node-children new-node))
|
|
(copy-node child)))
|
|
new-node))
|
|
(new-node (make-instance 'node
|
|
:route (or (node-route node2) (node-route node1))
|
|
:path-component (or path-component (node-path-component node2))))
|
|
(node1 (copy-node node1))
|
|
(node2 (copy-node node2))
|
|
(common-children (intersection (hash-table-keys (node-children node1))
|
|
(hash-table-keys (node-children node2))))
|
|
(node1-unique-children (set-difference (hash-table-keys (node-children node1))
|
|
(hash-table-keys (node-children node2))))
|
|
(node2-unique-children (set-difference (hash-table-keys (node-children node2))
|
|
(hash-table-keys (node-children node1)))))
|
|
(iter (for key in node1-unique-children)
|
|
(setf (gethash key (node-children new-node))
|
|
(gethash key (node-children node1))))
|
|
(iter (for key in node2-unique-children)
|
|
(setf (gethash key (node-children new-node))
|
|
(gethash key (node-children node2))))
|
|
(iter (for key in common-children)
|
|
(setf (gethash key (node-children new-node))
|
|
(merge-nodes (gethash key (node-children node1))
|
|
(gethash key (node-children node2)))))
|
|
new-node))
|
|
|
|
(defun build-path (node path-component rest fn)
|
|
"Build a path of nodes in the tree NODE, creating new nodes if they don't exist, call a function on the last child.
|
|
PATH-COMPONENT is the first path component, REST contains the rest of the path.
|
|
FN is a function of 3 arguments, the parent node, the last child node and the path component of the child."
|
|
;; Find the child or create it if it doesn't exist
|
|
(let ((child
|
|
(let ((key (if (consp path-component) (cdr path-component) path-component)))
|
|
(or (gethash key (node-children node))
|
|
(setf (gethash key (node-children node))
|
|
(make-instance 'node :path-component path-component))))))
|
|
(if rest
|
|
(build-path child (car rest) (cdr rest) fn)
|
|
(funcall fn node child path-component))))
|
|
|
|
(defun add-route-at-path (root path route-handler &optional route-name)
|
|
"Add a route to the root node at path."
|
|
(if (or (string= path "/")
|
|
(string= path "")
|
|
(null path))
|
|
(setf (node-route root) (cons route-handler route-name))
|
|
(bind (((path-component . rest) (parse-string-template (string-left-trim "/" path))))
|
|
(build-path root
|
|
path-component
|
|
rest
|
|
(lambda (parent-node child path-component)
|
|
(declare (ignore parent-node path-component))
|
|
(setf (node-route child) (cons route-handler route-name)))))))
|
|
|
|
(defun merge-node-at-path (root path node)
|
|
"Find or create a new node to path, and then merge NODE with it."
|
|
(if (or (string= path "/")
|
|
(string= path "")
|
|
(null path))
|
|
(progn (setf (node-route root) (or (node-route node) (node-route root)))
|
|
(merge-nodes root node))
|
|
(bind (((path-component . rest) (parse-string-template (string-left-trim "/" path))))
|
|
(build-path root
|
|
path-component
|
|
rest
|
|
(lambda (parent-node child path-component)
|
|
(setf (gethash (if (consp path-component)
|
|
(cdr path-component)
|
|
path-component)
|
|
(node-children parent-node))
|
|
(merge-nodes child node path-component)))))))
|
|
|
|
(defun walk-nodes (function node &optional (path '("")))
|
|
"Visit every node in a tree, applying FUNCTION to it.
|
|
FUNCTION takes 2 arguments, the child and the string path to the child."
|
|
(iter (for (path-component child) in-hashtable (node-children node))
|
|
(let* ((child-path (concatenate 'list path (if (stringp path-component)
|
|
(list path-component)
|
|
(list (node-path-component child))))))
|
|
(funcall function child (unparse-string-template child-path))
|
|
(walk-nodes function child child-path))))
|
|
|
|
(defun param-capture-children-p (node)
|
|
"Predicate, returns nil if none of the node children can perform parameter capture"
|
|
(remove-if-not #'keywordp (hash-table-keys (node-children node))))
|
|
|
|
(defun param-capture (node path-component &optional rest)
|
|
"Given a node and a path component and optionally the rest of the path,
|
|
if the node can perform parameter capture return the child that matched and the captured parameters."
|
|
(let ((integer-child (gethash :integer (node-children node)))
|
|
(string-child (gethash :string (node-children node)))
|
|
(wild-child (gethash :wild (node-children node))))
|
|
(when (and integer-child (ppcre:scan "^[0-9]+$" path-component))
|
|
(return-from param-capture (values integer-child (cons (car (node-path-component integer-child)) (parse-integer path-component)))))
|
|
(when string-child
|
|
(return-from param-capture (values string-child (cons (car (node-path-component string-child)) path-component))))
|
|
(when wild-child
|
|
(return-from param-capture (values wild-child (cons :* (str:join "/" (cons path-component rest))))))))
|
|
|
|
(defun find-child (node path-component &optional rest)
|
|
"Find the child in node, if the path is not found, attempt to capture parameters"
|
|
(let ((child (gethash path-component (node-children node))))
|
|
(cond (child (values child nil))
|
|
((param-capture-children-p node) (param-capture node path-component rest))
|
|
(t (values nil nil)))))
|
|
|
|
(defun find-path (root path)
|
|
"Find the node-route of the node designated by path."
|
|
(bind (((:labels find-path-internal (node path-component rest params))
|
|
(bind (((:values child p) (find-child node path-component rest))
|
|
(params (if p (cons p params) params)))
|
|
(cond ((and child rest)
|
|
(if (assoc :* params)
|
|
(values (car (node-route child)) params)
|
|
(find-path-internal child (car rest) (cdr rest) params)))
|
|
(child (values (car (node-route child)) params))
|
|
(t (values nil params)))))
|
|
(path (parse-string-template (string-left-trim "/" path))))
|
|
(if (equal '("") path)
|
|
(values (car (node-route root)) nil)
|
|
(find-path-internal root (car path) (cdr path) nil))))
|
|
|
|
;; High-level API
|
|
|
|
(defparameter *router* nil)
|
|
|
|
(defclass router ()
|
|
((root :accessor router-root-node
|
|
:initarg :root
|
|
:initform (make-instance 'node :path-component "")
|
|
:type node
|
|
:documentation "Root node of the router route tree")
|
|
(route-map :accessor router-route-map
|
|
:initform (make-hash-table)
|
|
:type hash-table
|
|
:documentation "Map of routes for easier debugging")
|
|
(route-name-map :accessor router-route-name-map
|
|
:initform (make-hash-table)
|
|
:type hash-table
|
|
:documentation "Reverse lookup map"))
|
|
(:documentation "Map of routes."))
|
|
|
|
(defun rebuild-route-map (router)
|
|
"Rebuild an router's reverse lookup maps."
|
|
;; Clear the route maps
|
|
(setf (router-route-name-map router) (make-hash-table))
|
|
(setf (router-route-map router) (make-hash-table))
|
|
;; walk-node visits every child, we check if the child has a route assosiated with it and put it in the maps.
|
|
(if (node-route (router-root-node router))
|
|
(bind (((route-handler . route-name) (node-route (router-root-node router))))
|
|
(when (and route-name (not (member route-name (hash-table-keys (router-route-name-map router)))))
|
|
(setf (gethash route-name (router-route-name-map router)) "/"))
|
|
(when route-handler
|
|
(setf (gethash "/" (router-route-map router)) (list route-handler route-name)))))
|
|
(walk-nodes
|
|
(lambda (child path)
|
|
(when (node-route child)
|
|
(bind (((route-handler . route-name) (node-route child)))
|
|
(when (and route-name (not (member route-name (hash-table-keys (router-route-name-map router)))))
|
|
(setf (gethash route-name (router-route-name-map router)) path))
|
|
(when route-handler
|
|
(setf (gethash path (router-route-map router)) (list route-handler route-name))))))
|
|
(router-root-node router)))
|
|
|
|
(defun find-route (uri &key (router *router*))
|
|
"Find a route in router"
|
|
(find-path (router-root-node router) uri))
|
|
|
|
(defun find-route-uri (route-name &key (router *router*) (params nil))
|
|
"Attempt to find a uri that will match a given route in router given a route-name.
|
|
Because the route might have variable capture keys on it's path, you must provide a plist of
|
|
apropriate variable capture values in order to build a valid path."
|
|
(when (gethash route-name (router-route-name-map router))
|
|
(str:join "/"
|
|
(iter (for path-component in (parse-string-template (gethash route-name (router-route-name-map router))))
|
|
(collect (if (stringp path-component)
|
|
path-component
|
|
(format nil "~A" (getf params (car path-component)))))))))
|
|
|
|
(defgeneric connect (router uri handler &optional name rebuild)
|
|
(:documentation "Connect a route in the router. Optional rebuild parameter rebuilds the routeers reverse route map.
|
|
If nil, you will have to manually call REBUILD-ROUTE-MAP for reverse lookup to work correctly.")
|
|
(:method ((router router) uri handler &optional (name nil) (rebuild nil))
|
|
(add-route-at-path (router-root-node router) uri handler name)
|
|
(when rebuild
|
|
(rebuild-route-map router))
|
|
router))
|
|
|
|
(defgeneric mount (router uri subrouter &optional route-name-prefix rebuild)
|
|
(:documentation "Mount a subrouter to a URI in ROUTER. Optionally you can provide a route-name-prefix,
|
|
this must be an uppercase string, such as \"PREFIX-\" that will be prepended to the names of all
|
|
route-name keywords in the subrouter.
|
|
Optional rebuild parameter rebuilds the routeers reverse route map.
|
|
If nil, you will have to manually call REBUILD-ROUTE-MAP for reverse lookup to work correctly.
|
|
")
|
|
(:method ((router router) uri (subrouter router) &optional (route-name-prefix nil) (rebuild nil))
|
|
(let ((new-subrouter-node (merge-node-at-path (router-root-node router)
|
|
uri
|
|
(router-root-node subrouter))))
|
|
(when route-name-prefix
|
|
(walk-nodes (lambda (child path)
|
|
(declare (ignore path))
|
|
(when (node-route child)
|
|
(bind (((_ . route-name) (node-route child)))
|
|
(if route-name
|
|
(setf (node-route child)
|
|
(cons route-name
|
|
(make-keyword (str:concat route-name-prefix
|
|
(symbol-name route-name)))))))))
|
|
new-subrouter-node))
|
|
(when rebuild
|
|
(rebuild-route-map router))
|
|
router)))
|
|
|
|
(defgeneric route-map-alist (router)
|
|
(:documentation "Return a solted alist of the route-map for debugging")
|
|
(:method ((router router))
|
|
(sort (alexandria:hash-table-alist (router-route-map router))
|
|
#'string<
|
|
:key #'car)))
|