git.fiddlerwoaroof.com
blog.lisp
2f4adace
 (defpackage :fwoar.blog
   (:use :cl :araneus :alexandria :serapeum :fw.lu)
   (:export ))
 (in-package :fwoar.blog)
 
 (defclass blog ()
   ((%posts :initarg :posts :accessor posts))
   (:default-initargs :posts ()))
 (make-constructor blog &rest posts)
 (defmethod print-object ((o blog) s)
   (format s "#.(make-blog ~{~s~^ ~})"
           (posts o)))
 
 (defclass post ()
   ((%content :initarg :content :accessor content)))
 
 (defclass micropost (post)
   ())
 (make-constructor micropost content)
 (defmethod print-object ((o micropost) s)
   (format s "#.(make-micropost ~s)" (content o)))
 
 (defclass macropost (post)
   ((%title :initarg :title :accessor title)))
 (make-constructor macropost title content)
 (defmethod print-object ((o macropost) s)
   (format s "#.(make-macropost ~s ~s)"
           (title o)
           (content o)))
 
 (defmacro orc (&rest funs)
   `(lambda (v)
      (or ,@(loop for fun in funs
                  collect `(,fun v)))))
 
 (defun slugify (string)
   (substitute #\- #\space
               (trim-whitespace
                (remove-if-not (orc alphanumericp
                                    (lambda (c) (eql c #\space))
                                    (lambda (c) (eql c #\-)))
                               (string-downcase string)))))
 
 (defgeneric titled-posts (blog)
   (:method ((blog blog))
     (mappend #'titled-posts
              (posts blog)))
   (:method ((post micropost))
     ())
   (:method ((post macropost))
     (list post)))
 
 (defgeneric find-post (slug blog)
   (:method ((slug string) (blog blog))
     (loop with needle-slug = (slugify slug)
           for post in (titled-posts blog)
           for haystack-slug = (slugify (title post))
           when (equal needle-slug haystack-slug)
             return post)))
 
 (defclass blog-route ()
   ((%blog :initarg :blog :reader blog)))
 
a8cd04b5
 (defclass index-route (blog-route)
2f4adace
   ())
 
 (defclass post-route (blog-route)
   ((%post :initarg :post :reader post)))
 
a8cd04b5
 (defmethod controller ((route index-route) params &key)
2f4adace
   (posts (blog route)))
 
 (defmethod controller ((route post-route) params &key)
   (post route))
 
c35bf91a
 (defmethod view ((_ blog-route) post)
   '(404 (:content-type "text/plain") ("FAIL!")))
 
 (defun layout (f)
2f4adace
   (spinneret:with-html-string
c35bf91a
     (:style
      ":root {
         --zenburn-fg-plus-2: #FFFFEF; --zenburn-fg-plus-1: #F5F5D6;
         --zenburn-fg: #DCDCCC; --zenburn-fg-1: #A6A689;
         --zenburn-fg-2: #656555; --zenburn-black: #000000;
         --zenburn-bg-2: #000000; --zenburn-bg-1: #111112;
         --zenburn-bg-05: #383838; --zenburn-bg: #2A2B2E;
         --zenburn-bg-plus-05: #494949; --zenburn-bg-plus-1: #4F4F4F;
         --zenburn-bg-plus-2: #5F5F5F; --zenburn-bg-plus-3: #6F6F6F;
         --zenburn-red-plus-2: #ECB3B3; --zenburn-red-plus-1: #DCA3A3;
         --zenburn-red: #CC9393; --zenburn-red-1: #BC8383;
         --zenburn-red-2: #AC7373; --zenburn-red-3: #9C6363;
         --zenburn-red-4: #8C5353; --zenburn-red-5: #7C4343;
         --zenburn-red-6: #6C3333; --zenburn-orange: #DFAF8F;
         --zenburn-yellow: #F0DFAF; --zenburn-yellow-1: #E0CF9F;
         --zenburn-yellow-2: #D0BF8F; --zenburn-green-5: #2F4F2F;
         --zenburn-green-4: #3F5F3F; --zenburn-green-3: #4F6F4F;
         --zenburn-green-2: #5F7F5F; --zenburn-green-1: #6F8F6F;
         --zenburn-green: #7F9F7F; --zenburn-green-plus-1: #8FB28F;
         --zenburn-green-plus-2: #9FC59F; --zenburn-green-plus-3: #AFD8AF;
         --zenburn-green-plus-4: #BFEBBF; --zenburn-cyan: #93E0E3;
         --zenburn-blue-plus-3: #BDE0F3; --zenburn-blue-plus-2: #ACE0E3;
         --zenburn-blue-plus-1: #94BFF3; --zenburn-blue: #8CD0D3;
         --zenburn-blue-1: #7CB8BB; --zenburn-blue-2: #6CA0A3;
         --zenburn-blue-3: #5C888B; --zenburn-blue-4: #4C7073;
         --zenburn-blue-5: #366060; --zenburn-magenta: #DC8CC3;}"
      (lass:compile-and-write
       `(* :box-sizing border-box)
       `((:or html body)
         :margin 0
         :padding 0
         :color (var "--zenburn-fg")
         :background (var "--zenburn-bg")
         :font-family sans-serif
         :font-size 16px
         :display grid
         :grid-template-areas "\"top     top     top\"
                              \"left     main     main\"
                              \"left     main     main\"")
       `((:or a)
         :margin 0
         :padding 0
         :color (var "--zenburn-blue")
         )
       `((:or h1 h2 h3 h4 h5 h6)
         :font-size 1.1rem
         :margin 0
         :padding 0)
       `((:and a :hover)
         :color (var "--zenburn-blue-1"))
       `(h1 :grid-area "top" :padding 2rem :font-size 3rem)
       `(nav :grid-area "left" :padding 2rem)
       `(main :grid-area "main" :padding 2rem 0 0 0)))
     (:h* "the site!")
     (:nav "aside")
     (:main (funcall f))))
 
 (defvar *layout-done* nil)
 (defmethod view :around ((_ blog-route) post)
   (if *layout-done*
       (call-next-method)
       (let ((*layout-done* t))
         (layout #'call-next-method))))
 
 (defmethod view ((name post-route) (post macropost))
   (spinneret:with-html
2f4adace
     (:section
      (:h* (title post))
      (:div
       (content post)))))
 
a8cd04b5
 (defmethod view ((name index-route) posts)
c35bf91a
   (format *standard-output* "~&~S~%" posts)
   (spinneret:with-html
2f4adace
     (:section
      (:h* "Blog Index")
      (:div
       (loop for post in posts
             do (call-current-view post))))))
 
a8cd04b5
 (defmethod view ((name index-route) (post micropost))
2f4adace
   (spinneret:with-html
     (:section.post.micropost
      (content post))))
 
 
a8cd04b5
 (defmethod view ((name index-route) (post macropost))
2f4adace
   (spinneret:with-html
     (:section.post.macropost
      (:h* (:a :href (format nil "/~a" (slugify (title post)))
               (title post))))))
 
 (defun setup-routes (app blog)
   (defroutes app
a8cd04b5
     (("/" :method :GET)
      (as-route
       (make-instance 'index-route :blog blog)))
     (("/:post" :method :GET)
      (lambda (params)
        (format t "~&params: ~s~%" params)
        (let* ((post-name (cdr (assoc :post params)))
               (route (make-instance 'post-route :post (find-post post-name blog))))
          (run-route route params))))))
2f4adace
 
 (defvar *blog*
   (make-blog (make-micropost "first post")
              (make-macropost "This is the title"
                              "This is the post content"))
   "The sample blog: passed lexically to the routes, so rebinding don't change nothin'")
 
 (defun setup (&optional (blog *blog*))
   (prog1-bind (app (make-instance 'ningle:<app>))
     (setup-routes app blog)))
 
 ;;; entrypoint
 (defvar *handler*)
 
 (defun is-running ()
   (and (boundp '*handler*)
        *handler*))
 
 (defun ensure-started (&rest r &key port)
   (declare (ignore port))
   (setf *handler*
         (if (not (is-running))
             (apply 'clack:clackup (setup) r)
             *handler*)))
 
 (defun stop ()
   (if (is-running)
       (progn
         (clack:stop *handler*)
         (makunbound '*handler*)
         nil)
       nil))
 
 #+fw.dev
 (define-cluser-entrypoint (&optional (port 5000))
   (ensure-started :port port))