webtentacle/webtentacle.lisp

;;; Copyright 2023, Jaidyn Ann <jadedctrl@posteo.at>
;;;
;;; 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 <https://www.gnu.org/licenses/>.

(defpackage #:webtentacle
  (:use #:cl)
  (:export :server :start-server :clack-response))

(in-package #:webtentacle)


(defun user-json (&key user host aliases properties links)
  "Given the USER’s information, return the applicable Webfinger JSON.
Details of the values of USER, HOST, ALIASES, PROPERTIES, and LINKS can be found
in the docstring of SERVER."
  (let ((yason:*symbol-key-encoder* #'yason:encode-symbol-as-lowercase)
        (yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
    (yason:with-output-to-string* ()
       (yason:with-object ()
         (yason:encode-object-element
          "subject"
          (concatenate 'string "acct:" user "@" host))
         (when (and aliases (listp aliases))
           (yason:encode-object-element "aliases" aliases))
         (when (and properties (listp properties))
           (yason:encode-object-element
            "properties"
            (alexandria:plist-hash-table properties)))
         (when (and links (listp links))
           (yason:encode-object-element
            "links"
            ;; Each link needs to be a hash-table (so it's encoded as a JSON object.
            (mapcar
             (lambda (link)
               ;; Each link’s properties/titles need to be hash-tables, likewise.
               (let ((properties (getf link 'properties))
                     (titles (getf link 'titles)))
                 (when (and properties (not (hash-table-p properties)))
                   (setf (getf link 'properties) (alexandria:plist-hash-table properties)))
                 (when (and titles (not (hash-table-p titles)))
                   (setf (getf link 'titles) (alexandria:plist-hash-table titles))))
               (alexandria:plist-hash-table link))
             links)))))))


(defun fake-info-func (user host)
  "A testing function. This is a USER-INFO-FUNC function that outputs garbage."
  (let ((profile (str:concat "https://example.example/users/" user)))
    (list
     :user user
     :host host
     :aliases (list profile "https://example.example/users/old-user")
     :links
     `((href ,profile
        rel  "http://webfinger.net/rel/profile-page"
        type "text/html"
             properties (:apple 3 :bear 4))
       (href ,profile
        rel  "self"
        type "application/activity+json")))))


(define-condition invalid-acct-uri (error) ()
  (:documentation "Thrown when a user@host acct URI is expected, but is lacking a user or host potion."))


(defun resource-user-host (resource)
  "Given a queried RESOURCE, return a list of its contained user and host."
  (let* ((sans-acct (if (str:starts-with-p "acct:" resource)
                        (subseq resource 5)
                        resource))
         (user-host (str:split #\@ sans-acct)))
    (if (or (not (eq (length user-host) 2))
            (str:emptyp (car user-host))
            (str:emptyp (cadr user-host)))
        (error 'invalid-acct-uri :message "Invalid acct resource")
        user-host)))


(defun filter-link-rels (rels link-plists)
  "Given a list of link property-lists, filter out links whose rel properties
aren’t a member of the RELS list.
If RELS is nil, nothing is filtered out.
If RELS is a list of strings, only links with rel properties matching a member
in RELS will remain."
  (if rels
      (remove-if-not
       (lambda (plist)
         (member (getf plist 'rel) rels :test #'equal))
       link-plists)
      link-plists))


(defun filter-user-info-rels (rels user-info)
  "Filter the :LINKS property-list’s properties from a USER-INFO property-list,
by their relations.
If RELS is nil, nothing is filtered out.
If RELS is a list of strings, only links with rel properties matching a member
in RELS will remain."
  (setf (getf user-info :links) (filter-link-rels rels (getf user-info :links)))
  user-info)


(defun clack-response (user-info-func resource &rest rels)
  "Given a USER-INFO-FUNC (as per the specification of SERVER’s docstring), and
the RESOURCE and RELS parameters from a Webfinger HTTP request, return the
response JSON in Clack’s format.
This can be used if you don’t want to wrap your server with SERVER, and would
rather handle the Webfinger path yourself."
  (list
   200
   '(:content-type "text/plain")
   (list
    (format
     nil "~A"
     (handler-case
         (if (not resource)
             "\"No resource specified\""
             (or (apply #'user-json
                         (filter-user-info-rels
                          rels
                          (apply user-info-func
                                 (resource-user-host resource))))
                 "\"Couldn't find user\""))
       (invalid-acct-uri ()
         "\"Invalid acct URI\"")
       (error (any-error)
         (format nil "\"Server error: ~A\"" any-error)))))))


(defun server (env user-info-func &optional (clack-app nil))
  "Start handling Webfinger requests, wrapping around the given CLACK-APP body
function.

USER-INFO-FUNC should be a function that will return user information to be
served by Webfinger.
USER-INFO-FUNC should take two parameters: Username and host, both strings.
It should return a property-list with some of the following properties:
  * :USER
  * :HOST
  * :ALIASES
  * :PROPERTIES
  * :LINKS
You need at minimum :USER and :HOST, all else is optional.

:ALIASES is a simple list of URLs.
:PROPERTIES is a simple property-list of whatever you want.

:LINKS is a list of property-lists, each with some of (or all) of the keys:
  * rel
  * types
  * href
  * titles
  * properties
… all of which are strings, except for the plists “titles” & “properties.”

“properties” should be a property-list containing whatever you want.
“titles” should contain a property for each language-code, with its
value being the corresponding title; for example,
  '(en “Birds & Planes”
    eo “Birdoj k Aviadiloj”
    es “No habla español :-(”)
"
  (let* ((uri (quri:uri (getf env :request-uri)))
         (params (quri:uri-query-params uri)))
    (if (string= (quri:uri-path uri) "/.well-known/webfinger")
        ;; We only want to handle the *exact* webfinger path
        (apply #'clack-response
               (append (list user-info-func
                             (cdr (assoc "resource" params :test #'string=)))
                       ;; We want all “rel” parameters, not just the first one
                       (mapcar
                        #'cdr
                        (remove-if-not
                          (lambda (pair)
                            (string= (car pair) "rel"))
                          params))))
        ;; At any other path, give control back over to the user’s server
        (or (and clack-app (funcall clack-app env))
            '(512 (:content-type "text/plain") ("HECK"))))))


(defun start-server (user-info-func)
  "Run a Webfinger HTTP server, given a USER-INFO-FUNC (see SERVER’s docstring).
This is useful if you want to delegate Webfinger-handling to this library with a
reverse-proxy.
It is also useful for debugging this library."
  (clack:clackup
   (lambda (env)
     (funcall #'server env user-info-func))))