diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/lint.scm | 78 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 61 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 1 |
3 files changed, 92 insertions, 48 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index fc61f0b547..a26f92f49c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -414,8 +414,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (close-connection port)))) (case (response-code response) - ((301 ; moved permanently - 302 ; found (redirection) + ((302 ; found (redirection) 303 ; see other 307 ; temporary redirection 308) ; permanent redirection @@ -423,6 +422,22 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (if (or (not location) (member location visited)) (values 'http-response response) (loop location (cons location visited))))) ;follow the redirect + ((301) ; moved permanently + (let ((location (response-location response))) + ;; Return RESPONSE, unless the final response as we follow + ;; redirects is not 200. + (if location + (let-values (((status response2) + (loop location (cons location visited)))) + (case status + ((http-response) + (values 'http-response + (if (= 200 (response-code response2)) + response + response2))) + (else + (values status response2)))) + (values 'http-response response)))) ;invalid redirect (else (values 'http-response response))))) (lambda (key . args) @@ -474,31 +489,46 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (if (= 200 (response-code argument)) - (match (response-content-length argument) - ((? number? length) - ;; As of July 2016, SourceForge returns 200 (instead of 404) - ;; with a small HTML page upon failure. Attempt to detect such - ;; malicious behavior. - (or (> length 1000) + (cond ((= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect + ;; such malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (G_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t))) + ((= 301 (response-code argument)) + (if (response-location argument) (begin (emit-warning package - (format #f - (G_ "URI ~a returned \ -suspiciously small file (~a bytes)") + (format #f (G_ "permanent redirect from ~a to ~a") (uri->string uri) - length)) + (uri->string + (response-location argument)))) + #t) + (begin + (emit-warning package + (format #f (G_ "invalid permanent redirect \ +from ~a") + (uri->string uri))) #f))) - (_ #t)) - (begin - (emit-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - field) - #f))) + (else + (emit-warning package + (format #f + (G_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field) + #f))) ((ftp-response) (match argument (('ok) #t) @@ -534,7 +564,7 @@ suspiciously small file (~a bytes)") ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. #f) - ((unknown-protocol) ;nothing we can do + ((unknown-protocol) ;nothing we can do #f) (else (error "internal linter error" status))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index d3cb64d604..6a2485a007 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -428,6 +428,23 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Return the name of the file used as a lock when choosing a build machine." (string-append %state-directory "/offload/machine-choice.lock")) +(define (random-seed) + (logxor (getpid) (car (gettimeofday)))) + +(define shuffle + (let ((state (seed->random-state (random-seed)))) + (lambda (lst) + "Return LST shuffled (using the Fisher-Yates algorithm.)" + (define vec (list->vector lst)) + (let loop ((result '()) + (i (vector-length vec))) + (if (zero? i) + result + (let* ((j (random i state)) + (val (vector-ref vec j))) + (vector-set! vec j (vector-ref vec (- i 1))) + (loop (cons val result) (- i 1)))))))) + (define (choose-build-machine machines) "Return two values: the best machine among MACHINES and its build slot (which must later be released with 'release-build-slot'), or #f and #f." @@ -441,39 +458,35 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots+loads + (define machines+slots (filter-map (lambda (machine) - ;; Call 'machine-load' from here to make sure it is called - ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot - (list machine slot (machine-load machine))))) - machines)) + (and slot (list machine slot)))) + (shuffle machines))) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1 load1) + ((machine1 slot1) (match b - ((machine2 slot2 load2) - (pred machine1 load1 machine2 load2))))))) - - (define (machine-less-loaded-or-faster? m1 l1 m2 l2) - ;; Return #t if M1 is either less loaded or faster than M2, with L1 - ;; being the load of M1 and L2 the load of M2. (This relation defines a - ;; total order on machines.) - (> (/ (build-machine-speed m1) (+ 1 l1)) - (/ (build-machine-speed m2) (+ 1 l2)))) - - (let loop ((machines+slots+loads - (sort machines+slots+loads - (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots+loads - (((best slot load) others ...) + ((machine2 slot2) + (pred machine1 machine2))))))) + + (define (machine-faster? m1 m2) + ;; Return #t if M1 is faster than M2. + (> (build-machine-speed m1) + (build-machine-speed m2))) + + (let loop ((machines+slots + (sort machines+slots (undecorate machine-faster?)))) + (match machines+slots + (((best slot) others ...) ;; Return the best machine unless it's already overloaded. - (if (< load 2.) + ;; Note: We call 'machine-load' only as a last resort because it is + ;; too costly to call it once for every machine. + (if (< (machine-load best) 2.) (match others - (((machines slots loads) ...) + (((machines slots) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 3dcf42d0d1..921a7c6790 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -962,6 +962,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) (close-port input) + (close-port progress) ;; Skip a line after what 'progress-reporter/file' printed, and another ;; one to visually separate substitutions. |