tapris/tapris/client.scm

;; Authorization code flow:
;; 1) Obtain a <client> by using (register-app).
;; 2) Obtain an authorization code by asking the user
;; to visit the url obtained from `build-authorize-url'.
;; This authorization code can only be used once.
;; 3) Obtain an access token with `get-token' using the authorization code.
;; 4) Optionally, verify the token with `verify-credentials'.
(define-module (tapris client)
  #:use-module (json)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 iconv)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-69)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (web client)
  ;; local
  #:use-module (tapris util)
  #:use-module (tapris json-mapping)
  #:export (CLIENT-NAME
            <client>
            make-client
            alist->client
            client?
            client-instance
            client-id
            client-secret
            client-token set-client-token!

            <mastodon-status>
            json->status
            status?
            status-id
            status-uri
            status-url
            status-account
            status-in-reply-to-id
            status-in-reply-to-account-id
            status-reblog
            status-content
            status-created-at
            status-emojis
            status-replies-count
            status-reblogs-count
            status-favourites-count
            status-reblogged
            status-favourited
            status-muted
            status-sensitive
            status-spoiler-text
            status-visibility
            status-media-attachments
            status-mentions
            status-tags
            status-card
            status-application
            status-language
            status-pinned


            register-app
            build-authorize-url
            get-token
            verify-credentials

            client-post
            client-get
            post-status
            post-media
            get-home-timeline))

(define CLIENT-NAME "TAPRIS")
(define NO-REDIRECT "urn:ietf:wg:oauth:2.0:oob")

(define BOUNDARY "AYYYLMAOxDxDxDBENIS")

(define (make-boundary)
  (let ((n1 (random 100))
        (n2 (random 100)))
    (format #f "~a~a~a" BOUNDARY n1 n2)))

;;; DATASTRUCTURES

(define-record-type <client>
  (make-client instance id secret token)
  client?
  (instance client-instance)
  (id client-id)
  (secret client-secret)
  (token client-token set-client-token!))

(define (alist->client instance alist)
  "Converts an alist (for instance obtained from `json->scm') to a <client>"
  (make-client
   instance
   (assoc-ref alist "client_id")
   (assoc-ref alist "client_secret")
   #f))

(define-json-mapping <status>
  make-status
  status?
  json->status
  status->json
  (id                     status-id)
  (uri                    status-uri)
  (url                    status-url)
  (account                status-account)
  (in-reply-to-id         status-in-reply-to-id "in_reply_to_id")
  (in-reply-to-account-id status-in-reply-to-account-id "in_reply_to_account_id")
  (reblog                 status-reblog)
  (content                status-content)
  (created-at             status-created-at "created_at")
  (emojis                 status-emojis)
  (replies-count          status-replies-count "replies_count")
  (reblogs-count          status-reblogs-count "reblogs_count")
  (favourites-count       status-favourites-count "favourites_count")
  (reblogged              status-reblogged)
  (favourited             status-favourited)
  (muted                  status-muted)
  (sensitive              status-sensitive)
  (spoiler-text           status-spoiler-text "spoiler_text")
  (visibility             status-visibility)
  (media-attachments      status-media-attachments "media_attachments")
  (mentions               status-mentions)
  (tags                   status-tags)
  (card                   status-card)
  (application            status-application)
  (language               status-language)
  (pinned                 status-pinned))


;;;;;;;;;; BASIC API FUNCTIONS

(define* (get-data uri #:optional #:key (token #f))
  (let-values (((res body)
                (http-get uri
                          #:body #f
                          #:version '(1 . 1)
                          #:keep-alive? #f
                          #:headers (if token
                                        `((Authorization
                                           . ,(string-append "Bearer " token)))
                                        '())
                          #:decode-body? #t
                          #:streaming? #f)))
    (match (response-code res)
      (200
       (json-string->scm (bytevector->string body "utf-8")))
      (_
       ;; Error
       (throw 'pleroma `(("request" . ,uri)
                         ("response-code" . ,(response-code res))
                         ("response-phrase" .
                          ,(response-reason-phrase res))
                         ("response" .
                          ,(if (bytevector? body)
                               (bytevector->string body "utf-8")
                               body))))))))

(define* (post-data uri data #:optional #:key (token #f) (content-type "application/json"))
  "Post to URI `uri' with `data' in JSON format."
  (let-values (((res body)
                (http-post uri
                           #:body (if (bytevector? data)
                                      data
                                      (string->bytevector data "utf-8"))
                           #:version '(1 . 1)
                           #:keep-alive? #f
                           #:headers (if token
                                         `((Content-Type . ,content-type)
                                           (Authorization
                                            . ,(string-append "Bearer " token)))
                                         `((Content-Type . ,content-type)))
                           #:decode-body? #t
                           #:streaming? #f)))
    (match (response-code res)
      (200
       (json-string->scm (bytevector->string body "utf-8")))
      (_
       ;; Error
       (throw 'pleroma `(("request" . ,uri)
                         ("response-code" . ,(response-code res))
                         ("response-phrase" .
                          ,(response-reason-phrase res))
                         ("response" .
                          ,(if (bytevector? body)
                               (bytevector->string body "utf-8")
                               body))))))))

;; REGISTERING AN APP

(define (register-app inst-base)
  "Register a new application, the first parameter is a uri."
  (let ((url (uri-set-path-query inst-base
                                 "/api/v1/apps"
                                 ""))
        (data (scm->json-string
               `(("client_name" .  ,CLIENT-NAME)
                 ("redirect_uris" . ,NO-REDIRECT)
                 ("scopes" . "read write follow")))))
    (alist->client inst-base (post-data url data))))


;; GETTING THE AUTH CODE

(define (build-authorize-url client)
  "Construct the URL for obtaining the access tokens."
  (let ((query (alist->query
                `(("client_id" . ,(client-id client))
                  ("client_secret" . ,(client-secret client))
                  ("redirect_uri" . ,NO-REDIRECT)
                  ("response_type" . "code")
                  ("scope" . "read write follow")))))
    (uri-set-path-query (client-instance client) "/oauth/authorize" query)))


;; GETTING AND VERIFYING THE CLIENT TOKEN

(define (get-token client auth-code)
  (let* ((query
          (alist->query
           `(("client_id" . ,(client-id client))
             ("client_secret" . ,(client-secret client))
             ("redirect_uri" . ,NO-REDIRECT)
             ("grant_type" . "authorization_code")
             ("code" . ,auth-code))))
         (url (uri-set-path-query (client-instance client)
                                  "/oauth/token"
                                  query)))
    (assoc-ref (post-data url "") "access_token")))

(define (verify-credentials client)
  (let* ((query
          (alist->query '()))
         (url (uri-set-path-query (client-instance client)
                                  "/api/v1/accounts/verify_credentials"
                                  query)))
    (get-data url #:token (client-token client))))


;; Wew all of this auth crap is over...

;; Simpler API functions

(define (data->json data)
  (cond
   ((string? data) data)
   ((bytevector? data) data)
   (else (scm->json-string data))))

(define* (client-post client endpoint
                      #:optional #:key
                      (data "")
                      (query '())
                      (content-type "application/json"))
  "A \"generic\" client POST request to an endpoint. Data can be
either a Scheme datastructrure (will be converted to JSON), a
string, or a bytevector; a query is an association list."
  (let* ((data (data->json data))
         (query (alist->query query))
         (uri (uri-set-path-query (client-instance client) endpoint query)))
    (post-data uri data #:token (client-token client)
               #:content-type content-type)))

(define* (client-get client endpoint
                      #:optional #:key
                      (query '()))
  "A \"generic\" client GET request to an endpoint. Data can be either
a Scheme datastructrure (will be converted to JSON). The query is an
association list."
  (let* ((query (alist->query query))
         (uri (uri-set-path-query (client-instance client) endpoint query)))
    (get-data uri #:token (client-token client))))


;; Specifics

(define* (post-status client status #:optional #:key (content-type "text/html"))
  (client-post client "/api/v1/statuses" #:data `(("status" . ,status)
                                                  ("content_type" . ,content-type))))

;; TODO: expand file paths
(define* (post-media client file #:optional #:key (status ""))
  (let* ((boundary (make-boundary))
         (media-endp "/api/v1/media")
         (status-endp "/api/v1/statuses")
         (media-data (file-encode file boundary))
         (attachment
          (client-post client media-endp #:data media-data
                     #:content-type (string-append "multipart/form-data; "
                                                   "boundary=" boundary)))
         (attachment-id
          (assoc-ref attachment "id"))
         (data `(("status" . ,status)
                 ("media_ids" . #(,attachment-id)))))
    (client-post client status-endp #:data data)))

(define* (get-home-timeline client #:optional #:key (limit 20))
  "Returns a list of <status>es from the home timeline."
  (map json->status
       (vector->list
        (client-get client "/api/v1/timelines/home" #:query `(("limit" . ,limit))))))