(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)
(ql:quickload :cl-markdown)
(defpackage :blogerate
(:use :cl :alexandria :ningle :anaphora :ningle :spinneret))
(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 nil :accessor blog-tags)
(authors :initform nil :accessor blog-authors)
(sets :initform nil :accessor blog-sets)
(seed :initarg :seed
:initform (make-array 10
:element-type '(unsigned-byte 8)
:initial-contents (loop for x from 1 to 10 collect (random 256)))
:accessor blog-seed)))
(manardb:defmmclass post-set ()
((id :initarg :id :accessor set-id :initform nil)
(name :initarg :name :accessor set-name)
(posts :initarg :posts :accessor set-posts :initform nil)
(seed :initarg :seed
:initform (make-array 10
:element-type '(unsigned-byte 8)
:initial-contents (loop for x from 1 to 10 collect (random 256)))
:accessor set-seed)))
(manardb:defmmclass post ()
((id :initarg :id :accessor post-id :initform (with-output-to-string (s)
(uuid:print-bytes s (uuid:make-v4-uuid))))
(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))
(set-obj (get-set :name set :author author)))
(push result (blog-posts blog))
(when tags-p
(mapcar (lambda (x) (push (cons x result) (blog-tags blog)))
(post-tags result)))
(push result (set-posts set-obj))
(unless (member set (blog-sets blog) :key #'car :test #'string=)
(push (cons set set-obj) (blog-sets blog)))
(push (cons (post-author result) result) (blog-authors blog))
result))
(defparameter *blog* (get-blog "my-blog9"))
(defvar *app* (make-instance 'ningle:<app>))
(defun get-set-by-id (id &optional (blog *blog*))
(awhen (blog-sets blog)
(awhen (assoc id it :test #'string=)
(cdr it))))
(defun get-set-by-name-and-author (name author)
(flet ((new-set ()
(let ((new-set (make-instance 'post-set :name name)))
(setf (set-id new-set) (get-set-id (set-seed new-set) name author))
new-set)))
(aif (manardb:retrieve-all-instances 'post-set)
(aif (car (remove-if-not (lambda (x) (equal (get-set-id (set-seed x) name author) (set-id x)))
it))
it
(new-set))
(new-set))))
(defun get-set (&key id name author)
(if id
(get-set-by-id id)
(get-set-by-name-and-author name author)))
(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))))
(defmacro with-page ((&key title) &body body)
`(spinneret:with-html-string
(:doctype)
(:html
(:head
(:link :rel "stylesheet" :href "/static/main.css")
(:title ,title))
(:body
(:main
,@body)))))
(defmacro format-post (item)
(alexandria:once-only (item)
`(spinneret:with-html
(:section :class "post-show"
(:h2
(post-title ,item))
(:article
(:raw
(nth-value 1 (cl-markdown:markdown (post-text ,item) :stream nil))))
(:span :class "author"
(post-author ,item))
(:span :class "set"
(post-set ,item))
(:ul.tags
(loop for tag in (post-tags ,item)
collect (:li tag)))))))
(defun get-set-posts (set-name)
(car
(loop for (set . post) in (blog-sets *blog*)
if (string= set set-name)
collect post)))
(defun get-tag (tag-name)
(mapcar #'cdr
(remove-if-not (lambda (x) (string= x tag-name))
(blog-tags *blog*)
:key #'car)))
(setf (route *app* "/posts/:set" :method :GET)
(lambda (params)
(declare (ignorable params))
(let* ((set-name (cdr (assoc :set params)))
(set-title (format nil "Set ~a" set-name))
(set (get-set :id set-name)))
(format nil "~s" (get-set :id set-name))
(with-page (:title set-title)
(:header
(:h1 (set-name set)))
(loop for post in (set-posts set)
collect (format nil "~s" (format-post post)))))))
(setf (route *app* "/posts/:set/:tag" :method :GET)
(lambda (params)
(let* ((set-id (cdr (assoc :set params)))
(tag-name (cdr (assoc :tag params)))
(set (get-set :id set-id))
(set-posts (set-posts set))
(tag-posts (get-tag tag-name))
(display-posts (intersection set-posts tag-posts
:key #'post-id
:test #'string=)))
(with-page (:title (format nil "Set: ~a Tag: ~a" (set-name set) tag-name))
(:header (:h1 (format nil "Set: ~a Tag: ~a" (set-name set) tag-name)))
(mapcar (lambda (post) (format nil "~s" (format-post post)))
display-posts)))))
(spinneret:deftag form-input (body attrs &key name label (type "text"))
(declare (ignore body))
(alexandria:once-only (name)
`(:div.input-group :class ,name ,@attrs
;(:label :for ,name ,label)
(:input :placeholder ,label :type ,type :name ,name))))
(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"
(form-input :name "title" :label "Title")
(form-input :name "author" :label "Author")
(:div.input-group.post
;(:label :for "post" "Post Content")
(:textarea :placeholder "Content" :name "post"))
(form-input :name "set" :label "Set")
(form-input :name "tags" :label "Comma-separated Tags")
(form-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)))
(defun get-set-id (blog-seed set-name author-name)
(let* ((o nil)
(digester (ironclad:make-digest :tiger))
(digest (progn
(ironclad:update-digest digester blog-seed)
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array set-name))
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array author-name))
(ironclad:byte-array-to-hex-string
(ironclad:produce-digest digester))))
(digest-length (length digest)))
(dotimes (x (ceiling (/ digest-length 5)))
(push (subseq digest
(* x 5)
(min digest-length (* (1+ x) 5)))
o))
(format nil "~{~a~^-~}" o)))
(setf (route *app* "/post/new" :method :POST)
(lambda (params)
(format nil "~s" params)
(let* ((author (str-assoc-cdr "author" params))
(set (str-assoc-cdr "set" params))
(new-post
(make-post *blog*
(str-assoc-cdr "title" params)
(str-assoc-cdr "post" params)
author
set
:tags (split-tags (str-assoc-cdr "tags" params)))))
(with-page (:title (post-title new-post))
(:header
(:h1 "What a Piece of Blog is This?"))
(format-post new-post)))))
(setf (route *app* "/" :method :GET)
(lambda (params)
(declare (ignore params))
(with-page (:title "What a Piece of Blog is This?")
(:header
(:h1 "What a Piece of Blog is This?"))
(loop for new-post in (blog-posts *blog*)
collect
(format-post new-post)))))
(defparameter *handler*
(clack:clackup
(lack.builder:builder
:session
;:csrf
;clack-errors:*clack-error-middleware*
(:static :path "/static/" :root #p"./static/")
*app*) :port 5050))