new file mode 100644

@@ -0,0 +1,172 @@

+(defpackage :fwoar.blog

+  (:use :cl :araneus :alexandria :serapeum :fw.lu)

+  (:export ))

+(in-package :fwoar.blog)

+

+(defmacro new (class &rest initializer-syms)

+  (multiple-value-bind (required optional rest) (parse-ordinary-lambda-list initializer-syms)

+    (when optional

+      (error "new doesn't handle optional arguments"))

+    (if rest

+        `(make-instance ,class

+                        ,@(mapcan (serapeum:op (list (alexandria:make-keyword _1) _1))

+                                  required)

+                        ,(make-keyword rest) ,rest)

+        `(make-instance ,class

+                        ,@(mapcan (serapeum:op (list (alexandria:make-keyword _1) _1))

+                                  initializer-syms)))))

+

+(defun-ct %constructor-name (class)

+  (format nil "~a-~a" '#:make class))

+

+(defmacro make-constructor (class &rest args)

+  (destructuring-bind (class &optional (constructor-name (intern (%constructor-name class))))

+      (ensure-list class)

+    `(defgeneric ,constructor-name (,@args)

+       (:method (,@args)

+         (new ',class ,@args)))))

+

+(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)))

+

+(defclass index (blog-route)

+  ())

+(make-constructor (index make-blog-index))

+

+(defclass post-route (blog-route)

+  ((%post :initarg :post :reader post)))

+(make-constructor (post make-blog-post))

+

+(defmethod controller ((route index) params &key)

+  (posts (blog route)))

+

+(defmethod controller ((route post-route) params &key)

+  (post route))

+

+(defmethod view ((name post-route) (post macropost))

+  (spinneret:with-html-string

+    (:section

+     (:h* (title post))

+     (:div

+      (content post)))))

+

+(defmethod view ((name index) posts)

+  (spinneret:with-html-string

+    (:section

+     (:h* "Blog Index")

+     (:div

+      (loop for post in posts

+            do (call-current-view post))))))

+

+(defmethod view ((name index) (post micropost))

+  (spinneret:with-html

+    (:section.post.micropost

+     (content post))))

+

+

+(defmethod view ((name index) (post macropost))

+  (spinneret:with-html

+    (:section.post.macropost

+     (:h* (:a :href (format nil "/~a" (slugify (title post)))

+              (title post))))))

+

+(defun setup-routes (app blog)

+  (defroutes app

+    (("/" :method :GET) (as-route (make-instance 'index :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))))))

+

+(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))

@@ -1,3 +1,14 @@

+#.(progn

+    (asdf:defsystem :fwoar.gallery

+      :depends-on (:lquery

+                   :araneus

+                   :drakma

+                   :clack

+                   :yason

+                   :ningle

+                   :lass))

+    nil)

+

 (defpackage :fwoar.gallery

   (:use :cl :araneus :alexandria :serapeum)

   (:export ))

@@ -74,6 +85,7 @@

 (defun get-site (uri)

   (hostname-case uri

     ("gfycat.com" :gfycat)

+    ("imgur.com" :imgur)

     ("i.redd.it" :ireddit)

     ("v.redd.it" :vreddit)))

@@ -88,6 +100,13 @@

               (fw.lu:prog1-bind (uri (puri:copy-uri uri))

                 (setf (puri:uri-host uri) "gfycat.com"))

               nil))))

+  (:method ((site (eql :imgur)) uri)

+    (make-image

+     (format nil "~a.jpg"

+             (puri:render-uri

+              (fw.lu:prog1-bind (uri (puri:copy-uri uri))

+                (setf (puri:uri-host uri) "i.imgur.com"))

+              nil))))

   (:method ((site (eql :vreddit)) uri)

     (make-video (puri:render-uri uri nil))))

@@ -112,11 +131,19 @@

                     body)

             )))

-(defmethod view :around ((name (eql 'root)) (model page))

-  (spinneret:with-html-string

-    (:html

-     (:head

-      (css

+(spinneret:deftag js (body attrs)

+  `(:script :type "text/javascript"

+            ,@attrs

+            (:raw

+             ,(format nil "~%")

+             (ps:ps

+               ,@body))))

+

+(defun gallery-css ()

+  (spinneret:with-html

+    (css

+      (:let ((bottom-gap 2em)

+             (gallery-height (calc (- 100vh 2em))))

         (*

          :box-sizing border-box)

         (html

@@ -127,22 +154,21 @@

         (.gallery

          :position relative

-         :display flex

+         :column-count 4

          :width 100vw

-         :height (calc (- 100vh 2em))

+         :height #(gallery-height)

          :overflow-y scroll

          :background "#888"

          :flex-wrap wrap)

         ((.gallery > div)

          :text-align center

-         :width 25%

          :max-height 25vh

          :overflow hidden)

         ((.gallery img)

          :width 98%

          :height 98%

-         :object-fit contain)

+         :object-fit cover)

         ((.gallery video)

          :width 98%

          :height 98%

@@ -151,7 +177,7 @@

          :position fixed

          :top 0

          :left 0

-         :max-height (calc (- 100vh 2em))

+         :max-height #(gallery-height)

          :height 100%

          :width 100%

          :background "#eee")

@@ -162,11 +188,35 @@

          :height 100%)

         ((.gallery > div.expanded > img)

          :display inline-block

+         :object-fit contain

          :vertical-align middle

          :height (calc (- 100vh 2em)))

         ((.gallery > div.expanded > video)

          :display inline-block

-         :vertical-align middle)))

+         :vertical-align middle)))))

+

+(defun gallery-js ()

+  (js

+   (ps:chain #() for-each

+             (call (ps:chain document

+                             (query-selector-all ".gallery > div"))

+                   (lambda (it)

+                     (ps:chain it (add-event-listener

+                                   "click"

+                                   (lambda ()

+                                     (ps:chain #() for-each

+                                               (call (ps:chain document (query-selector-all ".expanded"))

+                                                     (lambda (other)

+                                                       (unless (eql other it)

+                                                         (ps:chain other class-list (remove "expanded"))))))

+                                     (ps:chain it class-list (toggle "expanded"))))))))) )

+

+

+(defmethod view :around ((name (eql 'root)) (model page))

+  (spinneret:with-html-string

+    (:html

+     (:head

+      (gallery-css))

      (:body

       (let ((*gallery* (make-gallery (subseq (images (gallery model))

                                              (* 52 (1- (page model)))

@@ -178,22 +228,7 @@

         (:a :href (format nil "/?page=~d" (1+ (page model)))

             :style "width: 100%; text-align: center; display: inline-block;"

             "next"))

-      (:script

-       (:raw

-        (ps:ps

-          (ps:chain #() for-each

-                    (call (ps:chain document

-                                    (query-selector-all ".gallery > div"))

-                          (lambda (it)

-                            (ps:chain it (add-event-listener

-                                          "click"

-                                          (lambda ()

-                                            (ps:chain #() for-each

-                                                      (call (ps:chain document (query-selector-all ".expanded"))

-                                                            (lambda (other)

-                                                              (unless (eql other it)

-                                                                (ps:chain other class-list (remove "expanded"))))))

-                                            (ps:chain it class-list (toggle "expanded")))))))))))))))

+      (gallery-js)))))

 (define-view root ((model page))

   (spinneret:with-html

@@ -215,6 +250,12 @@

   (defroutes app

     (("/") (as-route 'root :gallery gallery))))

+(defun get-reddit-items (r)

+  (process-uri-list

+   (mapcar (lambda (i)

+             (fw.lu:pick '("data" "url") i))

+           (fw.lu:pick '("data" "children") r))))

+

 (defun main (url)

   (let* ((app (make-instance 'ningle:<app>))

          (gallery (page->gallery (plump:parse

@@ -224,12 +265,6 @@

     (initialize-app app gallery)

     (clack:clackup app)))

-(defun get-reddit-items (r)

-  (process-uri-list

-   (mapcar (lambda (i)

-             (fw.lu:pick '("data" "url") i))

-           (fw.lu:pick '("data" "children") r))))

-

 (defun reddit-main (subreddits)

   (let* ((app (make-instance 'ningle:<app>))

          (gallery (make-gallery

@@ -245,3 +280,8 @@

     (setf *gallery* gallery)

     (initialize-app app gallery)

     (clack:clackup app)))

+

+(defun cl-user::fwoar.gallery.main (version init)

+  (ecase version

+    (:reddit (reddit-main init))

+    (:dir (main init))))