54 lines
1.9 KiB
Scheme
54 lines
1.9 KiB
Scheme
(define-module (metalctrl identity)
|
|
#:use-module (json)
|
|
#:use-module (web client)
|
|
#:use-module (web uri)
|
|
#:use-module (ice-9 iconv)
|
|
#:use-module (srfi srfi-11))
|
|
|
|
|
|
(define-public %base-identity-url "https://iam.metalctrl.io/")
|
|
(define (token-endpoint) (string-append %base-identity-url "token"))
|
|
(define (userinfo-endpoint) (string-append %base-identity-url "userinfo"))
|
|
(define (openid-configuration-endpoint) (string-append %base-identity-url "/.well-known/openid-configuration"))
|
|
|
|
|
|
(define token-exchange-headers '((Accept . "application/json")
|
|
(Content-Type . "application/x-www-form-urlencoded")))
|
|
|
|
;;curl -XPOST -d "grant_type=urn:ietf:params:oauth:grant-type:token-exchange&subject_token=$AUTH_TOKEN&subject_token_type=urn:ietf:params:oauth:token-type:jwt" http://localhost:8000/token
|
|
(define-public (exchange-token token)
|
|
(let-values (((resp port) (send-request
|
|
'POST (token-endpoint)
|
|
token-exchange-headers
|
|
(string->bytevector (encode-token-params token) "utf-8"))))
|
|
(assoc-ref (unpack-json port) "access_token")))
|
|
|
|
(define-public (userinfo token)
|
|
(let ((headers (list `(Authorization . ,(string-append "Bearer " token)))))
|
|
(let-values (((resp port) (send-request 'GET (userinfo-endpoint)
|
|
headers
|
|
#f)))
|
|
(unpack-json port))))
|
|
|
|
(define (send-request method uri headers body)
|
|
(http-request uri
|
|
#:method method
|
|
#:headers headers
|
|
#:body body
|
|
#:decode-body? #f
|
|
#:streaming? #t))
|
|
|
|
|
|
(define (encode-token-params token)
|
|
(let ((grant_type "urn:ietf:params:oauth:grant-type:token-exchange")
|
|
(subject_token token)
|
|
(subject_token_type "urn:ietf:params:oauth:token-type:jwt"))
|
|
(string-append (symbol->string 'grant_type) "=" grant_type "&"
|
|
(symbol->string 'subject_token) "=" subject_token "&"
|
|
(symbol->string 'subject_token_type) "=" subject_token_type)))
|
|
|
|
(define (unpack-json port)
|
|
(with-input-from-port port
|
|
(lambda ()
|
|
(json->scm))))
|