Working delete instance for all cases.
This commit is contained in:
@@ -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
|
||||
|
||||
116
src/nassella.scm
116
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."))
|
||||
(Field (@ (name "instance-domain") (label ("Domain")) (value ""))))
|
||||
(@ (title "Delete Instance"))
|
||||
(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
|
||||
car
|
||||
(filter cdr
|
||||
(get-user-selected-apps db (session-user-id) instance-id))))
|
||||
`((selected-apps . ,(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)
|
||||
(with-input-from-file (string-append dir "/make-out") read-string))
|
||||
'failed
|
||||
(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))
|
||||
(when exit-normal
|
||||
(destroy-instance db instance-id))))))))))))
|
||||
(redirect (conc "/destroy-success/" (alist-ref "id" (current-params) equal?)))))))
|
||||
(if (eof-object? tf-state-backup) "" tf-state-backup))))
|
||||
;; todo handle errors here
|
||||
(when delete-backups
|
||||
(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"
|
||||
|
||||
Reference in New Issue
Block a user