From patchwork Fri Jul 9 08:38:40 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Hartmut Goebel X-Patchwork-Id: 31250 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id F152027BC81; Fri, 9 Jul 2021 09:40:12 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 7451227BC78 for ; Fri, 9 Jul 2021 09:40:12 +0100 (BST) Received: from localhost ([::1]:35486 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1m1m3P-00023K-H2 for patchwork@mira.cbaines.net; Fri, 09 Jul 2021 04:40:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:41334) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1m1m3G-00020z-2t for guix-patches@gnu.org; Fri, 09 Jul 2021 04:40:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:46788) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1m1m3F-0006Rk-QT for guix-patches@gnu.org; Fri, 09 Jul 2021 04:40:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1m1m3F-0000jr-Os for guix-patches@gnu.org; Fri, 09 Jul 2021 04:40:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49482] [PATCH 3/3] ci: Properly construct URLs. Resent-From: Hartmut Goebel Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 09 Jul 2021 08:40:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49482 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44906@debbugs.gnu.org, 49482@debbugs.gnu.org X-Debbugs-Original-To: 44906@debbugs.gnu.org, guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.16258199452755 (code B ref -1); Fri, 09 Jul 2021 08:40:01 +0000 Received: (at submit) by debbugs.gnu.org; 9 Jul 2021 08:39:05 +0000 Received: from localhost ([127.0.0.1]:58334 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1m1m2L-0000iE-8h for submit@debbugs.gnu.org; Fri, 09 Jul 2021 04:39:05 -0400 Received: from lists.gnu.org ([209.51.188.17]:48658) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1m1m2G-0000gt-UZ for submit@debbugs.gnu.org; Fri, 09 Jul 2021 04:39:03 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:41002) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1m1m2G-0000Gf-N5 for guix-patches@gnu.org; Fri, 09 Jul 2021 04:39:00 -0400 Received: from mail-out.m-online.net ([2001:a60:0:28:0:1:25:1]:57570) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1m1m2D-0005qf-Vf for guix-patches@gnu.org; Fri, 09 Jul 2021 04:39:00 -0400 Received: from frontend01.mail.m-online.net (unknown [192.168.8.182]) by mail-out.m-online.net (Postfix) with ESMTP id 4GLmlz6lsXz1s8Nq; Fri, 9 Jul 2021 10:38:55 +0200 (CEST) Received: from localhost (dynscan1.mnet-online.de [192.168.6.70]) by mail.m-online.net (Postfix) with ESMTP id 4GLmlz3wjJz1qr4T; Fri, 9 Jul 2021 10:38:55 +0200 (CEST) X-Virus-Scanned: amavisd-new at mnet-online.de Received: from mail.mnet-online.de ([192.168.8.182]) by localhost (dynscan1.mail.m-online.net [192.168.6.70]) (amavisd-new, port 10024) with ESMTP id uTiNp5X4guTE; Fri, 9 Jul 2021 10:38:54 +0200 (CEST) Received: from hermia.goebel-consult.de (ppp-188-174-58-132.dynamic.mnet-online.de [188.174.58.132]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by mail.mnet-online.de (Postfix) with ESMTPS; Fri, 9 Jul 2021 10:38:54 +0200 (CEST) Received: from thisbe.goebel-consult.de (hermia.goebel-consult.de [192.168.110.7]) by hermia.goebel-consult.de (Postfix) with ESMTP id F1CB56022C; Fri, 9 Jul 2021 10:38:46 +0200 (CEST) From: Hartmut Goebel Date: Fri, 9 Jul 2021 10:38:40 +0200 Message-Id: X-Mailer: git-send-email 2.30.2 In-Reply-To: References: MIME-Version: 1.0 Received-SPF: none client-ip=2001:a60:0:28:0:1:25:1; envelope-from=h.goebel@crazy-compilers.com; helo=mail-out.m-online.net X-Spam_score_int: -25 X-Spam_score: -2.6 X-Spam_bar: -- X-Spam_report: (-2.6 / 5.0 requ) BAYES_00=-1.9, RCVD_IN_DNSWL_LOW=-0.7, SPF_HELO_NONE=0.001, SPF_NONE=0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches Implement a new function "api-url", which constructs URLs using relative URI and "resolve-uri-reference" (which implements the algorithm specified in RFC 3986 section 5.2.2) for building the URL, instead of just appending strings. This avoids issued if the server-url ends with a slash. Since "api-url" uses URI-objects, it makes sense to also construct the query-part of the URL here. For this "api-url" accepts optional key-value-pairs. New function "json-api-fetch" is a wrapper using "api-url". * guix/ci.scm (api-url): New function. (build): Use it. (json-api-fetch): New function. (queued-builds, latest-builds, evaluation, latest-evaluations, evaluation-jobs: Use it. --- guix/ci.scm | 79 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 33 deletions(-) diff --git a/guix/ci.scm b/guix/ci.scm index dde93bbd53..cf39744567 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -20,9 +20,12 @@ (define-module (guix ci) #:use-module (guix http-client) #:use-module (guix utils) + #:use-module ((guix build download) + #:select (resolve-uri-reference)) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (web uri) #:use-module (guix i18n) #:use-module (guix diagnostics) #:autoload (guix channels) (channel) @@ -146,16 +149,41 @@ ;; Max number of builds requested in queries. 1000) +(define* (api-url base-url path #:rest query) + "Build a proper API url, taking into account BASE_URL's trailing slashes." + + (define (build-query-string query) + (let lp ((query (or (reverse query) '())) (acc '())) + (match query + (() (string-concatenate acc)) + (((_ #f) . rest) (lp rest acc)) + (((name val) . rest) + (lp rest (cons* + name "=" + (if (string? val) (uri-encode val) (number->string val)) + (if (null? acc) "" "&") + acc)))))) + + (let* ((query-string (build-query-string query)) + (base (string->uri base-url)) + (ref (build-relative-ref #:path path #:query query-string))) + (resolve-uri-reference ref base))) + + (define (json-fetch url) (let* ((port (http-fetch url)) (json (json->scm port))) (close-port port) json)) +(define* (json-api-fetch base-url path #:rest query) + (json-fetch (apply api-url base-url path query))) + + (define* (queued-builds url #:optional (limit %query-limit)) "Return the list of queued derivations on URL." - (let ((queue (json-fetch (string-append url "/api/queue?nr=" - (number->string limit))))) + (let ((queue + (json-api-fetch url "/api/queue" `("nr" ,limit)))) (map json->build (vector->list queue)))) (define* (latest-builds url #:optional (limit %query-limit) @@ -163,28 +191,21 @@ "Return the latest builds performed by the CI server at URL. If EVALUATION is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system string such as \"x86_64-linux\"), restrict to builds for SYSTEM." - (define* (option name value #:optional (->string identity)) - (if value - (string-append "&" name "=" (->string value)) - "")) - - (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr=" - (number->string limit) - (option "evaluation" evaluation - number->string) - (option "system" system) - (option "job" job) - (option "status" status - number->string))))) + (let ((latest (json-api-fetch + url "/api/latestbuilds" + `("nr" ,limit) + `("evaluation" ,evaluation) + `("system" ,system) + `("job" ,job) + `("status" ,status)))) ;; Note: Hydra does not provide a "derivation" field for entries in ;; 'latestbuilds', but Cuirass does. (map json->build (vector->list latest)))) (define (evaluation url evaluation) "Return the given EVALUATION performed by the CI server at URL." - (let ((evaluation (json-fetch - (string-append url "/api/evaluation?id=" - (number->string evaluation))))) + (let ((evaluation + (json-api-fetch url "/api/evaluation" `("id" ,evaluation)))) (json->evaluation evaluation))) (define* (latest-evaluations url @@ -192,16 +213,10 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM." #:key spec) "Return the latest evaluations performed by the CI server at URL. If SPEC is passed, only consider the evaluations for the given SPEC specification." - (let ((spec (if spec - (format #f "&spec=~a" spec) - ""))) - (map json->evaluation - (vector->list - (json->scm - (http-fetch - (string-append url "/api/evaluations?nr=" - (number->string limit) - spec))))))) + (map json->evaluation + (vector->list + (json-api-fetch + url "/api/evaluations" `("nr" ,limit) `("spec" ,spec))))) (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) "Return the evaluations among the latest LIMIT evaluations that have COMMIT @@ -216,16 +231,14 @@ as one of their inputs." "Return the list of jobs of evaluation EVALUATION-ID." (map json->job (vector->list - (json->scm (http-fetch - (string-append url "/api/jobs?evaluation=" - (number->string evaluation-id))))))) + (json-api-fetch url "/api/jobs" `("evaluation" ,evaluation-id))))) (define (build url id) "Look up build ID at URL and return it. Raise &http-get-error if it is not found (404)." (json->build - (http-fetch (string-append url "/build/" ;note: no "/api" here - (number->string id))))) + (http-fetch (api-url url (string-append "/build/" ;note: no "/api" here + (number->string id)))))) (define (job-build url job) "Return the build associated with JOB."