#lang racket/base

(provide jsonp-baseurl
         jsonp-rpc!
         simple-json-rpc!)

(require racket/match)
(require racket/format)
(require racket/port)
(require net/url)
(require net/uri-codec)
(require net/base64)
(require json)
(require "sessions.rkt")

(define jsonp-baseurl (make-parameter #f))

(define (make-basic-auth-credentials-header username password)
  (define token
    (base64-encode (string->bytes/utf-8 (string-append username ":" password)) #""))
  (string-append "Authorization: Basic " (bytes->string/utf-8 token)))

(define (jsonp-rpc! #:sensitive? [sensitive? #f]
                    #:include-credentials? [include-credentials? #t]
                    #:post-data [post-data #f]
                    site-relative-url
                    original-parameters)
  (define s (current-session))
  (if sensitive?
      (log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
      (log-info "jsonp-rpc: request ~a params ~a~a~a"
                site-relative-url
                original-parameters
                (if post-data
                    (format " post-data: ~v" post-data)
                    "")
                (if include-credentials?
                    (if s
                        " +creds"
                        " +creds(missing)")
                    "")))
  (define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
  (define callback-label (format "callback~a" stamp))
  (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
  (define parameters (cons (cons 'callback callback-label) original-parameters))
  (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
  (define request-urls
    (format "~a~a?~a"
             baseurl
             site-relative-url
             (alist->form-urlencoded parameters)))
  (define request-url (string->url request-urls))
  (define req-headers
    (if include-credentials?
        (list
         (make-basic-auth-credentials-header (session-email s)
                                             (session-password s)))
        null))
  (define-values (body-port response-headers)
    (if post-data
        (values (post-pure-port request-url
                                post-data
                                req-headers)
                'unknown-response-headers-because-post-pure-port-doesnt-return-them)
        (get-pure-port/headers request-url
                               req-headers)))
  (define raw-response (port->string body-port))
  (close-input-port body-port)
  (match raw-response
    [(pregexp extraction-expr (list _ json))
     (define reply (string->jsexpr json))
     (unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
     reply]
    [x
     (error 'jsonp-rpc! "Illegal response to ~v: ~v"
            (if sensitive? "REDACTED" request-urls)
            (if sensitive? "REDACTED" raw-response))]))

(define (simple-json-rpc! #:sensitive? [sensitive? #f]
                          #:include-credentials? [include-credentials? #t]
                          site-relative-url
                          jsexpr-to-send)
  (define s (current-session))
  (if sensitive?
      (log-info "simple-json-rpc: sensitive request ~v" site-relative-url)
      (log-info "simple-json-rpc: request ~v params ~v~a"
                site-relative-url
                jsexpr-to-send
                (if include-credentials?
                    (if s
                        " +creds"
                        " +creds(missing)")
                    "")))
  (define baseurl
    (or (jsonp-baseurl) (error 'simple-json-rpc! "jsonp-baseurl is not set")))
  (define request-urls (format "~a~a" baseurl site-relative-url))
  (define request-url (string->url request-urls))
  (define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
  (define req-headers
    (if include-credentials?
        (list (make-basic-auth-credentials-header (session-email s)
                                                  (session-password s)))
        '()))
  (define response-port (post-pure-port request-url post-data req-headers))
  (define raw-response (port->string response-port))
  (close-input-port response-port)
  (define reply (string->jsexpr raw-response))
  (unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
  reply)