nodeinfo.scm 4.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123
  1. ;; Usage: run with `guile -s' and the only argument being the instance domain/URL.
  2. ;; Example: `guile -s nodeinfo.scm be.cutewith.me'
  3. (use-modules (json)
  4. (ice-9 format)
  5. (ice-9 match)
  6. (ice-9 iconv)
  7. (srfi srfi-1)
  8. (srfi srfi-11)
  9. (rnrs bytevectors)
  10. (web uri)
  11. (web response)
  12. (web client))
  13. ;; Obtaining nodeinfo
  14. (define (string->uri-https s)
  15. "Try parsing the string S as an URI. If no scheme is present in the
  16. string, assume 'https. The path should be empty."
  17. (let* ((base (string->uri-reference s))
  18. (scheme (or (uri-scheme base) 'https))
  19. (host (or (uri-host base) (uri-path base))))
  20. (build-uri scheme
  21. #:userinfo (uri-userinfo base)
  22. #:host host
  23. #:port (uri-port base)
  24. #:validate? #t
  25. #:path ""
  26. #:query (uri-query base))))
  27. (define (nodeinfo-url instance)
  28. "Construct an URL to INSTANCE/.well-known/nodeinfo."
  29. (let* ((base (string->uri-https instance)))
  30. (build-uri (uri-scheme base)
  31. #:userinfo (uri-userinfo base)
  32. #:host (uri-host base)
  33. #:port (uri-port base)
  34. #:validate? #t
  35. #:path "/.well-known/nodeinfo")))
  36. (define (get-json-scm uri)
  37. "Perform a GET request for the URI, parse the response as json and
  38. return a corresponding alist."
  39. (let-values (((res body)
  40. (http-get uri
  41. #:body #f
  42. #:version '(1 . 1)
  43. #:keep-alive? #f
  44. #:decode-body? #t
  45. #:streaming? #f)))
  46. (match (response-code res)
  47. (200
  48. (json-string->scm (bytevector->string body "utf-8")))
  49. (_
  50. ;; Error
  51. (throw 'nodeinfo `((request . ,uri)
  52. (response-code . ,(response-code res))
  53. (response-phrase . ,(response-reason-phrase res))
  54. (response .
  55. ,(if (bytevector? body)
  56. (bytevector->string body "utf-8")
  57. body))))))))
  58. (define (-> data . args)
  59. "Deep accessor for association lists. Example (-> lst 'key1 'key2
  60. 'key3)."
  61. (define (f field acc)
  62. (cond
  63. ((number? field)
  64. (vector-ref acc field))
  65. (else (assoc-ref acc field))))
  66. (fold f data args))
  67. (define (get-nodeinfo-json-url instance)
  68. "Get the URI for the nodeinfo .json file associated with the
  69. instance."
  70. (let* ((uri (nodeinfo-url instance))
  71. (data (get-json-scm uri))
  72. (links (-> data "links")))
  73. (string->uri (assoc-ref (vector-ref links 0) "href"))))
  74. (define (get-nodeinfo instance)
  75. (let* ((uri (get-nodeinfo-json-url instance))
  76. (data (get-json-scm uri))
  77. (metadata (-> data "metadata"))
  78. (users (-> data "usage" "users" "total"))
  79. (posts (-> data "usage" "localPosts"))
  80. (open-registrations (-> data "openRegistrations"))
  81. (name (-> metadata "nodeName"))
  82. (software (-> data "software" "name"))
  83. (version (-> data "software" "version"))
  84. (features (vector->list (-> metadata "features")))
  85. (formats (vector->list (-> metadata "postFormats")))
  86. (mrf-simple (-> metadata "federation" "mrf_simple"))
  87. (mrf-accept (vector->list (-> mrf-simple "accept")))
  88. (mrf-nsfw (vector->list (-> mrf-simple "media_nsfw")))
  89. (mrf-media-remove (vector->list (-> mrf-simple "media_removal")))
  90. (mrf-reject (vector->list (-> mrf-simple "reject")))
  91. (mrf-remove (vector->list (-> mrf-simple "federated_timeline_removal")))
  92. (format-mrf-list (lambda (type l)
  93. (format #t "~:{~3t~a: ~38t~a\n~}"
  94. (map (lambda (x) (list x type)) l)))))
  95. (format #t "Node: ~a (~a)\n" name instance)
  96. (format #t "~d user~:p \t ~d post~:p\n" users posts)
  97. (format #t "Registrations are ~:[closed~;open~]\n" open-registrations)
  98. (format #t "Running ~a ~@[~a~]\n" software version)
  99. (format #t "Features:\n~{~3t - ~a\n~}" features)
  100. (format #t "Enabled formats: ~a\n" formats)
  101. (format #t "MRF (simple) policies:\n")
  102. (format-mrf-list "accept" mrf-accept)
  103. (format-mrf-list "auto-tag NSFW" mrf-nsfw)
  104. (format-mrf-list "remove all media" mrf-media-remove)
  105. (format-mrf-list "remove from TWKN" mrf-remove)
  106. (format-mrf-list "reject" mrf-reject)))
  107. (unless (= (length (command-line)) 2)
  108. (begin
  109. (format (current-error-port) "Usage: guile -s ~a <INSTANCE>\n" (car (command-line)))
  110. (exit)))
  111. (get-nodeinfo (cadr (command-line)))