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

            jrd-record->json

            json->jrd-record

            make-link-record

            link-record?

            link-record-rel

            link-record-type

            link-record-href

            link-record-titles

            link-record-properties

            link-record->json

            json->link-record

            webfinger-query

            find-actor-object

            jrd->string))

(define-json-mapping <link-record> make-link-record link-record?

  json->link-record <=> link-record->json

  (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-json-mapping <jrd-record> make-jrd-record jrd-record?

  json->jrd-record <=> jrd-record->json

  (subject    jrd-record-subject) ; string

  (aliases    jrd-record-aliases "aliases" ; string list

              (lambda (val)

                (if val (array->list val) '()))

              (lambda (val) (list->array 1 val)))

  (properties jrd-record-properties) ; alist whose keys and values are strings

  (links      jrd-record-links "links" ; list of links

              (lambda (val)

                (if val (map json->link-record (array->list val)) '()))

              (lambda (val) (list->array 1 (map link-record->json val)))))

(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->jrd-record (download-json uri))))

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

(define (jrd->string jrd)

  (scm->json-string

    (let ((subject (jrd-record-subject jrd))

          (aliases (jrd-record-aliases jrd))

          (properties (jrd-record-properties jrd))

          (links (jrd-record-links jrd)))

    `(("subject" . ,subject)

      ,@(if (and aliases (not (null? aliases)))

            `(("aliases" . ,(list->array 1 aliases)))

            '())

      ,@(if (and properties (not (null? properties)))

            `(("properties" . ,properties))

            '())

      ("links" . ,(list->array 1 (map link->scm links)))))))

(define (link->scm link)

  (let ((rel (link-record-rel link))

        (type (link-record-type link))

        (href (link-record-href link))

        (titles (link-record-titles link))

        (properties (link-record-properties link)))

    `(("rel" . ,rel)

      ,@(if type `(("href" . ,href)) '())

      ("href" . ,href)

      ,@(if type `(("titles" . ,titles)) '())

      ,@(if type `(("properties" . ,properties)) '()))))