70 lines
2.2 KiB
Common Lisp
70 lines
2.2 KiB
Common Lisp
(uiop:define-package :ningle-fbr
|
|
(:nicknames #:ningle-fbr/main)
|
|
(:use #:cl)
|
|
(:local-nicknames (#:alx #:alexandria))
|
|
(:local-nicknames (#:re #:cl-ppcre))
|
|
(:local-nicknames (#:ng #:ningle))
|
|
(:export #:enable-file-based-routing))
|
|
(in-package :ningle-fbr)
|
|
|
|
(defun remove-file-type (namestr)
|
|
(re:regex-replace ".lisp" namestr ""))
|
|
|
|
(defun remove-index (url)
|
|
(if (string= url "/index")
|
|
"/"
|
|
(re:regex-replace "/index" url "")))
|
|
|
|
(defun replace-dynamic-annotation (url)
|
|
(re:regex-replace "=" url ":"))
|
|
|
|
(defun format-url (url)
|
|
(replace-dynamic-annotation (remove-index url)))
|
|
|
|
(defun pathname->url (pathname dir)
|
|
(format-url
|
|
(re:regex-replace (concatenate 'string
|
|
(namestring (uiop/os:getcwd))
|
|
dir)
|
|
(remove-file-type (namestring pathname))
|
|
"")))
|
|
|
|
(defun pathname->package (pathname system system-pathname)
|
|
(alx:make-keyword
|
|
(string-upcase
|
|
(re:regex-replace (concatenate 'string
|
|
(namestring (uiop/os:getcwd))
|
|
system-pathname)
|
|
(remove-file-type (namestring pathname))
|
|
system))))
|
|
|
|
(defun dir->pathnames (dir)
|
|
(directory (concatenate 'string
|
|
dir
|
|
"/**/*.lisp")))
|
|
|
|
(defun dir->urls (dir)
|
|
(mapcar (lambda (pathname)
|
|
(pathname->url pathname dir))
|
|
(dir->pathnames dir)))
|
|
|
|
(defun dir->packages (dir system system-pathname)
|
|
(mapcar (lambda (pathname)
|
|
(pathname->package pathname system system-pathname))
|
|
(dir->pathnames dir)))
|
|
|
|
(defparameter *http-request-methods*
|
|
'(:GET :HEAD :POST :PUT :DELETE :CONNECT :OPTIONS :PATCH))
|
|
|
|
(defun enable-file-based-routing (app &key dir system system-pathname)
|
|
(let ((urls (dir->urls dir))
|
|
(packages (dir->packages dir system system-pathname)))
|
|
(ql:quickload packages)
|
|
(loop
|
|
:for url :in urls
|
|
:for pkg :in packages
|
|
:do (loop
|
|
:for method :in *http-request-methods*
|
|
:do (let ((handler (find-symbol (string (alx:symbolicate 'on- method)) pkg)))
|
|
(when handler
|
|
(setf (ng:route app url :method method) handler)))))))
|