;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix http-client)
  #:use-module (web uri)
  #</td></tr></table>
<table class='tabs'><tr><td>
<a class='active' href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=e7b8edc74490ebd345ca3b518418a59d1d00abe2'>refs</a><a href='/guix/log/'>log</a><a href='/guix/tree/?id=e7b8edc74490ebd345ca3b518418a59d1d00abe2'>tree</a><a href='/guix/commit/?id=e7b8edc74490ebd345ca3b518418a59d1d00abe2'>commit</a><a href='/guix/diff/?id=e7b8edc74490ebd345ca3b518418a59d1d00abe2'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/'>
<input type='hidden' name='id' value='e7b8edc74490ebd345ca3b518418a59d1d00abe2'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='content'><div id='summary'><pre>
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze &lt;zerodaysfordays@sdf.org&gt;
;;; Copyright © 2020 Danny Milosavljevic &lt;dannym@scratchpost.org&gt;
;;; Copyright © 2020, 2021 Brice Waegeneire &lt;brice@waegenei.re&gt;
;;; Copyright © 2021 raid5atemyhomework &lt;raid5atemyhomework@protonmail.com&gt;
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see &lt;http://www.gnu.org/licenses/&gt;.

(define-module (gnu tests linux-modules)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services linux)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:export (%test-loadable-kernel-modules-0
            %test-loadable-kernel-modules-1
            %test-loadable-kernel-modules-2
            %test-loadable-kernel-modules-service-0
            %test-loadable-kernel-modules-service-1
            %test-loadable-kernel-modules-service-2))

;;; Commentary:
;;;
;;; Test &lt;operating-system&gt; kernel-loadable-modules.
;;;
;;; Code:

(define* (modules-loaded?-program os modules)
  &quot;Return an executable store item that, upon being evaluated, will verify
that MODULES are actually loaded.&quot;
  (program-file
   &quot;verify-kernel-modules-loaded.scm&quot;
   #~(begin
     (use-modules (ice-9 rdelim)
                  (ice-9 popen)
                  (srfi srfi-1)
                  (srfi srfi-13))
     (let* ((port (open-input-pipe (string-append #$kmod &quot;/bin/lsmod&quot;)))
            (lines (string-split (read-string port) #\newline))
            (separators (char-set #\space #\tab))
            (modules (map (lambda (line)
                            (string-take line
                                         (or (string-index line separators)
                                             0)))
                          lines))
            (status (close-pipe port)))
       (and (= status 0)
            (and-map (lambda (module)
                       (member module modules string=?))
                     &apos;#$modules))))))

(define* (run-loadable-kernel-modules-test-base base-os module-names)
  &quot;Run a test of BASE-OS, verifying that MODULE-NAMES are loaded in memory.&quot;
  (define os
    (marionette-operating-system
     base-os
     #:imported-modules &apos;((guix combinators))))

  (define vm (virtual-machine os))

  (define (test script)
    (with-imported-modules &apos;((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64))

          (define marionette
            (make-marionette (list #$vm)))

          (test-runner-current (system-test-runner #$output))
          (test-begin &quot;loadable-kernel-modules&quot;)
          (test-assert &quot;script successfully evaluated&quot;
            (marionette-eval
             &apos;(primitive-load #$script)
             marionette))
          (test-end))))

  (gexp-&gt;derivation &quot;loadable-kernel-modules&quot;
                    (test (modules-loaded?-program os module-names))))

(define* (run-loadable-kernel-modules-test module-packages module-names)
  &quot;Run a test of an OS having MODULE-PACKAGES, and verify that MODULE-NAMES
are loaded in memory.&quot;
  (run-loadable-kernel-modules-test-base
    (operating-system
      (inherit (simple-operating-system))
      (services (cons (service kernel-module-loader-service-type module-names)
                      (operating-system-user-services
                       (simple-operating-system))))
      (kernel-loadable-modules module-packages))
    module-names))

(define* (run-loadable-kernel-modules-service-test module-packages module-names)
  &quot;Run a test of an OS having MODULE-PACKAGES, which are loaded by creating a
service that extends LINUXL-LOADABLE-MODULE-SERVICE-TYPE. Then verify that
MODULE-NAMES are loaded in memory.&quot;
  (run-loadable-kernel-modules-test-base
    (operating-system
      (inherit (simple-operating-system))
      (services (cons* (simple-service &apos;installing-module
                                       linux-loadable-module-service-type
                                       module-packages)
                       (service kernel-module-loader-service-type module-names)
                       (operating-system-user-services
                        (simple-operating-system)))))
    module-names))

(define %test-loadable-kernel-modules-0
  (system-test
   (name &quot;loadable-kernel-modules-0&quot;)
   (description &quot;Tests loadable kernel modules facility of &lt;operating-system&gt;
with no extra modules.&quot;)
   (value (run-loadable-kernel-modules-test &apos;() &apos;()))))

(define %test-loadable-kernel-modules-1
  (system-test
   (name &quot;loadable-kernel-modules-1&quot;)
   (description &quot;Tests loadable kernel modules facility of &lt;operating-system&gt;
with one extra module.&quot;)
   (value (run-loadable-kernel-modules-test
           (list ddcci-driver-linux)
           &apos;(&quot;ddcci&quot;)))))

(define %test-loadable-kernel-modules-2
  (system-test
   (name &quot;loadable-kernel-modules-2&quot;)
   (description &quot;Tests loadable kernel modules facility of &lt;operating-system&gt;
with two extra modules.&quot;)
   (value (run-loadable-kernel-modules-test
           (list acpi-call-linux-module
                 (package
                   (inherit ddcci-driver-linux)
                   (arguments
                    `(#:linux #f
                      ,@(strip-keyword-arguments &apos;(#:linux)
                                                 (package-arguments
                                                  ddcci-driver-linux))))))
           &apos;(&quot;acpi_call&quot; &quot;ddcci&quot;)))))

(define %test-loadable-kernel-modules-service-0
  (system-test
   (name &quot;loadable-kernel-modules-service-0&quot;)
   (description &quot;Tests loadable kernel modules extensible service with no
extra modules.&quot;)
   (value (run-loadable-kernel-modules-service-test &apos;() &apos;()))))

(define %test-loadable-kernel-modules-service-1
  (system-test
   (name &quot;loadable-kernel-modules-service-1&quot;)
   (description &quot;Tests loadable kernel modules extensible service with one
extra module.&quot;)
   (value (run-loadable-kernel-modules-service-test
           (list ddcci-driver-linux)
           &apos;(&quot;ddcci&quot;)))))

(define %test-loadable-kernel-modules-service-2
  (system-test
   (name &quot;loadable-kernel-modules-service-2&quot;)
   (description &quot;Tests loadable kernel modules extensible service with two
extra modules.&quot;)
   (value (run-loadable-kernel-modules-service-test
           (list acpi-call-linux-module
                 (package
                   (inherit ddcci-driver-linux)
                   (arguments
                    `(#:linux #f
                      ,@(strip-keyword-arguments &apos;(#:linux)
                                                 (package-arguments
                                                  ddcci-driver-linux))))))
           &apos;(&quot;acpi_call&quot; &quot;ddcci&quot;)))))
</pre>
</div></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
     (string->utf8 str))))
                            headers))
                     (_ headers))))
      (unless (or buffered? (not (file-port? port)))
        (setvbuf port _IONBF))
      (let*-values (((resp data)
                     (http-get uri #:streaming? #t #:port port
                               #:keep-alive? #t
                               #:headers headers))
                    ((code)
                     (response-code resp)))
        (case code
          ((200)
           (values data (response-content-length resp)))
          ((301                                   ; moved permanently
            302)                                  ; found (redirection)
           (let ((uri (resolve-uri-reference (response-location resp) uri)))
             (close-port port)
             (format #t (G_ "following redirection to `~a'...~%")
                     (uri->string uri))
             (loop uri)))
          (else
           (raise (condition (&http-get-error
                              (uri uri)
                              (code code)
                              (reason (response-reason-phrase resp)))
                             (&message
                              (message
                               (format
                                #f
                                (G_ "~a: HTTP download failed: ~a (~s)")
                                (uri->string uri) code
                                (response-reason-phrase resp))))))))))))


;;;
;;; Caching.
;;;

(define %http-cache-ttl
  ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
  (make-parameter
   (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
                      string->number*)
               36))))

(define (cache-file-for-uri uri)
  "Return the name of the file in the cache corresponding to URI."
  (let ((digest (sha256 (string->utf8 (uri->string uri)))))
    ;; Use the "URL" alphabet because it does not contain "/".
    (string-append (cache-directory) "/http/"
                   (base64-encode digest 0 (bytevector-length digest)
                                  #f #f base64url-alphabet))))

(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?)
  "Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix.  The cache remains valid for TTL seconds."
  (let ((file (cache-file-for-uri uri)))
    (define (update-cache)
      ;; Update the cache and return an input port.
      (let ((port (http-fetch uri #:text? text?)))
        (mkdir-p (dirname file))
        (with-atomic-file-output file
          (cut dump-port port <>))
        (close-port port)
        (open-input-file file)))

    (define (old? port)
      ;; Return true if PORT has passed TTL.
      (let* ((s   (stat port))
             (now (current-time time-utc)))
        (< (+ (stat:mtime s) ttl) (time-second now))))

    (catch 'system-error
      (lambda ()
        (let ((port (open-input-file file)))
          (if (old? port)
              (begin
                (close-port port)
                (update-cache))
              port)))
      (lambda args
        (if (= ENOENT (system-error-errno args))
            (update-cache)
            (apply throw args))))))

;;; http-client.scm ends here