123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123 |
- ;; Usage: run with `guile -s' and the only argument being the instance domain/URL.
- ;; Example: `guile -s nodeinfo.scm be.cutewith.me'
- (use-modules (json)
- (ice-9 format)
- (ice-9 match)
- (ice-9 iconv)
- (srfi srfi-1)
- (srfi srfi-11)
- (rnrs bytevectors)
- (web uri)
- (web response)
- (web client))
- ;; Obtaining nodeinfo
- (define (string->uri-https s)
- "Try parsing the string S as an URI. If no scheme is present in the
- string, assume 'https. The path should be empty."
- (let* ((base (string->uri-reference s))
- (scheme (or (uri-scheme base) 'https))
- (host (or (uri-host base) (uri-path base))))
- (build-uri scheme
- #:userinfo (uri-userinfo base)
- #:host host
- #:port (uri-port base)
- #:validate? #t
- #:path ""
- #:query (uri-query base))))
- (define (nodeinfo-url instance)
- "Construct an URL to INSTANCE/.well-known/nodeinfo."
- (let* ((base (string->uri-https instance)))
- (build-uri (uri-scheme base)
- #:userinfo (uri-userinfo base)
- #:host (uri-host base)
- #:port (uri-port base)
- #:validate? #t
- #:path "/.well-known/nodeinfo")))
- (define (get-json-scm uri)
- "Perform a GET request for the URI, parse the response as json and
- return a corresponding alist."
- (let-values (((res body)
- (http-get uri
- #:body #f
- #:version '(1 . 1)
- #:keep-alive? #f
- #:decode-body? #t
- #:streaming? #f)))
- (match (response-code res)
- (200
- (json-string->scm (bytevector->string body "utf-8")))
- (_
- ;; Error
- (throw 'nodeinfo `((request . ,uri)
- (response-code . ,(response-code res))
- (response-phrase . ,(response-reason-phrase res))
- (response .
- ,(if (bytevector? body)
- (bytevector->string body "utf-8")
- body))))))))
- (define (-> data . args)
- "Deep accessor for association lists. Example (-> lst 'key1 'key2
- 'key3)."
- (define (f field acc)
- (cond
- ((number? field)
- (vector-ref acc field))
- (else (assoc-ref acc field))))
- (fold f data args))
- (define (get-nodeinfo-json-url instance)
- "Get the URI for the nodeinfo .json file associated with the
- instance."
- (let* ((uri (nodeinfo-url instance))
- (data (get-json-scm uri))
- (links (-> data "links")))
- (string->uri (assoc-ref (vector-ref links 0) "href"))))
- (define (get-nodeinfo instance)
- (let* ((uri (get-nodeinfo-json-url instance))
- (data (get-json-scm uri))
- (metadata (-> data "metadata"))
- (users (-> data "usage" "users" "total"))
- (posts (-> data "usage" "localPosts"))
- (open-registrations (-> data "openRegistrations"))
- (name (-> metadata "nodeName"))
- (software (-> data "software" "name"))
- (version (-> data "software" "version"))
- (features (vector->list (-> metadata "features")))
- (formats (vector->list (-> metadata "postFormats")))
- (mrf-simple (-> metadata "federation" "mrf_simple"))
- (mrf-accept (vector->list (-> mrf-simple "accept")))
- (mrf-nsfw (vector->list (-> mrf-simple "media_nsfw")))
- (mrf-media-remove (vector->list (-> mrf-simple "media_removal")))
- (mrf-reject (vector->list (-> mrf-simple "reject")))
- (mrf-remove (vector->list (-> mrf-simple "federated_timeline_removal")))
- (format-mrf-list (lambda (type l)
- (format #t "~:{~3t~a: ~38t~a\n~}"
- (map (lambda (x) (list x type)) l)))))
- (format #t "Node: ~a (~a)\n" name instance)
- (format #t "~d user~:p \t ~d post~:p\n" users posts)
- (format #t "Registrations are ~:[closed~;open~]\n" open-registrations)
- (format #t "Running ~a ~@[~a~]\n" software version)
- (format #t "Features:\n~{~3t - ~a\n~}" features)
- (format #t "Enabled formats: ~a\n" formats)
- (format #t "MRF (simple) policies:\n")
- (format-mrf-list "accept" mrf-accept)
- (format-mrf-list "auto-tag NSFW" mrf-nsfw)
- (format-mrf-list "remove all media" mrf-media-remove)
- (format-mrf-list "remove from TWKN" mrf-remove)
- (format-mrf-list "reject" mrf-reject)))
- (unless (= (length (command-line)) 2)
- (begin
- (format (current-error-port) "Usage: guile -s ~a <INSTANCE>\n" (car (command-line)))
- (exit)))
- (get-nodeinfo (cadr (command-line)))
|