diff --git a/qlfile b/qlfile index ac827b7..6553439 100644 --- a/qlfile +++ b/qlfile @@ -1 +1,3 @@ ql ningle +ql cl-ppcre +ql alexandria diff --git a/qlfile.lock b/qlfile.lock index 35d083e..ae6cce7 100644 --- a/qlfile.lock +++ b/qlfile.lock @@ -6,3 +6,11 @@ (:class qlot/source/ql:source-ql :initargs (:%version :latest) :version "ql-2023-10-21")) +("cl-ppcre" . + (:class qlot/source/ql:source-ql + :initargs (:%version :latest) + :version "ql-2023-10-21")) +("alexandria" . + (:class qlot/source/ql:source-ql + :initargs (:%version :latest) + :version "ql-2023-10-21")) diff --git a/src/main.lisp b/src/main.lisp index bdec57b..aab7a94 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -1,9 +1,70 @@ (uiop:define-package :ningle-fbr (:nicknames #:ningle-fbr/main) - (:use #:cl - #:ningle) + (: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 enable-file-based-routing (app directory) - (declare (ignore app directory))) +(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)))))))