guile-docker/api-utils.scm

(library (api-utils)
  (export define-api-route)
  (import (rnrs base)
          (only (guile)
                lambda* λ
                ;; macro stuff
                syntax-case
                syntax
                identifier?
                datum->syntax
                syntax->datum)
          (web client)
          (web uri)
          (json)
          (ice-9 iconv)
          (ice-9 exceptions)))


(define-syntax http-method->http-call-procedure
  (λ (stx)
    (syntax-case stx (GET HEAD POST PUT DELETE CONNECT OPTIONS TRACE PATH)
      [(_ GET) (syntax http-get)]
      [(_ HEAD) (syntax http-head)]
      [(_ POST) (syntax http-post)]
      [(_ PUT) (syntax http-put)]
      [(_ DELETE) (syntax http-delete)]
      [(_ TRACE) (syntax http-trace)]
      [(_ OPTIONS) (syntax http-options)]
      ;; error case
      [(_ other)
       (syntax
        (raise-exception
         (make-exception
          (make-non-continuable-error)
          (make-exception-with-message "unknown HTTP method used")
          (make-exception-with-irritants (list other))
          (make-exception-with-origin 'http-method->http-call-procedure))))])))


(define-syntax variable-name->string
  (λ (stx)
    (syntax-case stx ()
      ((_ id)
       (identifier? #'id)
       (datum->syntax #'id (symbol->string (syntax->datum #'id)))))))


(define-syntax define-api-route
  ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Methods
  ;; All HTTP methods are literals.
  (syntax-rules (GET HEAD POST PUT DELETE CONNECT OPTIONS TRACE PATH)
    ((define-api-route route http-method my-content-type)
     (define route
       (lambda* (docker-socket #:key (data #f))
         (call-with-values
             (λ ()
               ((http-method->http-call-procedure http-method)
                (variable-name->string route)
                #:port docker-socket
                #:version '(1 . 1)
                #:keep-alive? #f
                #:headers `((host . ("localhost" . #f))
                            (content-type . (my-content-type (charset . "utf-8"))))
                #:body (scm->json-string data)
                #:decode-body? #t
                #:streaming? #f))
           (λ (response response-text)
             (let ([resp-text-as-string (bytevector->string response-text "utf-8")])
               (cons response resp-text-as-string)))))))))