Working delete instance for all cases.

src/Dockerfile

@@ -30,7 +30,7 @@ RUN chicken-install srfi-1 srfi-13 srfi-18 srfi-19 srfi-158 srfi-194 \
         sxml-transforms schematra \
         uri-common http-client medea intarweb \
         sql-null openssl postgresql crypto-tools \
-        hmac sha2 string-utils
+        hmac sha2 string-utils base64
 
 WORKDIR /var
 RUN mkdir nassella

src/nassella.scm

@@ -54,7 +54,8 @@
         spiffy
         hmac
         sha256-primitive
-        string-hexadecimal)
+        string-hexadecimal
+        base64)
 
 (define app (schematra/make-app))
 
@@ -656,6 +657,66 @@ h1, h2, h3, h4, h5, h6 {
                                   (email . ,email))))))))
       read-json)))
 
+;; returns something like:
+;; ((accountId . "xxx") (apiInfo (storageApi (absoluteMinimumPartSize . 5000000) (allowed (buckets . #(((id . "yyy") (name . "aaa")))) (capabilities . #("readBucketEncryption" "listFiles" "shareFiles" "listBuckets" "readBucketLifecycleRules" "readBuckets" "readFiles" "writeBucketReplications" "writeBucketNotifications" "listAllBucketNames" "writeFiles" "writeBuckets" "writeBucketEncryption" "deleteFiles" "writeBucketLogging" "readBucketLogging" "readBucketReplications" "writeBucketLifecycleRules" "readBucketNotifications")) (namePrefix . null)) (apiUrl . "https://api004.backblazeb2.com") (downloadUrl . "https://f004.backblazeb2.com") (recommendedPartSize . 100000000) (s3ApiUrl . "https://s3.us-west-004.backblazeb2.com"))) (applicationKeyExpirationTimestamp . null) (authorizationToken . "abc"))
+;; #<URI-common: scheme=https port=443 host="api.backblazeb2.com" path=(/ "b2api" "v4" "b2_authorize_account") query=() fragment=#f>
+;; #<intarweb#response>
+;; ; 3 values
+(define (b2-authorize-account key-id key)
+  (with-input-from-request
+      (make-request method: 'GET
+                    uri: (uri-reference "https://api.backblazeb2.com/b2api/v4/b2_authorize_account")
+                    headers: (headers `((authorization #(,(string-append "Basic " (base64-encode (string-append key-id ":" key))) raw)))))
+    #f
+    read-json))
+
+(define (b2-authorization-details key-id key)
+  (let* ((auth (b2-authorize-account key-id key))
+         (buckets (alist-ref 'buckets (alist-ref 'allowed (alist-ref 'storageApi (alist-ref 'apiInfo auth))))))
+    (values (alist-ref 'authorizationToken auth)
+            (alist-ref 'accountId auth)
+            (alist-ref 'apiUrl (alist-ref 'storageApi (alist-ref 'apiInfo auth)))
+            (alist-ref 'id (car buckets)) ;; assume at least one bucket and the one we want for now
+            (alist-ref 'name (car buckets))
+            buckets)))
+
+(define (b2-list-file-versions api-url account-token bucket-id)
+  (with-input-from-request
+      (make-request method: 'GET
+                    uri: (uri-reference (string-append api-url "/b2api/v4/b2_list_file_versions?bucketId=" bucket-id))
+                    headers: (headers `((authorization #(,account-token raw))
+                                        (content-type application/json))))
+    #f
+    read-json))
+
+(define (b2-list-file-versions-only-name-id api-url account-token bucket-id)
+  (map (lambda (x)
+         (cons (alist-ref 'fileName x)
+               (alist-ref 'fileId x)))
+       (alist-ref 'files (b2-list-file-versions api-url account-token bucket-id))))
+
+(define (b2-delete-file-version api-url account-token file-name file-id)
+  (with-input-from-request
+      (make-request method: 'POST
+                    uri: (uri-reference (string-append api-url "/b2api/v4/b2_delete_file_version"))
+                    headers: (headers `((authorization #(,account-token raw))
+                                        (content-type application/json))))
+    (lambda ()
+      (write-json
+       `((fileName . ,file-name)
+         (fileId . ,file-id))))
+    read-json))
+
+(define (b2-delete-bucket-files key-id app-key)
+  (receive (token account-id api-url bucket-id _ _)
+      (b2-authorization-details key-id app-key)
+    (let loop ((files (b2-list-file-versions-only-name-id api-url token bucket-id)))
+      (when (not (null? files))
+        (for-each (lambda (file)
+                    (b2-delete-file-version api-url token (car file) (cdr file)))
+                  files)
+        (loop (b2-list-file-versions-only-name-id api-url token bucket-id))))))
+
 (define (get-digital-ocean-regions api-token)
   (filter
    (lambda (r)
@@ -1685,7 +1746,6 @@ chmod -R 777 /opt/keys")))
              (restic-password (alist-ref 'restic-password results))
              (dir (deployment-directory (session-user-id) instance-id)))
         (setup-deploy-files dir (alist-ref 'state terraform-state) (alist-ref 'backup terraform-state))
-        (log-to (debug-log) "writing configs")
         (with-output-to-file (string-append dir "/config/apps.config")
           (lambda ()
             (map (lambda (e)
@@ -2058,20 +2118,26 @@ chmod -R 777 /opt/keys")))
       (@ (action ,(conc "/destroy-submit/" instance-id)) (method POST))
       (VStack
        (Fieldset
-        (@ (title "Type the domain name of the instance to confirm."))
+        (@ (title "Delete Instance"))
-        (Field (@ (name "instance-domain") (label ("Domain")) (value ""))))
+        (Field (@ (name "instance-domain") (label ("Type the domain name of the instance to confirm.")) (value "")))
+        (Field (@ (name "delete-backups") (label ("Delete backups for this instance")) (type "checkbox"))))
        (Form-Nav (@ (back-to "/dashboard") (submit-button "Destroy"))))))))
 
-;; TODO This is mostly a copy of the deployment POST action
 (post "/destroy-submit/:id"
   (let* ((instance-id (alist-ref "id" (current-params) equal?))
+         (status (string->symbol
+                  (->string
+                   (with-db/transaction
+                    (lambda (db)
+                      (get-most-recent-deployment-status db (session-user-id) instance-id)))))))
+    (if (or (not (or (eq? status 'queued) (eq? status 'in-progress)))
+            (equal? (alist-ref 'force (current-params)) "true"))
+        (let* ((instance-id (alist-ref "id" (current-params) equal?))
+               (restic-snapshot-id (alist-ref 'restic-snapshot-id (current-params)))
                (results
                 (with-db/transaction
                  (lambda (db)
-                 `((selected-apps . ,(map
+                   `((selected-apps . ,(get-user-selected-apps db (session-user-id) instance-id))
-                                      car
-                                      (filter cdr
-                                              (get-user-selected-apps db (session-user-id) instance-id))))
                      (app-config . ,(get-user-app-config db (session-user-id) instance-id))
                      (service-config . ,(get-user-service-config db (session-user-id) instance-id))
                      (terraform-state . ,(get-user-terraform-state db (session-user-id) instance-id))
@@ -2172,11 +2238,13 @@ chmod -R 777 /opt/keys")))
                            ("flatcar_stable_version" . "4593.2.4")))
                     ;; remove the newline that generating the ssh key adds
                     (display "ssh_keys=[\"") (display (string-drop-right ssh-pub-key 1)) (print "\"]")))
-              ;; TODO need a new table to track destroying?
-              ;; as this is creating a new "deployment"
-              ;; to attach state to
                 (let* ((instance-id (alist-ref "id" (current-params) equal?))
+                       (delete-backups (alist-ref 'delete-backups (current-params) equal?))
                        (user-id (session-user-id))
+                       (app-config
+                        (with-db/transaction
+                         (lambda (db)
+                           (get-user-app-config db (session-user-id) instance-id))))
                        (deployment-id (with-db/transaction (lambda (db) (create-deployment db user-id instance-id))))
                        (dir (deployment-directory user-id instance-id)))
                   (thread-start!
@@ -2212,16 +2280,28 @@ chmod -R 777 /opt/keys")))
                                  (with-db/transaction
                                   (lambda (db)
                                     (update-deployment-progress db deployment-id progress)
+                                    (when (= status 0)
                                       (update-deployment-status
                                        db user-id deployment-id
-                                   (if exit-normal 'complete 'failed)
+                                       'failed
-                                   (with-input-from-file (string-append dir "/make-out") read-string))
+                                       (with-input-from-file (string-append dir "/make-out") read-string)))
                                     (update-user-terraform-state db user-id instance-id
                                                                  (if (eof-object? tf-state) "" tf-state)
-                                                               (if (eof-object? tf-state-backup) "" tf-state-backup))
+                                                                 (if (eof-object? tf-state-backup) "" tf-state-backup))))
-                                  (when exit-normal
+                                 ;; todo handle errors here
-                                    (destroy-instance db instance-id))))))))))))
+                                 (when delete-backups
-              (redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?)))))))
+                                   (b2-delete-bucket-files (alist-ref 'backblaze-key-id service-config) (alist-ref 'backblaze-application-key service-config)))
+                                 (with-db/transaction
+                                  (lambda (db)
+                                    (update-deployment-status
+                                     db user-id deployment-id
+                                     'complete
+                                     (with-input-from-file (string-append dir "/make-out") read-string))))
+                                 (with-db/transaction
+                                  (lambda (db)
+                                    (destroy-instance db instance-id)))))))))))
+                (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))))
+        (redirect (conc "/config/wizard/success/" (alist-ref "id" (current-params) equal?))))))
 
 (get/widgets
  ("/destroy-success/:id"