git.fiddlerwoaroof.com
Raw Blame History
(declaim (optimize (debug 3) (speed 0) (safety 3)))
(ql:quickload :alexandria)
(ql:quickload :ironclad)
(ql:quickload :uuid)
(ql:quickload :bordeaux-threads)
(ql:quickload :manardb)
(ql:quickload :ningle)
(ql:quickload :anaphora)
(ql:quickload :ubiquitous)
(ql:quickload :spinneret)
(ql:quickload :clack)
(ql:quickload :clack-errors)

(defpackage :blogerate
  (:use :cl :alexandria :ningle :anaphora :ningle))

(in-package :blogerate)
(ubiquitous:restore 'blogerate)

(manardb:use-mmap-dir "/tmp/manardb-blogerate")

(manardb:defmmclass blog ()
    ((id :initarg :id :accessor blog-id)
     (posts :initarg :posts :accessor blog-posts :initform nil)
     (tags :initform (make-hash-table :test #'equal) :accessor blog-tags)
     (authors :initform (make-hash-table :test #'equal) :accessor blog-authors)
     (sets :initform (make-hash-table :test #'equal) :accessor blog-sets)))

(manardb:defmmclass post ()
    ((id :initarg :id :accessor post-id :initform (with-output-to-string (s)
                                                    (uuid:print-bytes s
                                                                      (uuid:make-v5-uuid
                                                                        uuid:+namespace-oid+
                                                                        "blump"))))
     (title :initarg :title :accessor post-title :initform "")
     (text :initarg :text :accessor post-text :initform "")
     (author :initarg :author :accessor post-author :initform "")
     (post-set :initarg :set :accessor post-set :initform "")
     (tags :initarg :tags :initform '() :accessor post-tags)))

(defun make-post (blog title text author set &key (tags nil tags-p))
  (let ((result (make-instance 'post :title title :text text :author author :set set :tags tags)))
    (push result (blog-posts blog))
    (when tags-p
      (mapcar (lambda (x) (push (cons x result) (blog-tags blog)))
              (post-tags result)))
    (push (cons (post-set result) result) (blog-sets blog))
    (push (cons (post-author result) result) (blog-authors blog))
    result))

(defun get-blog (id)
  (flet ((new-blog () (make-instance 'blog :id id)))
    (aif (manardb:retrieve-all-instances 'blog)
      (aif (car (remove-if-not (lambda (x) (equal id (blog-id x))) it))
        it
        (new-blog))
      (new-blog))))

(defparameter *blog* (get-blog "my-blog3"))
(defparameter *app* (make-instance 'ningle:<app>))

(defmacro with-page ((&key title) &body body)
  `(spinneret:with-html-string
     (:doctype)
     (:html
       (:head
         (:link :rel "stylesheet" :href "/static/main.css")
         (:title ,title))
       (:body ,@body))))


(setf (route *app* "/post/new" :method :GET)
      (lambda (params)
        (declare (ignorable params))
        (with-page (:title "new post")
          (:header
            (:h1 "New Post:"))
          (:section :class "post-new"
            (:form :action "/post/new" :method "POST"
             (:input :type "text" :name "title")
             (:input :type "text" :name "author")
             (:textarea :name "post")
             (:input :type "text" :name "set")
             (:input :type "text" :name "tags")
             (:input :type "submit"))))))

(defun str-assoc-cdr (key alist)
  (cdr (assoc key alist :test #'equal)))

(defun split-tags (str)
  (mapcar (lambda (x) (string-trim " " x)) (split-sequence:split-sequence #\, str)))

(setf (route *app* "/post/new" :method :POST)
      (lambda (params)
        (format nil "~s" params)
        (let ((new-post
                (make-post *blog*
                           (str-assoc-cdr "title" params)
                           (str-assoc-cdr "post" params)
                           (str-assoc-cdr "author" params)
                           (str-assoc-cdr "set" params)
                           :tags (split-tags (str-assoc-cdr "tags" params)))))
          (with-page (:title (post-title new-post))
            (:header
              (:h1 (post-title new-post)))
            (:section :class "post-show"
             (:article
               (post-text new-post))
             (:span :class "author"
              (post-author new-post))
             (:span :class "set"
              (post-set new-post)))))))

(setf (route *app* "/" :method :GET)
      (lambda (params)
        (with-page (:title "Blog")
          (:header
            (:h1 "Blog"))
          (loop for new-post in (blog-posts *blog*)
                collect
                (:section :class "post-show"
                 (:h2
                   (post-title new-post))
                 (:article
                   (post-text new-post))
                 (:span :class "author"
                  (post-author new-post))
                 (:span :class "set"
                  (post-set new-post)))))))


(defparameter *handler*
  (clack:clackup
    (lack.builder:builder
      :session
      ;:csrf
      ;clack-errors:*clack-error-middleware*
      (:static :path "/static/" :root #p"./static/")
      *app*) :port 5000))