(use-modules (web client)
	     (json)
	     (srfi srfi-1)
	     (srfi srfi-11))

(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 path headers body))
    (let-values (((resp port) (http-get (combine-path path) #:headers headers
					#: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 (build-project project-alist)
  (list (assoc "id" project-alist)
	(assoc "name" project-alist)))

(define (build-device device-alist)
  (list (assoc "id" device-alist)
	(assoc "hostname" device-alist)))

(define (list-all-projects)
  (handle-pagination "/projects?exclude=devices,memberships,members" "projects" build-project))

(define (list-all-devices project)
  (handle-pagination (format #f "/projects/~a/devices" (project->id project)) "devices" build-device))

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

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



(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" . ,(vlan->metro-code vlan))
     ("description" . ,(vlan->description vlan)))))

(define (build-vlan vlan-alist)
  (list (assoc "id" vlan-alist)
	(assoc "description" vlan-alist)
	(assoc "vxlan" vlan-alist)
	(assoc "metro_code" vlan-alist)))

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