;;;; 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)))))