File: simple-routes.lisp

package info (click to toggle)
pgcharts 1.0+2017-09-16-1
  • links: PTS, VCS
  • area: non-free
  • in suites: bullseye, buster, sid
  • size: 25,228 kB
  • sloc: lisp: 1,779; java: 1,601; xml: 330; jsp: 162; makefile: 123; php: 70; sql: 64; sh: 39
file content (131 lines) | stat: -rw-r--r-- 5,317 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
;;;
;;; https://raw.github.com/vancan1ty/simple-routes/master/simple-routes.lisp
;;;
;;; As I couldn't make Quicklisp and ASDF to load the project once git
;;; cloned in ~/quicklisp/local-projects/, let's just add a copy here.

(defpackage :simple-routes
  (:use :common-lisp :cl-ppcre :hunchentoot)
  (:export :compile-routes
	   :simpleroutes-acceptor
	   :simpleroutes-ssl-acceptor
	   :bind-alist-values
           :define-simple-handler))

(in-package :simple-routes)


;;Adds simple-router dispatching to the front of hunchentoot's dispatch table!

(defvar *routeslist* ()
 "should contain routes compiled with routespec-compile or manually entered in compiled form
  incoming requests are matched up against each item in *routeslist* successively, until (and if) a
  matching routespec is found.")

(defclass simpleroutes-acceptor (acceptor)
  ((routes :initarg :routes
           :accessor routes
           :documentation "Routes list."))
  (:documentation
   "This first tries to route requests using simple-router, then falls back
    to hunchentoot's default easy-acceptor."))

#-:hunchentoot-no-ssl
(defclass simpleroutes-ssl-acceptor (simpleroutes-acceptor ssl-acceptor)
  ()
  (:documentation "This is an acceptor that mixes the simpleroutes
  acceptor with SSL connections."))

(defun issymbolstring (str)
  (and (> (length str) 1) (eql (elt str 0) #\:)))

(defun removelast (sequence)
  "removes the last item in sequence IF THE SEQUENCE HAS A LAST ITEM"
  (if (> (length sequence) 0)
      (subseq sequence 0 (1- (length sequence)))
      sequence))

(defun routespec-compile (httpmethod urldef fntocall)
  "httpmethod can be one of :GET :HEAD :POST :PUT :DELETE or :ALL
   urldef is a url definition string sharing *basic* syntax with Ruby on Rails
   fntocall is the function to call in case the this is found to be a match for the request

   this macro returns a list which is meant to be processed by cl-simple routehandler
   example call:
   =>(rtreg :GET ``/home/next/:number'' #'nxthandler) returns
   (:GET \"^/home/next/([^/]*)$\" (NUMBER)
     #<CLOSURE (LAMBDA # :IN MACRO-FUNCTION) {1000F213DB}>)
   the output of this macro can in turn be processed by simple-processor"
  (declare (optimize (debug 3)))
  (let* ((thelist (remove "" (cl-ppcre:split "/" urldef) :test #'equalp)) 
	 (startswithslash (and (> (length urldef) 0) (eql (elt urldef 0) #\/)))
	 (endswithslash (and (> (length urldef) 1) (eql (lastitem urldef) #\/)))
	 (colonitems (reverse 
		      (reduce (lambda (accum nxt) 
				(if (issymbolstring nxt) 
				    (cons nxt accum)
				    accum))
			      thelist :initial-value ())))
	 (theregex (concatenate 'string
				"^"
				(when startswithslash "/")
				(removelast
				 (apply #'concatenate 'string 
					(loop for item in thelist collect
					     (if (issymbolstring item)
						 "([^/]*)/"
						 (concatenate 'string item "/")))))
				(when endswithslash "/")
				"$"))
	 (symstobind (mapcar (lambda (item) (intern (string-upcase (subseq item 1)))) colonitems)))
    `(list ,httpmethod ,theregex (quote ,symstobind) ,fntocall)))

(defmacro compile-routes (&rest routespecs)
  `(list ,@(loop for routespec in routespecs collect
       (apply #'routespec-compile routespec))))

(defun simple-router (request-uri request-type)
  "takes in a request uri and type (:GET, :POST, etc...) and loops through all
   compiled routes in *routeslist*.  If it finds a route that matches
   ,it returns the associated handler and returns true.  otherwise returns false"
  (register-groups-bind (processed-uri) ("^([^?]*)\\??.*" request-uri)
    (loop for compiled-route in *routeslist* do 
	 (destructuring-bind (treqtype tregexp tvars tfntocall) compiled-route
	   (declare (ignore tvars))
	   (multiple-value-bind (regexmatch capturedstrings) (cl-ppcre:scan-to-strings tregexp processed-uri)
	     (declare (ignore regexmatch))
	     (if (and (not (eql capturedstrings nil))
		      (eql treqtype request-type))
		 (progn 
		   (return-from simple-router (apply tfntocall (mapcar #'hunchentoot:url-decode (coerce capturedstrings 'list)))))))))))


(defmethod acceptor-dispatch-request ((acceptor simpleroutes-acceptor) request)
  "The simple request dispatcher which tries to complete the request using simple,
   but otherwise falls back to the hunchentoot defaults *dispatch-table* and easy-acceptor"
  (let ((uri (request-uri request))
	(request-type (hunchentoot:request-method request)))
    (let* ((*routeslist* (let ((routes (routes acceptor)))
                           (typecase routes
                             (symbol (symbol-value routes))
                             (t      routes))))
           (potentialout (simple-router uri request-type)))
      (or potentialout
	  (call-next-method)))))

(defmacro bind-alist-values (lambda-list alist-expression &rest body)
  "this is intended to be used to access get and post parameters.  example usage
   (bind-alist-values (first second) (hunchentoot:get-parameters*)
		         (list first second))"
  `(destructuring-bind ,lambda-list 
       (mapcar (lambda (varname) 
		 (cdr (assoc (string varname) 
			     ,alist-expression
			     :test #'equalp)) )
	       (quote ,lambda-list))
     ,@body))

(defun lastitem (seq)
  (let ((lindex (- (length seq) 1)))
    (when (> lindex 0)
      (elt seq lindex))))