;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

(define-module (webfinger webfinger)
  #:use-module (json)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (web client)
  #:use-module (web uri)
  #:export (jrd-record?
            make-jrd-record
            jrd-record-subject
            jrd-record-aliases
            jrd-record-properties
            jrd-record-links

            make-link-record
            link-record?
            link-record-rel
            link-record-type
            link-record-href
            link-record-titles
            link-record-properties

            webfinger-query
            find-actor-object))

(define-record-type <jrd-record>
  (make-jrd-record subject aliases properties links)
  jrd-record?
  (subject    jrd-record-subject) ; string
  (aliases    jrd-record-aliases) ; string list
  (properties jrd-record-properties) ; alist whose keys and values are strings
  (links      jrd-record-links)) ; list of links

(define-record-type <link-record>
  (make-link-record rel type href titles properties)
  link-record?
  (rel        link-record-rel) ; string
  (type       link-record-type) ; string
  (href       link-record-href) ; string
  (titles     link-record-titles) ; alist whose keys are languages or "und" and values ar strings
  (properties link-record-properties)) ; alist whose keys and values are strings

(define (download-json uri)
  (json-string->scm
    (call-with-values
      (lambda ()
        (http-get uri #:headers '((Accept . "application/jrd+json"))))
      (lambda (hdr body)
        (utf8->string body)))))

(define* (webfinger-query server resource #:optional rel)
  "Queries a webfinger @var{server} for @var{resource}.  This follows the
webfinger specification at @url{https://tools.ietf.org/html/rfc7033}.  Returns
a @code{jrd-record} object."
  (let* ((uri (or (string->uri server) (build-uri 'https #:host server)))
         (query (string-append "resource=" resource
                               (if rel
                                   (apply
                                     string-append
                                     (map
                                       (lambda (rel)
                                         (string-append "rel=" rel))
                                       rel))
                                   "")))
         (uri (build-uri
                'https
                #:host (uri-host uri)
                #:path "/.well-known/webfinger"
                #:query query))
         (json (download-json uri)))
    (let ((subject (assoc-ref json "subject"))
          (aliases (assoc-ref json "aliases"))
          (properties (assoc-ref json "properties"))
          (links (assoc-ref json "links")))
    (make-jrd-record
      subject
      (if aliases (array->list aliases) '())
      (or properties '())
      (if links
          (map
            (lambda (link)
              (make-link-record
                (assoc-ref link "rel")
                (assoc-ref link "type")
                (assoc-ref link "href")
                (assoc-ref link "titles")
                (assoc-ref link "properties")))
            (array->list links))
          '())))))

(define (find-actor-object user server)
  "Find the actor object of @var{user} on @var{server}.  This uses the webfinger
protocol to find the user actor object URL, which does not have any default
or common location.  This is used in many services that implement the
ActivityPub protocol."
  (let* ((server (if (string->uri server) (uri-host (string->uri server)) server))
         (resource (webfinger-query server (string-append "acct:" user "@"
                                                          server)))
         (links (jrd-record-links resource)))
    (link-record-href
      (car (filter
             (lambda (link)
               (equal? (link-record-type link) "application/activity+json"))
             links)))))