Bug fixes, improvements, parallel download

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 "<binary response body>"))))
+         (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 <b2-client>))
   (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 <b2-client> #: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))