Starting a Scheme SDK for Equinix Metal

metalapi/device.scm

@@ -0,0 +1,11 @@
+(define-module (metalapi device)
+  #:use-module (metalapi requests)
+  #:use-module (metalapi project)
+  #:export (build-device
+	    list-all-devices))
+
+(define (build-device device-alist)
+  (extract-attrs device-alist "id" "hostname"))
+
+(define (list-all-devices project)
+  (handle-pagination (format #f "/projects/~a/devices" (project->id project)) "devices" build-device))

metalapi/project.scm

@@ -0,0 +1,20 @@
+(define-module (metalapi project)
+  #:use-module (metalapi requests)
+  #:export (list-all-projects
+	    build-project
+	    project->id
+	    project->organization))
+
+(define (list-all-projects)
+  (handle-pagination "/projects?exclude=devices,memberships,members" "projects" build-project))
+
+(define (build-project project-alist)
+  (extract-attrs project-alist "id" "name"))
+
+(define (project->id project)
+  (assoc-ref project "id"))
+
+(define (project->organization project)
+  (let ((project (GET (format #f "/projects/~a" (project->id project)) (headers))))
+    (let ((org (GET (assoc-ref (assoc-ref project "organization") "href") (headers))))
+      (list (assoc "id" org) (assoc "name" org)))))

metalapi/requests.scm

@@ -0,0 +1,129 @@
+(define-module (metalapi requests)
+  #:use-module (web client)
+  #:use-module (json)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (api-key
+	    consumer-token
+
+	    toggle-http-debug
+	    %default-headers
+	    with-staff-headers
+	    headers
+
+	    GET
+	    POST
+	    PUT
+	    DELETE
+
+	    handle-pagination
+
+	    extract-attrs)
+  #:re-export (scm->json))
+
+(define (api-key) (getenv "API_KEY"))
+(define (consumer-token) (getenv "CONSUMER_TOKEN"))
+(define auth-header-key 'x-auth-token)
+(define consumer-header-key 'x-consumer-token)
+(define staff-header (cons 'x-packet-staff "true"))
+(define base-url "https://api.equinix.com/metal/v1")
+(define metal-prefix "/metal/v1")
+
+(define %default-headers
+  `((x-auth-token . ,(api-key))
+    (CONTENT-TYPE . "application/json")
+    (ACCEPT . "application/json")))
+
+(define http-debug? #f)
+
+(define (toggle-http-debug)
+  (set! http-debug? (not http-debug?)))
+
+(define (with-staff-headers thunk)
+  (let ((old-headers %default-headers))
+    (dynamic-wind
+      (lambda () (set! %default-headers (append %default-headers
+					      (list (cons 'X-CONSUMER-TOKEN (consumer-token))
+						    (cons 'X-PACKET-STAFF "true")))))
+      thunk
+      (lambda () (set! %default-headers old-headers)))))
+
+(define (headers)
+  %default-headers)
+
+(define (http-debug method path headers body)
+  (display (format #f "method: ~a\npath: ~a\nheaders: ~a\nbody: ~a\n" method path headers body)))
+
+(define (staff-headers)
+  (let ((consumer-token (getenv "CONSUMER_TOKEN")))
+    (cons (car (headers))
+	  (list
+	   (cons consumer-header-key consumer-token)
+	   staff-header))))
+
+(define (http-req method path headers body)
+  (let ((fixed-path (combine-path path)))
+    (when http-debug? (http-debug method fixed-path headers body))
+    (let-values (((resp port) (http-request fixed-path #:headers headers
+					    #:method method
+					    #:streaming? #t
+					    #:decode-body? #f
+					    #:body body)))
+      (handle-json port))))
+
+
+(define (handle-json port)
+  (with-input-from-port port
+    (lambda ()
+      (let ((res (json->scm port)))
+	(close-port port)
+	res))))
+
+(define (GET path headers)
+  (http-req 'GET path headers #f))
+
+(define (POST path headers body)
+  (http-req 'POST path headers body))
+
+(define (PUT path headers body)
+  (http-req 'PUT  path headers body))
+
+(define (DELETE path headers body)
+  (http-req 'DELETE path headers body))
+
+(define (strip-prefix s prefix)
+  (substring s (string-length prefix)))
+
+(define (combine-path path)
+  (if (string-contains path metal-prefix)
+      (string-append base-url (strip-prefix path metal-prefix))
+      (string-append base-url path)))
+
+(define (meta paginated-json)
+  (assoc-ref paginated-json "meta"))
+
+(define (meta->current-page meta)
+  (assoc-ref meta "current_page"))
+
+(define (meta->last-page meta)
+  (assoc-ref meta "last_page"))
+
+(define (meta->next meta)
+  (assoc-ref (assoc-ref meta "next") "href"))
+
+(define (extract-attrs alist . args)
+  (fold (lambda (key lst) (cons (assoc key alist) lst)) '() args))
+
+
+(define (handle-pagination start-path array-key model-fn)
+  (let ((pagination (meta (GET start-path (headers))))
+	(collection '()))
+    (define (process-page url)
+      (let ((full-page (GET url (headers))))
+	(map (lambda (item)
+	       (set! collection (cons (model-fn item) collection)))
+	     (vector->list (assoc-ref full-page array-key)))
+	(if (meta->next (meta full-page))
+	    (process-page (meta->next (meta full-page)))
+	    (reverse collection))))
+    (process-page start-path)))

metalapi/vlan.scm

@@ -0,0 +1,34 @@
+(define-module (metalapi vlan)
+  #:use-module (metalapi requests)
+  #:use-module (metalapi project)
+  #:export (build-vlan
+	    vlan->project
+	    vlan->metro-code
+	    vlan->vxlan
+
+	    vlan-request-body
+
+	    list-all-vlans))
+
+(define (build-vlan vlan-alist)
+  (extract-attrs vlan-alist "id" "description" "vxlan" "metro_code"))
+
+(define (vlan->project vlan)
+  (project->id (assoc-ref vlan "project")))
+
+(define (vlan->metro-code vlan)
+  (assoc-ref vlan "metro_code"))
+
+(define (vlan->description vlan)
+  (assoc-ref vlan "description"))
+
+(define (vlan-request-body vlan)
+  (scm->json-string
+   `(("metro" . ,(assoc-ref vlan "metro_code"))
+     ("description" . ,(vlan->description vlan)))))
+
+(define (vlan->vxlan vlan)
+  (assoc-ref vlan "vxlan"))
+
+(define (list-all-vlans project)
+  (handle-pagination (format #f "/projects/~a/virtual-networks" (project->id project)) "virtual_networks" build-vlan))

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))))