From: Lucian Mogosanu <lucian.mogosanu@gmail.com>
Date: Sun, 23 Apr 2017 17:20:54 +0000 (+0300)
Subject: http: Some convenience mods and additions
X-Git-Url: https://git.mogosanu.ro/?a=commitdiff_plain;h=18ad306016a82247e613df737f905f4e794fce24;p=thetarpit.git

http: Some convenience mods and additions

* Use cl-http-server routes to route to about, archive, index, etc.

* Don't handle the default page in cl-http-server

* Manage site config by setup-ing/unsetup-ing routes in their respective
  hash tables. We have some default things plus some neat redirects, but
  we still only serve static content at the moment.
---

diff --git a/http.lisp b/http.lisp
index e6e0578..ae2ef60 100644
--- a/http.lisp
+++ b/http.lisp
@@ -26,29 +26,92 @@
   (require 'asdf)
   (asdf:load-system :cl-http-server))
 
-(defvar *tlbw-server* nil)
+;; Helpful high-level stuff
+(defmacro tlbw-dispatcher (type uri dispatcher)
+  `(cl-http:add-route
+    cl-http:*server* ,type ,uri ,dispatcher))
+
+(defmacro tlbw-static (type uri file)
+  `(tlbw-dispatcher ,type ,uri
+                    #'(lambda ()
+                        (cl-http:serve-file
+                         (merge-pathnames (pathname ,file)
+                                          (namestring (cl-http:public-dir)))))))
+
+(defun tlbw-setup ()
+  (assert cl-http:*server* )
+
+  (tlbw-static :static "/" "index.html")
+  (tlbw-static :static "/about" "about.html")
+  (tlbw-static :regex "/archive" "archive.html")
+  (tlbw-static :regex "/rss" "rss.xml")
+
+  ;; Redirect old URIs
+  (tlbw-dispatcher :regex "^/index\(.html\)?$"
+                   #'(lambda () (cl-http:redirect "/")))
+  (tlbw-dispatcher :static "/about.html"
+                   #'(lambda () (cl-http:redirect "/about")))
+  (tlbw-dispatcher :static "/archive.html"
+                   #'(lambda () (cl-http:redirect "/archive")))
+  (tlbw-dispatcher :regex "^/tags/?$"
+                   #'(lambda () (cl-http:redirect "/archive")))
+  (tlbw-dispatcher :static "/rss.xml"
+                   #'(lambda () (cl-http:redirect "/rss"))))
+
+(defun tlbw-unsetup ()
+  (assert cl-http:*server*)
+  (let ((static-route (cl-http:route-static
+                       (cl-http:server-route cl-http:*server*)))
+        (regex-route (cl-http:route-regex
+                      (cl-http:server-route cl-http:*server*))))
+    (maphash #'(lambda (k _)
+                 (declare (ignore _))
+                 (remhash k static-route)) static-route)
+    (maphash #'(lambda (k _)
+                 (declare (ignore _))
+                 (remhash k regex-route)) regex-route)))
+
+  ;; (cl-http:defpage index ()
+  ;;   (cl-http:serve-file
+  ;;    (merge-pathnames #p"index.html"
+  ;;                     (namestring (cl-http:public-dir)))))
 
 (defun tlbw-start-server ()
   ;; Check whether the server is running
-  (when *tlbw-server*
+  (when cl-http:*server*
     (format t "TLBW server is already running:~%~s~%"
-            *tlbw-server*)
+            cl-http:*server*)
     (return-from tlbw-start-server))
 
   ;; Alles gutes
-  (setq *tlbw-server*
-        (cl-http-server:start-server
-         (cl-http-server:make-server :public-dir *lbs-site*
-                                     :port 8000))))
+  (setq cl-http:*server*
+        (cl-http:start-server
+         (cl-http:make-server :public-dir *lbs-site*
+                              :port 8000)))
+  (tlbw-setup)
+  cl-http:*server*)
+
+(defun tlbw-reload-server ()
+  ;; Check whether the server is running
+  (when (not cl-http:*server*)
+    (format t "TLBW server not running.")
+    (return-from tlbw-reload-server))
+
+  ;; We don't kill the server, we just re-setup its routes.
+  (tlbw-unsetup)
+  (tlbw-setup)
+  cl-http:*server*)
+
 
 (defun tlbw-stop-server ()
   ;; Check whether the server is running
-  (when (not *tlbw-server*)
+  (when (not cl-http:*server*)
     (format t "TLBW server not running.")
     (return-from tlbw-stop-server))
 
-  (cl-http-server:stop-server *tlbw-server*)
-  (setq *tlbw-server* nil))
+  (cl-http:stop-server cl-http:*server*)
+  (setq cl-http:*server* nil))
+
 
 ;; A demo. First off, we load lib:
 ;;
diff --git a/stolen/cl-http-server/src/package.lisp b/stolen/cl-http-server/src/package.lisp
index a742d9b..b162f9e 100644
--- a/stolen/cl-http-server/src/package.lisp
+++ b/stolen/cl-http-server/src/package.lisp
@@ -2,6 +2,7 @@
 
 (defpackage :cl-http-server
   (:use :cl :my-util :usocket :cl-fad :flexi-streams)
+  (:nicknames "CL-HTTP")
   (:export :html
            :*server*
            :*request*
@@ -21,6 +22,7 @@
            :start-server
            :stop-server
            :server-is-running-p
+           :server-route
            :access-log
            :error-log
            :debug-log
diff --git a/stolen/cl-http-server/src/server.lisp b/stolen/cl-http-server/src/server.lisp
index cee9b0a..70861f7 100644
--- a/stolen/cl-http-server/src/server.lisp
+++ b/stolen/cl-http-server/src/server.lisp
@@ -36,6 +36,7 @@
   (remhash route (get-route server type)))
 
 (defun matched-route (uri)
+  (format *standard-output* "URI: ~s~%" uri)
   (aif (gethash uri (get-route *server* :static))
        it
        (maphash #'(lambda (regex dispatcher)
@@ -580,7 +581,8 @@
           ((:get :head :post)
            (cond ((get-page path1) (funcall (get-page path1)))
                  ((matched-route uri) (funcall (matched-route uri)))
-                 ((string= uri "/") (default-page))
+                 ;; This is handled by TLBW
+                 ;((string= uri "/") (default-page))
                  ((string= (public-dir) "")
                   (status-page 404))
                  (t (serve-file (merge-pathnames