ray/scripts
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve exception handling

Browse source
This commit is contained in:
Ray Miller 2025-06-15 11:56:08 +01:00
parent b61996f393
commit e0d897ec8d
1 changed files with 33 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

63
guile/b2-pitr.scm
View file

@ -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 "<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 +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 <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
@ -233,6 +235,7 @@ resore these empty files."
(define (main args)
(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 cutoff (* 1000 (time-second (date->time-utc (string->date "2025-06-01 00:00:00+0000" "~Y-~m-~d ~H:~M:~S~z")))))