Add DigitalOcean snapshots management script.

1 files changed, 207 insertions, 0 deletions

diff --git a/digitalocean-snapshots.scm b/digitalocean-snapshots.scm
new file mode 100644
index 0000000..e1e0fb1
--- /dev/null
+++ b/digitalocean-snapshots.scm
@@ -0,0 +1,207 @@
+(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 droplet?)
+  (fields (immutable id droplet-id)
+          (immutable name droplet-name)))
+
+(define-record-type (<snapshot> 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)