diff --git a/guile/b2-pitr.scm b/guile/b2-pitr.scm old mode 100755 new mode 100644 index 7833e5d..56950d8 --- a/guile/b2-pitr.scm +++ b/guile/b2-pitr.scm @@ -8,45 +8,17 @@ (ice-9 exceptions) ((ice-9 iconv) #:select (string->bytevector)) (ice-9 match) - (ice-9 threads) (json) (oop goops) - (srfi srfi-1) ;; lists - (srfi srfi-19) ;; date/time - (srfi srfi-26) ;; cut - (srfi srfi-71) ;; extended let + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26) + (srfi srfi-71) (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) @@ -60,6 +32,15 @@ "" 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 @@ -72,7 +53,11 @@ (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))) - (check-api-response "/b2api/v4/b2_authorize_account" res body (and (= 200 (response-code res)) (json-response? res))) + (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)))) (json->scm body))) (define (assoc-ref* alist . keys) @@ -97,16 +82,28 @@ (define-method (account-id (cli )) (assoc-ref (b2-auth-info cli) "accountId")) -(define* (api-call cli method endpoint #:key query-params payload raw?) +(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?) (let* ((url (if query-params - (string-append (api-url cli) endpoint "?" (encode-query query-params)) - (string-append (api-url cli) endpoint))) + (string-append (api-url cli) path "?" (encode-query query-params)) + (string-append (api-url cli) path))) (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 endpoint res body-port) + (check-api-response res body-port (string-append "Error from " path)) (if raw? body-port (let ((body (cond @@ -116,25 +113,12 @@ (close-port body-port) body)))) -(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-buckets cli) + (assoc-ref (api-call cli + http-post + "/b2api/v4/b2_list_buckets" + #:payload `(("accountId" . ,(account-id cli)))) + "buckets")) (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" @@ -162,6 +146,13 @@ #: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." @@ -218,9 +209,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)) - (define (bz-empty? f) - (string=? ".bzEmpty" (basename (assoc-ref f "fileName")))) + (find (lambda (f) + (< (assoc-ref f "uploadTimestamp") cutoff)) + files)) (define (select-by-filename files result) (if (null? files) result @@ -231,25 +222,23 @@ 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 bz-empty? files) '())) + (select-by-filename (remove (lambda (f) (string=? ".bzEmpty" (assoc-ref f "fileName"))) files) '())) (define (restore cli files target-dir) - (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))) + (for-each (lambda (f) + (download-file-by-id cli + (assoc-ref f "fileId") + (string-append target-dir "/" (assoc-ref f "fileName")))) + files)) (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-name "uk-org-1729-backups") + (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"))))) - (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)) + + (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 + )