diff options
Diffstat (limited to 'haunt/jakob')
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/comments.scm | 27 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/common.scm | 4 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/schema-comments.sql | 3 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/util.scm | 23 | ||||
| -rw-r--r-- | haunt/jakob/utils/comments.scm | 15 |
5 files changed, 57 insertions, 15 deletions
diff --git a/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm index 33f2429..ee2a52d 100644 --- a/haunt/jakob/dynamic/capabilities/comments.scm +++ b/haunt/jakob/dynamic/capabilities/comments.scm @@ -42,17 +42,21 @@ This interface exists for dynamically generating the comment view from Haunt." (define (make-internal-comment~ . args) - (let* ((args-needing-processing (take-right args 3)) + (let* ((args-needing-processing (take-right args 4)) (approved (list-ref args-needing-processing 0)) (approved (string->date approved "~Y~m~d ~H~M~S.~N")) (reactions (list-ref args-needing-processing 1)) (reactions (if reactions (with-input-from-string reactions read) '())) - (replies (list-ref args-needing-processing 2))) - + (originating-network (list-ref args-needing-processing 2)) + (replies (list-ref args-needing-processing 3))) (apply make-internal-comment - (append (drop-right args 3) (list approved reactions replies))))) + `(,@(drop-right args 4) + ,approved + ,reactions + ,replies + ,originating-network)))) (define (order-comments comments) (define seen (make-hash-table)) (define (id comment) (first comment)) @@ -78,7 +82,7 @@ This interface exists for dynamically generating the comment view from Haunt." (hash-append! seen 'terminal parsed)) (pass (cdr cur) initial-comments remaining))))) (pass comments comments '())) - (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions, reply_to + (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions, originating_network, reply_to FROM comments WHERE slug = $1 and approved IS NOT NULL") (result (exec-query conn query (list slug)))) (if (positive? (length result)) @@ -106,6 +110,10 @@ This is a wrapper around `get-comments-by-slug'." (define (put-comment request body) "API endpoint handler for submitting a comment" + (define (request-originating-network request) + (cond ((from-tor? request) "tor") + ((from-i2p? request) "i2p") + (else "clearnet"))) (define (valid-comment? form-data) (and (assoc "slug" form-data) (assoc "name" form-data) @@ -124,9 +132,9 @@ This is a wrapper around `get-comments-by-slug'." (string->number (assoc-value form-data "captcha-id")))))) (define (insert-comment form-data) (exec-query conn - "INSERT INTO comments (submitted, slug, name, subject, - email, url, comment, reply_to) - VALUES (now(), $1, $2, $3, $4, $5, $6, $7);" + "INSERT INTO comments (submitted, slug, name, subject, email, + url, comment, reply_to, originating_network) + VALUES (now(), $1, $2, $3, $4, $5, $6, $7, $8);" (list (assoc-value form-data "slug") (assoc-value form-data "name") (assoc-value form-data "subject") @@ -136,7 +144,8 @@ This is a wrapper around `get-comments-by-slug'." (if (and (assoc-value form-data "reply-to") (positive? (string-length (assoc-value form-data "reply-to")))) (assoc-value form-data "reply-to") - #f))) + #f) + (request-originating-network request))) (values (build-response #:code 307 #:headers '((Location . "https://jakob.space"))) diff --git a/haunt/jakob/dynamic/capabilities/common.scm b/haunt/jakob/dynamic/capabilities/common.scm index 0e7d7b8..2bca1a2 100644 --- a/haunt/jakob/dynamic/capabilities/common.scm +++ b/haunt/jakob/dynamic/capabilities/common.scm @@ -31,6 +31,7 @@ internal-comment-publish-time internal-comment-reactions internal-comment-replies + internal-comment-originating-network sort-comments)) (define-json-mapping <internal-comment> @@ -57,7 +58,8 @@ (vector->list x))) (lambda (x) (list->vector (map (lambda (y) (json-string->scm (internal-comment->json y))) - x))))) + x)))) + (originating-network internal-comment-originating-network)) (define (sort-comments comments) "Sort COMMENTS, a list of `<internal-comment>' chronologically" diff --git a/haunt/jakob/dynamic/schema-comments.sql b/haunt/jakob/dynamic/schema-comments.sql index 1f2edc7..8519f4b 100644 --- a/haunt/jakob/dynamic/schema-comments.sql +++ b/haunt/jakob/dynamic/schema-comments.sql @@ -9,7 +9,8 @@ CREATE TABLE comments( url VARCHAR(100), comment VARCHAR(1024) NOT NULL, reactions VARCHAR(1024), - reply_to INT + reply_to INT, + originating_network VARCHAR(100) ); -- Use `now' for `submitted'. diff --git a/haunt/jakob/dynamic/util.scm b/haunt/jakob/dynamic/util.scm index f6f0382..e34ae91 100644 --- a/haunt/jakob/dynamic/util.scm +++ b/haunt/jakob/dynamic/util.scm @@ -20,6 +20,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (web request) #:use-module (web uri) #:export (assoc-value acons-normalize @@ -27,7 +28,10 @@ decode-form date<? hash-append! - emoji?)) + emoji? + from-tor? + from-i2p? + from-darknet?)) (define (assoc-value alist key) "Return the `car' of `(assoc alist key)' if truthy" @@ -110,3 +114,20 @@ to express my God-given constitutional rights!" (<= #x270A codepoint #x270D) (= codepoint #x1F37B) (= codepoint #x1F440))))) + +(define (from-tor? request) + "Return whether or not REQUEST was sent by the Tor daemon" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (or (string=? "127.0.0.1" originating-ip) + (string=? "::1" originating-ip)))) + +(define (from-i2p? request) + "Return whether or not REQUEST was sent by i2pd" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (and (or (string-prefix? "127." originating-ip) + (string-suffix? ":1" originating-ip)) + (not (from-tor? request))))) + +(define (from-darknet? request) + "Return whether or not REQUEST was sent by a darknet tunnel" + (or (from-tor? request) (from-i2p? request))) diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm index f38bb18..4b38fd2 100644 --- a/haunt/jakob/utils/comments.scm +++ b/haunt/jakob/utils/comments.scm @@ -110,9 +110,18 @@ `(img (@ (class "comment-source-identifier") (alt "Icon for comments posted externally and syndicated by Webmention") (src "/static/image/webmention-logo.png"))) - `(img (@ (class "comment-source-identifier") - (alt "Icon for comments posted on jakob.space") - (src "/static/image/lambda.svg")))) + (match (internal-comment-originating-network comment) + ("tor" `(img (@ (class "comment-source-identifier") + (alt "Icon for comments posted on jakob.space via Tor; +The Tor logo belongs to The Tor Project, Inc. and is licensed under the CC BY 3.0 US") + (src "/static/image/lambda.svg")))) + ("i2p" `(img (@ (class "comment-source-identifier") + (alt "Icon for comments posted on jakob.space via I2P; +The I2P logo belongs to The I2P Project, and is licensed under the CC BY 4.0") + (src "/static/image/lambda.svg")))) + (_ `(img (@ (class "comment-source-identifier") + (alt "Icon for comments posted on jakob.space") + (src "/static/image/lambda.svg")))))) (div (@ (class "p-author h-card author")) (img (@ (class "u-photo") (src ,(comment-photo comment))))) (div (@ (class "metaline")) |