From e0d897ec8da0900f7620fd1bd554b2bdc6d1374b Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 15 Jun 2025 11:56:08 +0100 Subject: [PATCH 1/2] Improve exception handling --- guile/b2-pitr.scm | 63 +++++++++++++++++++++++++---------------------- 1 file changed, 33 insertions(+), 30 deletions(-) diff --git a/guile/b2-pitr.scm b/guile/b2-pitr.scm index 56950d8..9cf5447 100644 --- a/guile/b2-pitr.scm +++ b/guile/b2-pitr.scm @@ -19,6 +19,33 @@ (web response) (web uri)) +(define-exception-type &api-error &external-error + make-api-error + api-error? + (endpoint api-error-endpoint) + (status-code api-error-status-code) + (body api-error-body)) + +(define (json-response? res) + (eq? 'application/json (car (response-content-type res)))) + +(define (text-response? res) + (string-prefix? "text/" + (symbol->string (car (response-content-type res))))) + +(define-syntax check-api-response + (syntax-rules () + ((check-api-response endpoint res body-port) + (check-api-response endpoint res body-port (<= 100 (response-code res) 399))) + ((check-api-response endpoint res body-port ok?) + (unless ok? + (let ((body (cond + ((json-response? res) (json->scm body-port)) + ((text-response? res) (get-string-all body-port)) + (else "")))) + (close-port body-port) + (raise-exception (make-api-error endpoint (response-code res) body))))))) + (define (encode-query alist) (fold (match-lambda* (((k . v) s) @@ -32,15 +59,6 @@ "" alist)) -(define (http-ok? res) - (<= 200 (response-code res) 299)) - -(define (json-response? res) - (eq? 'application/json (car (response-content-type res)))) - -(define (text-response? res) - (string-prefix? "text/" - (symbol->string (car (response-content-type res))))) ;; We have to override the default handling of the Authorization header as the ;; Backblaze API expects just a bare string. The b2_authorize_account endpoint @@ -53,11 +71,7 @@ (define auth-url "https://api.backblazeb2.com/b2api/v4/b2_authorize_account") (let* ((token (base64-encode (string->bytevector (string-append key-id ":" app-key) "utf-8"))) (res body (http-get auth-url #:headers `((authorization . ,(string-append "Basic " token))) #:streaming? #t))) - (unless (http-ok? res) - (raise-exception (make-exception - (make-external-error) - (make-exception-with-message "Error response from b2_authorize_account") - (make-exception-with-irritants res)))) + (check-api-response "/b2api/v4/b2_authorize_account" res body (and (= 200 (response-code res)) (json-response? res))) (json->scm body))) (define (assoc-ref* alist . keys) @@ -82,28 +96,16 @@ (define-method (account-id (cli )) (assoc-ref (b2-auth-info cli) "accountId")) -(define (check-api-response res body-port err-msg) - (unless (http-ok? res) - (let ((body (cond - ((json-response? res) (json->scm body-port)) - ((text-response? res) (get-string-all body-port)) - (else "Binary response body")))) - (close-port body-port) - (raise-exception (make-exception - (make-external-error) - (make-exception-with-message err-msg) - (make-exception-with-irritants (get-string-all body))))))) - -(define* (api-call cli method path #:key query-params payload raw?) +(define* (api-call cli method endpoint #:key query-params payload raw?) (let* ((url (if query-params - (string-append (api-url cli) path "?" (encode-query query-params)) - (string-append (api-url cli) path))) + (string-append (api-url cli) endpoint "?" (encode-query query-params)) + (string-append (api-url cli) endpoint))) (res body-port (method url #:body (and=> payload scm->json-string) #:headers `((authorization . ,(auth-token cli)) (content-type . (application/json (charset . "utf-8")))) #:streaming? #t))) - (check-api-response res body-port (string-append "Error from " path)) + (check-api-response endpoint res body-port) (if raw? body-port (let ((body (cond @@ -233,6 +235,7 @@ resore these empty files." (define (main args) (define cli (make #:key-id (getenv "BB_KEY_ID") #:app-key (getenv "BB_APP_KEY"))) + (define bucket-id (resolve-bucket-id cli "uk-org-1729-server-backups")) (define cutoff (* 1000 (time-second (date->time-utc (string->date "2025-06-01 00:00:00+0000" "~Y-~m-~d ~H:~M:~S~z"))))) From 91b7c1b55475bf5705f40068d4c509d43422a9a2 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Sun, 15 Jun 2025 15:03:13 +0100 Subject: [PATCH 2/2] Bug fixes, improvements, parallel download --- guile/b2-pitr.scm | 78 ++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 35 deletions(-) mode change 100644 => 100755 guile/b2-pitr.scm diff --git a/guile/b2-pitr.scm b/guile/b2-pitr.scm old mode 100644 new mode 100755 index 9cf5447..7833e5d --- a/guile/b2-pitr.scm +++ b/guile/b2-pitr.scm @@ -8,12 +8,13 @@ (ice-9 exceptions) ((ice-9 iconv) #:select (string->bytevector)) (ice-9 match) + (ice-9 threads) (json) (oop goops) - (srfi srfi-1) - (srfi srfi-19) - (srfi srfi-26) - (srfi srfi-71) + (srfi srfi-1) ;; lists + (srfi srfi-19) ;; date/time + (srfi srfi-26) ;; cut + (srfi srfi-71) ;; extended let (web client) (web http) (web response) @@ -115,12 +116,25 @@ (close-port body-port) body)))) -(define (list-buckets cli) - (assoc-ref (api-call cli - http-post - "/b2api/v4/b2_list_buckets" - #:payload `(("accountId" . ,(account-id cli)))) - "buckets")) +(define* (list-buckets cli #:key bucket-id bucket-name bucket-types) + (let ((params `(("accountId" . ,(account-id cli))))) + (when bucket-id (set! params (assoc-set! params "bucketId" bucket-id))) + (when bucket-name (set! params (assoc-set! params "bucketName" bucket-name))) + (when bucket-types (set! params (assoc-set! params "bucketTypes" bucket-types))) + (assoc-ref (api-call cli + http-post + "/b2api/v4/b2_list_buckets" + #:payload params) + "buckets"))) + +(define (get-bucket-id cli bucket-name) + (let ((buckets (list-buckets cli #:bucket-name bucket-name))) + (when (zero? (vector-length buckets)) + (raise-exception (make-exception + (make-external-error) + (make-exception-with-message "Bucket not found") + (make-exception-with-irritants bucket-name)))) + (assoc-ref (vector-ref buckets 0) "bucketId"))) (define* (list-file-versions cli bucket-id #:key prefix delimiter start-file-name start-file-id max-file-count) (api-call cli http-get "/b2api/v4/b2_list_file_versions" @@ -148,13 +162,6 @@ #:start-file-id next-file-id #:max-file-count 10000)))))) -(define (resolve-bucket-id cli bucket-name) - (let ((bucket (find (lambda (b) (string=? bucket-name (assoc-ref b "bucketName"))) - (vector->list (list-buckets cli))))) - (if bucket - (assoc-ref bucket "bucketId") - #f))) - ;; Borrowed from guix/build/utils.scm (define (mkdir-p dir) "Create directory DIR and all its ancestors." @@ -211,9 +218,9 @@ been deleted. The 'start' and 'folder' actions are not of interest here. Backblaze creates a file called .bzEmpty in every directory. We never want to resore these empty files." (define (latest-before-cutoff files) - (find (lambda (f) - (< (assoc-ref f "uploadTimestamp") cutoff)) - files)) + (find (lambda (f) (< (assoc-ref f "uploadTimestamp") cutoff)) files)) + (define (bz-empty? f) + (string=? ".bzEmpty" (basename (assoc-ref f "fileName")))) (define (select-by-filename files result) (if (null? files) result @@ -224,24 +231,25 @@ resore these empty files." (if (and batch-latest (string=? "upload" (assoc-ref batch-latest "action"))) (select-by-filename remainder (cons batch-latest result)) (select-by-filename remainder result))))) - (select-by-filename (remove (lambda (f) (string=? ".bzEmpty" (assoc-ref f "fileName"))) files) '())) + (select-by-filename (remove bz-empty? files) '())) (define (restore cli files target-dir) - (for-each (lambda (f) - (download-file-by-id cli - (assoc-ref f "fileId") - (string-append target-dir "/" (assoc-ref f "fileName")))) - files)) + (n-par-for-each 4 (lambda (f) + (download-file-by-id cli + (assoc-ref f "fileId") + (string-append target-dir "/" (assoc-ref f "fileName")))) + files)) + +(define* (recover-at-point-in-time cli #:key bucket-name cutoff-time target-dir prefix) + (let* ((bucket-id (get-bucket-id cli bucket-name)) + (file-versions (list-all-file-versions cli bucket-id #:prefix prefix)) + (to-recover (select-for-recovery file-versions cutoff-time))) + (restore cli to-recover target-dir))) (define (main args) + ;; TODO: parse command-line args for bucket name, prefix, cutoff, and target dir. (define cli (make #:key-id (getenv "BB_KEY_ID") #:app-key (getenv "BB_APP_KEY"))) - - (define bucket-id (resolve-bucket-id cli "uk-org-1729-server-backups")) + (define bucket-name "uk-org-1729-backups") (define cutoff (* 1000 (time-second (date->time-utc (string->date "2025-06-01 00:00:00+0000" "~Y-~m-~d ~H:~M:~S~z"))))) - - (define file-versions (list-all-file-versions cli bucket-id)) - (define to-recover (select-for-recovery file-versions cutoff)) - (define target-dir "/home/ray/Downloads/uk-org-1729-server-backups") - - #f - ) + (define target-dir "/home/ray/Downloads/uk-org-1729-backups") + (recover-at-point-in-time cli #:bucket-name bucket-name #:cutoff-time cutoff #:target-dir target-dir))