Starting a Scheme SDK for Equinix Metal

metalctrl/identity.scm

@@ -0,0 +1,53 @@
+(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))))