1 files changed, 155 insertions, 0 deletions
diff --git a/jakob/builder/outbox.scm b/jakob/builder/outbox.scm
new file mode 100644
index 0000000..9bd5f75
--- /dev/null
+++ b/jakob/builder/outbox.scm
@@ -0,0 +1,155 @@
+;;; Copyright © 2019 - 2020 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (jakob builder outbox)
+  #:use-module (haunt artifact)
+  #:use-module (haunt html)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (jakob theme)
+  #:use-module (jakob utils pagination)
+  #:use-module (jakob utils sxml)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:export (outbox))
+
+;;; Commentary:
+;;;
+;;; My implementation of an "outbox" for sending comments via Webmention [1] to
+;;; sites that support it.
+;;;
+;;; [1]: https://webmention.net/
+;;;
+;;; Code:
+
+;; Prefix for all pages representing Webmention interactions.
+(define %outbox-prefix "/outbox")
+
+
+;;;
+;;; Profile.
+;;;
+
+(define %h-card
+  `(div (@ (class "u-author h-card"))
+        (img (@ (class "u-photo")
+                (src "/static/image/profile-picture.jpg")
+                (width "40")))
+        (a (@ (class "u-url p-name")
+              (href "http://jakob.space"))
+           "Jakob L. Kreuze")))
+
+
+;;;
+;;; Common rendering code.
+;;;
+
+(define (datetime uri date)
+  `(p (a (@ (class "u-url") (href ,uri))
+         (time (@ (class "dt-published")
+                  (datetime ,(date->string date "~4")))
+               ,(date->string date "~B ~e, ~Y")))))
+
+
+;;;
+;;; Record type for replies -- by far, my most frequently-used type of
+;;; Webmention response.
+;;;
+
+(define-record-type <reply>
+  (make-reply content date target-uri target-handle)
+  reply?
+  (content reply-content)
+  (date reply-date)
+  (target-uri reply-target-uri)
+  (target-handle reply-target-handle))
+
+(define (reply-uri reply)
+  (let* ((date (date->string (reply-date reply) "~Y-~m-~d-~H:~M:~S"))
+         (target (reply-target-handle reply))
+         (slug (format #f "reply-~a-~a" target date)))
+    (string-append %outbox-prefix "/" slug ".html")))
+
+(define reply
+  (match-lambda
+    ((target-uri target-handle date-string content)
+     (let ((date (string->date date-string "~Y-~m-~dT~H:~M:~S~z")))
+       (make-reply content date target-uri target-handle)))))
+
+
+;;;
+;;; Reply rendering.
+;;;
+
+(define (render-reply reply)
+  (let ((content (cons* (car (reply-content reply))
+                        `(@ (class "e-content"))
+                        (cdr (reply-content reply)))))
+    `(div (@ (class "h-entry"))
+          ,%h-card
+          (p "In reply to: "
+             (a (@ (class "u-in-reply-to")
+                   (href ,(reply-target-uri reply)))
+                ,(reply-target-handle reply)))
+          ,content
+          ,(datetime (reply-uri reply) (reply-date reply)))))
+
+(define (render-preview reply)
+  (let* ((simple-text? (eqv? 'p (car (reply-content reply))))
+         (truncated? (and simple-text?
+                          (> (length (cdr (reply-content reply))) 80)))
+         (preview (if simple-text?
+                      (if truncated?
+                          (format #f "~a..."
+                                  (substring (cdr (reply-content reply))
+                                             0 80))
+                          (cdr (reply-content reply)))
+                      "[No preview available...]")))
+    `(section
+      (h2 ,(hyperlink
+            (reply-uri reply)
+            (format #f "Reply directed towards ~a on ~a"
+                    (reply-target-handle reply)
+                    (date->string (reply-date reply) "~B ~e, ~Y"))))
+      (p ,preview))))
+
+(define (reply->page reply)
+  (let ((title (format #f "Reply to ~a" (reply-target-handle reply))))
+    (serialized-artifact (reply-uri reply)
+                         (theme #:title title
+                                ;; #:description (first-paragraph post)
+                                ;; #:keywords (post-ref post 'tags)
+                                #:content (render-reply reply))
+                         sxml->html)))
+
+
+;;;
+;;; Builder.
+;;;
+
+(define (outbox)
+  (let ((replies (map reply (primitive-load "data/replies.scm"))))
+    (lambda (site posts)
+      (append
+       ;; Permalinks.
+       (map reply->page replies)
+
+       ;; Outbox listing.
+       (items->pages render-preview
+                     (reverse replies)
+                     "Webmentions"
+                     (string-append %outbox-prefix "/" "index")
+                     #:items-per-page 50)))))