---
Hi!
Here is a small library that exports 3 types:
â <patch-name-metadata> is the collection of metadata that is present
in the square brackets in the patch names;
â <patch> is an individual item of the patch series;
â <patch-series> is a whole series of patches;
And a set of functions to parse and serialize these.
A fun experiment is to run the following script:
(use-modules (guix-qa-frontpage patchwork patch-series))
(use-modules (rnrs bytevectors))
(use-modules (web client))
(use-modules (ice-9 receive))
(use-modules (json))
(define patchwork-data
(receive (r body)
(http-get
"https://patches.guix-patches.cbaines.net/api/patches/?order=-id";)
(json-string->scm (utf8->string body))))
(define patchwork-series
(map scm->patch-series (vector->list patchwork-data)))
(for-each
(lambda (correct-series)
(display correct-series)
(newline))
(map patch-series->scm patchwork-series))
You will see that patchwork has quite a lot of creativity when it
comes to breaking my expectations. I made sure to add as much
information in exceptions so that we can understand what is happening.
Best regards,
Vivien
Makefile.am | 3 +
guix-qa-frontpage/patchwork/patch-name.scm | 117 +++++++++++++
guix-qa-frontpage/patchwork/patch-series.scm | 165 +++++++++++++++++++
guix-qa-frontpage/patchwork/patch.scm | 93 +++++++++++
4 files changed, 378 insertions(+)
create mode 100644 guix-qa-frontpage/patchwork/patch-name.scm
create mode 100644 guix-qa-frontpage/patchwork/patch-series.scm
create mode 100644 guix-qa-frontpage/patchwork/patch.scm
diff --git a/Makefile.am b/Makefile.am
index 79b7032..7b00ea9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -32,6 +32,9 @@ SOURCES =
\
guix-qa-frontpage/server.scm
\
guix-qa-frontpage/database.scm
\
guix-qa-frontpage/patchwork.scm
\
+ guix-qa-frontpage/patchwork/patch-name.scm
\
+ guix-qa-frontpage/patchwork/patch.scm
\
+ guix-qa-frontpage/patchwork/patch-series.scm
\
guix-qa-frontpage/guix-data-service.scm
\
guix-qa-frontpage/branch.scm
\
guix-qa-frontpage/issue.scm
\
diff --git a/guix-qa-frontpage/patchwork/patch-name.scm
b/guix-qa-frontpage/patchwork/patch-name.scm
new file mode 100644
index 0000000..1b4cd97
--- /dev/null
+++ b/guix-qa-frontpage/patchwork/patch-name.scm
@@ -0,0 +1,117 @@
+(define-module (guix-qa-frontpage patchwork patch-name)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 exceptions)
+ #:export (<patch-name-metadata>
+ make-patch-name-metadata
+ patch-name-metadata?
+ patch-name-metadata-bug-number
+ patch-name-metadata-feature-branch
+ patch-name-metadata-revision
+ patch-name-metadata-index
+ patch-name-metadata-total
+ patch-name-metadata-set-index
+
+ &patch-name-parser-error
+ patch-name-parser-error?
+ make-patch-name-parser-error
+
+ parse-patch-name
+ synthesize-patch-name
+ ))
+
+(define-record-type <patch-name-metadata>
+ (make-patch-name-metadata bug-number feature-branch revision index total)
+ patch-name-metadata?
+ (bug-number patch-name-metadata-bug-number)
+ (feature-branch patch-name-metadata-feature-branch)
+ (revision patch-name-metadata-revision)
+ (index patch-name-metadata-index)
+ (total patch-name-metadata-total))
+
+(define (patch-name-metadata-set-index meta index)
+ (match meta
+ (($ <patch-name-metadata> bug branch rev _ total)
+ (make-patch-name-metadata bug branch rev index total))))
+
+(set-record-type-printer!
+ <patch-name-metadata>
+ (lambda (record port)
+ (match record
+ (($ <patch-name-metadata> bug feature revision index total)
+ (format port
+ "#<<patch-name-metadata> \
+bug-number=~s feature-branch=~s revision=~s \
+index=~s total=~s>"
+ bug feature revision index total)))))
+
+(define-exception-type &patch-name-parser-error
+ &error
+ make-patch-name-parser-error
+ patch-name-parser-error?)
+
+(define (parse-patch-name name)
+ "Given a patch @var{name} obtained from Patchwork, infer the metadata
+from its name."
+ (define (raise-error message)
+ (raise-exception
+ (make-exception
+ (make-error)
+ (make-patch-name-parser-error)
+ (make-exception-with-message message)
+ (make-exception-with-irritants (list name))
+ (make-exception-with-origin 'parse-patch-name))))
+ (define (as-bug-number arg)
+ (and (string-prefix? "bug#" arg)
+ (string->number (substring arg (string-length "bug#")))))
+ (define (as-revision arg)
+ (and (string-prefix? "v" arg)
+ (string->number (substring arg 1))))
+ (define (as-patch-number arg)
+ (match (string-split arg #\/)
+ (((= string->number index) (= string->number total))
+ (and index total (<= index total)
+ (cons index total)))
+ (else #f)))
+ (unless (string-prefix? "[" name)
+ (raise-error "the patch name does not start with '['"))
+ (let ((stop (string-index name #\])))
+ (unless stop
+ (raise-error "the patch name does not contain ']'"))
+ (let ((args (substring name 1 stop)))
+ (let analyze ((bug-number #f)
+ (branch "master")
+ (revision 1)
+ (index 1)
+ (total 1)
+ (arguments
+ (string-split args #\,)))
+ (match arguments
+ ((or ("") ())
+ (begin
+ (unless bug-number
+ (raise-error "the patch name does not have a bug number"))
+ (make-patch-name-metadata bug-number branch revision index total)))
+ (((= as-bug-number (? number? new-bug-number))
+ arguments ...)
+ (analyze new-bug-number branch revision index total arguments))
+ (((= as-revision (? number? new-revision))
+ arguments ...)
+ (analyze bug-number branch new-revision index total arguments))
+ (((= as-patch-number ((? number? new-index) . (? number? new-total)))
+ arguments ...)
+ (analyze bug-number branch revision new-index new-total arguments))
+ ((feature-branch arguments ...)
+ (analyze bug-number feature-branch revision index total
arguments)))))))
+
+
+(define (synthesize-patch-name meta name)
+ "Prepend @samp{[bug#nnn,branch,v1,1/1]} to the @var{name}."
+ (match meta
+ (($ <patch-name-metadata>
+ bug-number feature-branch revision
+ index total)
+ (format #f "[bug#~a,~a,v~a,~a/~a] ~a"
+ bug-number feature-branch revision
+ index total name))))
diff --git a/guix-qa-frontpage/patchwork/patch-series.scm
b/guix-qa-frontpage/patchwork/patch-series.scm
new file mode 100644
index 0000000..20e2c61
--- /dev/null
+++ b/guix-qa-frontpage/patchwork/patch-series.scm
@@ -0,0 +1,165 @@
+(define-module (guix-qa-frontpage patchwork patch-series)
+ #:use-module (guix-qa-frontpage patchwork patch-name)
+ #:use-module (guix-qa-frontpage patchwork patch)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 exceptions)
+ #:use-module (ice-9 match)
+ #:export (<patch-series>
+ patch-series?
+ make-patch-series
+ patch-series-id
+ patch-series-bug-number
+ patch-series-feature-branch
+ patch-series-revision
+ patch-series-patches
+
+ &invalid-patch-series-json
+ invalid-patch-series-json?
+ make-invalid-patch-series-json
+
+ scm->patch-series
+ patch-series->scm))
+
+(define-record-type <patch-series>
+ (make-patch-series id bug-number feature-branch revision patches)
+ patch-series?
+ (id patch-series-id)
+ (bug-number patch-series-bug-number)
+ (feature-branch patch-series-feature-branch)
+ (revision patch-series-revision)
+ (patches patch-series-patches))
+
+(define-exception-type &invalid-patch-series-json
+ &error
+ make-invalid-patch-series-json
+ invalid-patch-series-json?)
+
+(define (scm->patch-series json-data)
+ "Parse a full patch series from JSON data."
+ (let ((json-patches (assoc-ref json-data "series"))
+ (id (assoc-ref json-data "id")))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-invalid-patch-series-json)
+ (make-exception-with-message
+ "while converting JSON data to a patch series")
+ (make-exception-with-origin 'scm->patch-series)
+ (make-exception-with-irritants (list json-data))
+ exn)))
+ (lambda ()
+ (unless (and (integer? id) (>= id 0))
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ "no \"id\" key in the object, or not an integer")
+ (make-exception-with-irritants
+ (list id)))))
+ (unless json-patches
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ "no \"series\" key in the object"))))
+ (unless (vector? json-patches)
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ "series is not an array")
+ (make-exception-with-irritants json-patches))))
+ (set! json-patches (vector->list json-patches))
+ (when (null? json-patches)
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ "the series has no patches"))))
+ (let ((global-metadata
+ ;; There are 2 places where the metadata could be: in
+ ;; the "name" key of the root object, or in the "name"
+ ;; key of any patch.
+ (or
+ (false-if-exception
+ (parse-patch-name (assoc-ref json-data "name")))
+ (parse-patch-name
+ (assoc-ref (car json-patches) "name")))))
+ (let check-patches ((patches json-patches)
+ (n-checked 0)
+ (checked '()))
+ (match patches
+ (()
+ (begin
+ (unless (eqv? n-checked (patch-name-metadata-total
global-metadata))
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ (format #f "wrong number of patches in series, expected
~s"
+ (patch-name-metadata-total global-metadata)))
+ (make-exception-with-irritants
+ (list n-checked)))))
+ (make-patch-series id
+ (patch-name-metadata-bug-number
global-metadata)
+ (patch-name-metadata-feature-branch
global-metadata)
+ (patch-name-metadata-revision
global-metadata)
+ (reverse checked))))
+ ((next patches ...)
+ (let ((parsed
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ (format #f "while parsing patch ~s/~s"
+ (1+ n-checked)
+ (patch-name-metadata-total
global-metadata)))
+ exn)))
+ (lambda ()
+ (let* ((expected-meta
+ (patch-name-metadata-set-index
+ global-metadata
+ (1+ n-checked)))
+ (p
+ ;; Parse the patch, but if it fails,
+ ;; try with a synthetic name that
+ ;; adds the relevant information.
+ (with-exception-handler
+ (lambda (no-metadata)
+ (unless (patch-name-parser-error?
no-metadata)
+ (raise-exception no-metadata))
+ (let ((incorrect-name
+ (assoc-ref next "name")))
+ (scm->patch
+ `(("name" .
+ ,(synthesize-patch-name
+ expected-meta
+ incorrect-name))
+ ,@next))))
+ (lambda ()
+ (scm->patch next))
+ #:unwind? #t
+ #:unwind-for-type
&patch-name-parser-error))
+ (meta
+ (patch-name-metadata p))
+ (expected-meta
+ (patch-name-metadata-set-index
+ global-metadata
+ (1+ n-checked))))
+ (unless (equal? expected-meta meta)
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ (format #f "the patch has inconsistent
metadata: expected ~s"
+ expected-meta))
+ (make-exception-with-irritants
+ (list meta)))))
+ (unless meta
+ (set! p (patch-set-name-metadata p
expected-meta)))
+ p)))))
+ (check-patches patches (1+ n-checked) `(,parsed
,@checked)))))))))))
+
+(define (patch-series->scm series)
+ "Convert a series back to a JSON sexp, so that it can be cached in
+ database."
+ `(("id" . ,(patch-series-id series))
+ ("series" . ,(list->vector
+ (map patch->scm (patch-series-patches series))))))
diff --git a/guix-qa-frontpage/patchwork/patch.scm
b/guix-qa-frontpage/patchwork/patch.scm
new file mode 100644
index 0000000..0209476
--- /dev/null
+++ b/guix-qa-frontpage/patchwork/patch.scm
@@ -0,0 +1,93 @@
+(define-module (guix-qa-frontpage patchwork patch)
+ #:use-module (guix-qa-frontpage patchwork patch-name)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 exceptions)
+ #:use-module (ice-9 match)
+ #:use-module (web uri)
+ #:export (<patch>
+ patch?
+ make-patch
+ patch-index
+ patch-name
+ patch-mbox
+ patch-set-name
+ patch-name-metadata
+ patch-set-name-metadata
+
+ &invalid-patch-json
+ invalid-patch-json?
+ make-invalid-patch-json
+
+ scm->patch
+ patch->scm))
+
+(define-record-type <patch>
+ (make-patch id index name mbox)
+ patch?
+ (id patch-id)
+ (index patch-index)
+ (name patch-name)
+ (mbox patch-mbox))
+
+(define (patch-set-name patch new-name)
+ (match patch
+ (($ <patch> id index _ mbox)
+ (make-patch id index new-name mbox))))
+
+(define (patch-set-name-metadata patch meta)
+ "Synthesize a new patch name with all the relevant information."
+ (patch-set-name
+ patch
+ (synthesize-patch-name meta (patch-name patch))))
+
+(define-exception-type &invalid-patch-json
+ &error
+ make-invalid-patch-json
+ invalid-patch-json?)
+
+(define (patch-name-metadata patch)
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-exception-with-message
+ "while parsing patch name metadata")
+ (make-exception-with-origin 'patch-name-metadata)
+ (make-exception-with-irritants (list patch))
+ exn)))
+ (lambda ()
+ (parse-patch-name (patch-name patch)))))
+
+(define (scm->patch json-data)
+ "Get a patch series item from patchwork as JSON."
+ (let ((id (assoc-ref json-data "id"))
+ (name (assoc-ref json-data "name"))
+ (mbox (assoc-ref json-data "mbox")))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-invalid-patch-json)
+ (make-exception-with-message "while converting JSON data to a
patch")
+ (make-exception-with-origin 'scm->patch)
+ (make-exception-with-irritants (list json-data))
+ exn)))
+ (lambda ()
+ (unless (and (integer? id) (>= id 0))
+ (error "the patch does not have an ID or it is not an integer"))
+ (unless (string? name)
+ (error "the patch name is missing or not a string"))
+ (unless (and (string? mbox) (string->uri mbox))
+ (error "the patch mbox is not an URI"))
+ (let ((metadata (parse-patch-name name)))
+ (make-patch id
+ (patch-name-metadata-index metadata)
+ name
+ (string->uri mbox)))))))
+
+(define (patch->scm patch)
+ "Convert a patch back to a JSON sexp, so that it can be cached in
+ database."
+ `(("id" . ,(patch-id patch))
+ ("name" . ,(patch-name patch))
+ ("mbox" . ,(uri->string (patch-mbox patch)))))
base-commit: 96e85c3ff9dbc55bcabeceff6ef45c54151ce7b3
--
2.41.0
