Tweet from Racket

tweet.rkt

#lang racket
(provide tweet! (struct-out oauth) current-oauth)
(require (only-in racket/random crypto-random-bytes)
         json
         net/url
         (only-in net/uri-codec [uri-unreserved-encode %])
         web-server/stuffers/hmac-sha1
         (only-in net/base64 base64-encode))

;; tweet! : String -> JSON
;; Post a tweet!, return JSON response
;; (Included for backwards compatability
(define (tweet! status)
  (statuses/update status #:include-entities "true"))
 
;; Now with ability to call more of API

(struct missing ())

(define-for-syntax (underscore id)
  (regexp-replace "-" (symbol->string (syntax->datum id)) "_"))

(define-for-syntax (keyword id)
  (string->keyword (symbol->string (syntax->datum id))))

(require (for-syntax racket/syntax))

(define-syntax define/twitter-api
  (λ (stx)
    (syntax-case stx ()
      [(define/twitter-api meth domain name (req ...) (opt ...))
       (with-syntax* ([(req_ ...) (map underscore (syntax->list #'(req ...)))]
                      [(opt# ...) (map keyword (syntax->list #'(opt ...)))]
                      [(opt_ ...) (map underscore (syntax->list #'(opt ...)))]
                      [name_ (underscore #'name)]
                      [url (format "https://~a/1.1/~a.json" (syntax->datum #'domain) (syntax->datum #'name_))]
                      [(opts ...)
                        (apply append
                               (map syntax->list (syntax->list #'((opt# [opt (missing)]) ...))))])
         
         #'(begin (provide name)
                  (define (name req ... opts ...)
                    (define params `((req_ ,req) ...
                                     ,@(if (missing? opt)
                                           '()
                                           `((opt_ ,opt)))
                                     ...))
                    (twitter-call url 'meth params))))])))
            
(define-syntax-rule (define/twitter meth domain (name (req ...) (opt ...)) ...)
  (begin (define/twitter-api meth domain name (req ...) (opt ...))
         ...))
         

(define/twitter POST upload.twitter.com
  [media/upload
   () ; xor media media-data is required
   (media media-data additional-owners)])

(define/twitter POST api.twitter.com
  [statuses/update
   (status)
   (in-reply-to-status-id auto-populate-reply-metadata exclude-reply-user-ids
                          attachment-url media-ids possibly-sensitive lat
                          long place-id display-coordinates trim-user
                          enable-dm-commands
                          fail-dm-commands
                          ; not mentioned in API but used in examples
                          include-entities)])
  
(define/twitter GET api.twitter.com
  [account/settings () ()]
  [account/verify-credentials
   ()
   (include-entities skip-status include-email)]
  [users/profile-banner
   ()
   (user-id screen-name)]

  ;...
  
  [statuses/home-timeline
   ()
   (count since-id max-id trim-user exclude-replies include-entities)]
  [statuses/mention-timeline
   ()
   (count since-id max-id trim-user include-entities)]
  [statuses/user-timeline
   ()
   (user-id screen-name since-id count max-id trim-user exclude-replies include-rts)])
  
 
;; For description, see:
;; https://developer.twitter.com/
;;   en/docs/basics/authentication/guides/authorizing-a-request

(define-struct oauth (consumer-key consumer-sec token token-sec))

(define current-oauth
  (make-parameter
   (oauth (getenv "OAUTH_CONS_KEY")
          (getenv "CONS_SEC")
          (getenv "OAUTH_TOKEN")
          (getenv "OAUTH_TOKEN_SEC"))))
 
(define ++ string-append)
(define (& s) (apply ++ (add-between s "&")))


(define (twitter-call url get/post params)
  (define o (current-oauth))
  (define oauth-nonce (nonce))
  (define timestamp (number->string (current-seconds)))
  
  (define (encode msg)
    (& (map (λ (e) (string-append (first e) "=" (second e)))
            (sort (map (λ (e) (list (% (first e)) (% (second e)))) msg)
                  (λ (elem1 elem2) (string<=? (car elem1) (car elem2)))))))
  
  (define parameter-string
    (encode (append params
                    `(("oauth_consumer_key" ,(oauth-consumer-key o))
                      ("oauth_nonce" ,oauth-nonce)
                      ("oauth_signature_method" "HMAC-SHA1")
                      ("oauth_timestamp" ,timestamp)
                      ("oauth_token" ,(oauth-token o))
                      ("oauth_version" "1.0")))))
  
  (define sig-base-string
    (++ (cond [(eq? get/post 'POST) "POST"]
              [(eq? get/post 'GET)  "GET"])
        "&" (% url) "&" (% parameter-string)))
  
  (define signing-key
    (++ (% (oauth-consumer-sec o)) "&" (% (oauth-token-sec o))))
  
  (define oauth-signature
    (bytes->string/utf-8 
     (base64-encode (HMAC-SHA1 (string->bytes/utf-8 signing-key)
                               (string->bytes/utf-8 sig-base-string))
                    #"")))
  
  (define header
    (list "Accept: */*"
          "Connection: close"
          "Content-Type: application/x-www-form-urlencoded"
          (++ "Authorization: OAuth "
              "oauth_consumer_key=\"" (% (oauth-consumer-key o)) "\", "
              "oauth_nonce=\"" oauth-nonce "\", "
              "oauth_signature=\"" (% oauth-signature) "\", "
              "oauth_signature_method=\"HMAC-SHA1\", "
              "oauth_timestamp=\"" timestamp "\", "
              "oauth_token=\"" (% (oauth-token o)) "\", "
              "oauth_version=\"1.0\"")))
  
  (read-json
   (cond [(eq? get/post 'POST)
          (post-pure-port (string->url url)
                          (string->bytes/utf-8 (params->string params))
                          header)]
         [(eq? get/post 'GET)           
          (get-pure-port (string->url (++ url "?" (params->string params)))
                         header)])))


(define (params->string ps)
  (& (map (λ (e) (++ (% (first e)) "=" (% (second e))))
          ps)))


;; nonce : -> String
;; Creates 32 bytes of random alphabetic data
(define (nonce) 
  (define (int->alpha i)
    (define a (modulo i 52))
    (integer->char
     (cond [(<= 0 a 25) (+ a 65)]
           [(<= 26 a 52) (+ a 97 -26)])))
  (apply string
         (map int->alpha
              (bytes->list (crypto-random-bytes 32)))))