#lang racket/base
(require racket/class
racket/string
net/url
net/uri-codec
"net.rkt"
(planet neil/json-parsing:1))
(provide oauth2-auth-server<%>
oauth2-auth-server
oauth2-client<%>
oauth2-client
oauth2<%>
oauth2%
oauth2/auth-code
oauth2/refresh-token
google-auth-server)
(define oauth2-auth-server<%>
(interface ()
get-auth-url get-token-url get-tokeninfo-url get-auth-request-url
))
(define oauth2-client<%>
(interface ()
get-id get-secret ))
(define oauth2<%>
(interface ()
get-client get-client-id get-scopes get-access-token get-refresh-token headers ))
(define OOB-uri "urn:ietf:wg:oauth:2.0:oob")
(define oauth2-auth-server%
(class* object% (oauth2-auth-server<%>)
(init-field auth-url
token-url
[tokeninfo-url #f]
[revoke-url #f])
(super-new)
(define/public (get-auth-url) auth-url)
(define/public (get-token-url) token-url)
(define/public (get-tokeninfo-url) tokeninfo-url)
(define/public (get-revoke-url) revoke-url)
(define/public (get-auth-request-url #:client client
#:scopes scopes
#:redirect-uri [redirect-uri OOB-uri]
#:state [state #f]
#:extra-parameters [extra-parameters null])
(url->string
(url-add-query (get-auth-url)
`((response_type . "code")
(client_id . ,(send client get-id))
(redirect_uri . ,redirect-uri)
(scope . ,(string-join scopes " "))
(state . ,(or state ""))
,@extra-parameters))))))
(define (oauth2-auth-server #:auth-url auth-url
#:token-url token-url
#:tokeninfo-url [tokeninfo-url #f]
#:revoke-url [revoke-url #f])
(new oauth2-auth-server%
(auth-url auth-url)
(token-url token-url)
(tokeninfo-url tokeninfo-url)
(revoke-url revoke-url)))
(define google-auth-server
(oauth2-auth-server #:auth-url "https://accounts.google.com/o/oauth2/auth"
#:token-url "https://accounts.google.com/o/oauth2/token"
#:tokeninfo-url "https://www.googleapis.com/oauth2/v1/tokeninfo"
#:revoke-url "https://accounts.google.com/o/oauth2/revoke"))
(define oauth2-client%
(class* object% (oauth2-client<%>)
(init-field id secret)
(super-new)
(define/public (get-id) id)
(define/public (get-secret) secret)))
(define (oauth2-client #:id id #:secret [secret #f])
(new oauth2-client% (id id) (secret secret)))
(define oauth2%
(class* object% (oauth2<%>)
(init-field client
auth-server)
(field [scopes null]
[token-type #f]
[access-token #f]
[refresh-token #f]
[expiration +inf.0])
(super-new)
(define/public (get-auth-server) auth-server)
(define/public (get-client) client)
(define/public (get-client-id) (send client get-id))
(define/public (get-scopes) scopes)
(define/public (get-access-token #:re-acquire? [re-acquire? #t]
#:who [who 'oauth2:get-access-token])
(cond [(< (current-inexact-milliseconds) expiration)
access-token]
[re-acquire?
(re-acquire-token! #:who who)
access-token]
[else #f]))
(define/public (get-refresh-token)
refresh-token)
(define/public (re-acquire-token! #:who [who 'oauth2:re-acquire-token!])
(cond [refresh-token
(refresh-token! #:who who)]
[else
(error who "access token expired; no method of re-acquiring access")]))
(define/public (acquire-token/auth-code! auth-code
#:redirect-uri [redirect-uri OOB-uri]
#:who [who 'oauth2:acquire-token/auth-code!])
(let* ([now (current-inexact-milliseconds)]
[json (acquire-token/auth-code/json #:auth-code auth-code
#:redirect-uri redirect-uri)])
(reset-from-json! who now json)))
(define/public (refresh-token! #:who [who 'oauth2:refresh-token!])
(unless refresh-token (error who "refresh-token not available"))
(let* ([now (current-inexact-milliseconds)]
[json (refresh-token/json #:who who)])
(reset-from-json! who now json)))
(define/public (validate! #:who [who 'oauth2:validate!])
(let* ([tokeninfo-url (or (send auth-server get-tokeninfo-url)
(error who "no validatation url for auth server"))]
[json
(get/url (url-add-query tokeninfo-url
`((access_token . ,(get-access-token #:who who))))
#:handle json->sjson
#:who who)])
(unless (equal? (hash-ref json 'audience #f) (send client get-id))
(error who "invalid token: not issued to client"))
(let ([scope (hash-ref json 'scope "")])
(unless (equal? scope "")
(set! scopes (regexp-split #rx" +" scope))))
(void)))
(define/public (revoke! #:who [who 'oauth2:revoke!])
(let* ([revoke-url (or (send auth-server get-revoke-url)
(error who "no revocation url for auth server"))]
[json
(get/url (url-add-query revoke-url `((token . ,refresh-token)))
#:handle void
#:who who)])
(set! access-token #f)
(set! refresh-token #f)))
(define/public (acquire-token/auth-code/json #:auth-code auth-code
#:redirect-uri redirect-uri
#:who [who 'oauth2:acquire-token/auth-code/json])
(post/url (send auth-server get-token-url)
#:headers (form-headers)
#:data (body/acquire-token #:auth-code auth-code
#:redirect-uri redirect-uri)
#:handle json->sjson
#:who who))
(define/public (body/acquire-token #:auth-code auth-code
#:redirect-uri redirect-uri)
(alist->form-urlencoded
`((grant_type . "authorization_code")
(client_id . ,(send client get-id))
(client_secret . ,(or (send client get-secret) ""))
(code . ,auth-code)
(redirect_uri . ,redirect-uri))))
(define/public (refresh-token/json #:who [who 'oauth2:refresh-token/json])
(post/url (send auth-server get-token-url)
#:headers (form-headers)
#:data (body/refresh-token)
#:handle json->sjson
#:who who))
(define/public (body/refresh-token)
(alist->form-urlencoded
`((grant_type . "refresh_token")
(client_id . ,(send client get-id))
(client_secret . ,(or (send client get-secret) ""))
(refresh_token . ,refresh-token))))
(define/public (reset-from-json! who now json)
(let* ([new-access-token (hash-ref json 'access_token)]
[new-token-type (hash-ref json 'token_type)]
[new-refresh-token (hash-ref json 'refresh_token #f)]
[new-scope (hash-ref json 'scope "")]
[new-expires-in (hash-ref json 'expires_in +inf.0)])
(unless (string-ci=? new-token-type "Bearer")
(error who "unsupported token type: ~e" new-token-type))
(set! access-token new-access-token)
(set! token-type new-token-type)
(when new-refresh-token
(set! refresh-token new-refresh-token))
(set! expiration (+ now (* 1000 new-expires-in)))
(unless (equal? new-scope "")
(set! scopes (regexp-split #rx" +" new-scope)))
(void)))
(define/public (headers)
(list (format "Authorization: Bearer ~a" (get-access-token))))
))
(define (oauth2/auth-code auth-server client auth-code
#:redirect-uri [redirect-uri OOB-uri])
(let ([oauth2 (new oauth2% (auth-server auth-server) (client client))])
(send oauth2 acquire-token/auth-code!
auth-code
#:redirect-uri redirect-uri
#:who 'oauth2/auth-code)
oauth2))
(define (oauth2/refresh-token auth-server client refresh-token)
(let ([oauth2 (new oauth2% (auth-server auth-server) (client client))])
(set-field! refresh-token oauth2 refresh-token)
(send oauth2 refresh-token! #:who 'oauth2/refresh-token)
oauth2))