diff --git a/guile/b2-pitr.scm b/guile/b2-pitr.scm old mode 100644 new mode 100755 index 56950d8..7833e5d --- a/guile/b2-pitr.scm +++ b/guile/b2-pitr.scm @@ -8,17 +8,45 @@ (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) (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 +60,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 +72,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 +97,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 @@ -113,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" @@ -146,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." @@ -209,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 @@ -222,23 +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))