(use-modules (rnrs conditions) (rnrs io ports) (rnrs records syntactic) (srfi srfi-1) (srfi srfi-11) (srfi srfi-19) (srfi srfi-26) (srfi srfi-37) (ice-9 match) (ice-9 popen) (web client) (web http) (web response) (json) (lens)) (define-record-type ( droplet droplet?) (fields (immutable id droplet-id) (immutable name droplet-name))) (define-record-type ( snapshot snapshot?) (fields (immutable id snapshot-id) (immutable name snapshot-name) (immutable date snapshot-date))) (define (call-with-input-pipe command proc) "Call @var{proc} with input pipe to @var{command}. @var{command} is a list of program arguments." (match command ((prog args ...) (let ((port #f)) (dynamic-wind (lambda () (set! port (apply open-pipe* OPEN_READ prog args))) (cut proc port) (lambda () (unless (zero? (close-pipe port)) (error "Command invocation failed" command)))))))) (define (get-api-key api-key-command) "Run @var{api-key-command} and get the API key." ;; We use a shell to execute since ;; 1. api-key-command is a string, not a list of string arguments ;; 2. api-key-command may contain pipes (string-trim-right (call-with-input-pipe `("sh" "-c" ,api-key-command) get-string-all) #\newline)) (define* (json-request method url #:key (headers '()) body) "Send a HTTP @var{method} request to @var{url} with @var{body} and additional @var{headers}. Return JSON response." (let-values (((response body) (http-request url #:method method #:headers headers #:body body #:streaming? #t))) ;; Guile does not consider application/json responses as textual, and does ;; not automatically set the port encoding to UTF-8. (when body (set-port-encoding! body "UTF-8")) (case (quotient (response-code response) 100) ((2) (and body (json->scm body))) ((4) (raise-exception (condition (make-violation) (make-irritants-condition (list method url headers body)) (make-message-condition (string-append "JSON API request failed with client error code " (number->string (response-code response))))))) (else (raise-exception (condition (make-error) (make-irritants-condition (list method url headers body)) (make-message-condition (string-append "JSON API request failed with code " (number->string (response-code response)))))))))) (define* (json-get url #:key (headers '())) "Send a GET request to @var{url} with @var{headers}. Return JSON response." (json-request 'GET url #:headers headers)) (define* (json-post url #:key (headers '()) json) "Send a POST request to @var{url} with @var{json} body and additional @var{headers}. The @samp{Content-Type} header is set to @samp{application/json} and need not be specified in @var{headers}. Return JSON response." (json-request 'POST url #:headers `((content-type application/json) ,@headers) #:body (scm->json-string json))) (define* (json-delete url #:key (headers '())) "Send a DELETE request to @var{url} with @var{headers}. Return JSON response." (json-request 'DELETE url #:headers headers)) ;; Declare the Authorization header as opaque so that Guile doesn't try to mess ;; with it. (declare-opaque-header! "Authorization") (define (digitalocean-droplets api-key) "Return list of all droplets. @var{api-key} is the DigitalOcean API key for authentication." (map (lambda (tree) (droplet (focus (key-ref "id") tree) (focus (key-ref "name") tree))) (vector->list (focus (key-ref "droplets") (json-get "https://api.digitalocean.com/v2/droplets" #:headers `((authorization . ,(string-append "Bearer " api-key)))))))) (define (digitalocean-snapshots api-key) "Return list of all snapshots. @var{api-key} is the DigitalOcean API key for authentication." (map (lambda (tree) (snapshot (focus (key-ref "id") tree) (focus (key-ref "name") tree) (string->date (focus (key-ref "created_at") tree) "~Y-~m-~dT~H:~M:~S~z"))) (vector->list (focus (key-ref "snapshots") (json-get "https://api.digitalocean.com/v2/snapshots" #:headers `((authorization . ,(string-append "Bearer " api-key)))))))) (define (current-unix-time) (time-second (date->time-monotonic (current-date)))) (define (digitalocean-create-snapshot droplet api-key) (json-post (string-append "https://api.digitalocean.com/v2/droplets/" (number->string (droplet-id droplet)) "/actions") #:headers `((authorization . ,(string-append "Bearer " api-key))) #:json `(("type" . "snapshot") ("name" . ,(string-append (droplet-name droplet) "-" (number->string (current-unix-time))))))) (define (digitalocean-delete-snapshot snapshot-id api-key) (json-delete (string-append "https://api.digitalocean.com/v2/snapshots/" (number->string snapshot-id)) #:headers `((authorization . ,(string-append "Bearer " api-key))))) (define (date-listing date) (string-append (date->string date "~A, ~B ~e, ") (string-trim (date->string date "~l:~M ~p")))) (define (list-snapshots api-key) (for-each (lambda (snapshot) (display (string-join (list (snapshot-id snapshot) (snapshot-name snapshot) (date-listing (snapshot-date snapshot))) "\t")) (newline)) (digitalocean-snapshots api-key))) (define (list-droplets api-key) (for-each (lambda (droplet) (display (string-join (list (number->string (droplet-id droplet)) (droplet-name droplet)) "\t")) (newline)) (digitalocean-droplets api-key))) (define (create-snapshot of-droplet-id api-key) (digitalocean-create-snapshot (find (lambda (droplet) (= (droplet-id droplet) of-droplet-id)) (digitalocean-droplets api-key)) api-key)) (define (delete-snapshot snapshot-id api-key) (digitalocean-delete-snapshot snapshot-id api-key)) (define (main) (let ((api-key (get-api-key "pass dev/digitalocean | awk '/^api-key/ { print $2 }'"))) (match (program-arguments) ((program "list-droplets") (list-droplets api-key)) ((program "list-snapshots") (list-snapshots api-key)) ((program "create-snapshot" droplet-id) (create-snapshot (string->number droplet-id) api-key)) ((program "delete-snapshot" snapshot-id) (delete-snapshot (string->number snapshot-id) api-key)) ((program _ ...) (format (current-error-port) "Usage: ~a ACTION Actions: ~a list-droplets ~a list-snapshots ~a create-snapshot DROPLET-ID ~a delete-snapshot SNAPSHOT-ID~%" program program program program program) (exit #f))))) (main)