;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019-2023 Ludovic Courtès ;;; Copyright © 2020 Björn Höfling ;;; Copyright © 2022 Maxim Cournoyer ;;; ;;; 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 . ;; This file contains machinery to build HTML and PDF copies of
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>.
;;;
;;; 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 (gnu tests vnstat)
  #:use-module (gnu tests)
  #:use-module ((gnu packages networking) #:select (socat vnstat))
  #:use-module (gnu services)
  #:use-module (gnu services networking)
  #:use-module (gnu services monitoring)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (guix gexp)
  #:use-module (ice-9 format)
  #:export (%test-vnstat))


(define (run-vnstat-test)
  "Run tests in a vm which has vnstat running."

  (define vnstat-config
    (vnstat-configuration
     (max-bandwidth 0)
     (time-sync-wait 0)
     (bandwidth-detection-interval 0)))

  (define inetd-service-entry-config
    (inetd-entry
     (name "discard")
     (socket-type 'stream)
     (protocol "tcp")
     (wait? #t)
     (user "nobody")))

  (define os
    (marionette-operating-system
     (simple-operating-system
      (service dhcp-client-service-type)
      (service vnstat-service-type
               vnstat-config)
      (service inetd-service-type
               (inetd-configuration
                (entries
                 (list inetd-service-entry-config)))))
     #:imported-modules '((gnu services herd))))

  (define forwarded-port 9999)

  (define vm
    ;; The 'discard' port is 9.  Avoid using 'getservbyname' as that might
    ;; fail depending on what /etc/services has (if it's available).
    (let ((guest-port 9))
      (virtual-machine
       (operating-system os)
       (port-forwardings `((,forwarded-port . ,guest-port))))))

  ;; The test duration is inconsistent, at times a test may complete under
  ;; 2 minutes and at times it may take up to 5 minutes.
  (define test-timeout (* 60 5))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64))

          (let ((marionette (make-marionette (list #$vm)))
                (pid-file #$(vnstat-configuration-pid-file vnstat-config)))

            (test-runner-current (system-test-runner #$output))
            (test-begin "vnstat")

            (test-assert "service is running"
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'vnstatd))
               marionette))

            (test-assert "vnstatd ready"
              (wait-for-file pid-file marionette))

            ;; Pump garbage into the 'discard' inetd service within the vm.
            (let* ((socat #$(file-append socat "/bin/socat"))
                   (dest-addr #$(format #f "TCP4:localhost:~d"
                                        forwarded-port))
                   (args `("socat" "-u" "/dev/zero" ,dest-addr))
                   ;; XXX: Guile bug (22/03/2023, Guile 3.0.9)
                   ;; Fixed in main: <https://issues.guix.gnu.org/61073>
                   ;; FIXME: re-add #:output (%make-void-port "w") below on
                   ;; next Guile release.
                   (garbage-pump-pid
                    (spawn socat args)))
              (test-group-with-cleanup "Logging"
                ;; To aid debugging, this test returns #t on success
                ;; and either #f or 'timed-out otherwise.
                (test-eq "vnstatd is logging"
                  #t
                  (marionette-eval
                   '(begin
                      (use-modules (ice-9 popen)
                                   (ice-9 match)
                                   (sxml simple)
                                   (sxml xpath))

                      (define selector
                        (let ((xpath '(vnstat interface traffic total)))
                          (compose (node-pos 1) (sxpath xpath))))

                      (let loop ((i 0))
                        (let* ((vnstat #$(file-append vnstat "/bin/vnstat"))
                               (query-cmd (format #f "~a --xml" vnstat))
                               (proc (compose selector xml->sxml))
                               (result
                                (call-with-port
                                    (open-input-pipe query-cmd) proc)))
                          (match result
                            ;; Counter still warming up.
                            ((('total ('rx "0") ('tx "0")))
                             (sleep 1)
                             (if (< i #$test-timeout)
                                 (loop (+ i 1))
                                 'timed-out))
                            ;; Count of bytes on iface was non-zero.
                            ((('total ('rx rx) ('tx tx)))
                             #t)
                            ;; Unknown data encountered, perhaps the
                            ;; data format changed?
                            (_ #f)))))
                   marionette))
                ;; Cleanup: shutdown garbage pump.
                (kill garbage-pump-pid SIGTERM)))

            (test-end)))))

  (gexp->derivation "vnstat-test" test))

(define %test-vnstat
  (system-test
   (name "vnstat")
   (description "Basic tests for vnstat service.")
   (value (run-vnstat-test))))
"/" file)))))) (define (underscore-decode str) ;; Decode STR, an "underscore-encoded" string as produced by ;; makeinfo for indexes, such as "_0025base_002dservices" for ;; "%base-services". (let loop ((str str) (result '())) (match (string-index str #\_) (#f (string-concatenate-reverse (cons str result))) (index (let ((char (string->number (substring str (+ index 1) (+ index 5)) 16))) (loop (string-drop str (+ index 5)) (append (list (string (integer->char char)) (string-take str index)) result))))))) (define (anchor-id->key id) ;; Convert ID, an anchor ID such as ;; "index-pam_002dlimits_002dservice" to the corresponding key, ;; "pam-limits-service" in this example. Drop the suffix of ;; duplicate anchor IDs like "operating_002dsystem-1". (let ((id (if (any (cut string-suffix? <> id) '("-1" "-2" "-3" "-4" "-5")) (string-drop-right id 2) id))) (underscore-decode (string-drop id (string-length "index-"))))) (define* (collect-anchors file #:optional (anchors '())) ;; Collect the anchors that appear in FILE, a makeinfo-generated ;; file. Grab those from
tags, which corresponds to ;; Texinfo @deftp, @defvr, etc. Return ANCHORS augmented with ;; more name/reference pairs. (define string-or-entity? (match-lambda ((? string?) #t) (('*ENTITY* _ ...) #t) (_ #f))) (define (worthy-entry? lst) ;; Attempt to match: ;; Scheme Variable: x ;; but not: ;; cups-configuration parameter: … (let loop ((lst lst)) (match lst (((? string-or-entity?) rest ...) (loop rest)) ((('strong _ ...) _ ...) #t) ((('span ('@ ('class "category")) ;raw Texinfo 6.8 (? string-or-entity?) ...) rest ...) #t) ((('span ('@ ('class "symbol-definition-category")) (? string-or-entity?) ...) rest ...) #t) (x #f)))) (let ((shtml (call-with-input-file file html->shtml))) (let loop ((shtml shtml) (anchors anchors)) (match shtml (('dt ('@ ('id id) _ ...) rest ...) (if (and (string-prefix? "index-" id) (worthy-entry? rest)) (alist-cons (anchor-id->key id) (string-append (file-url file) "#" id) anchors) anchors)) ((tag ('@ _ ...) body ...) (fold loop anchors body)) ((tag body ...) (fold loop anchors body)) (_ anchors))))) (define (html-files directory) ;; Return the list of HTML files under DIRECTORY. (map (cut string-append directory "/" <>) (or (scandir #$manual (lambda (file) (string-suffix? ".html" file))) '()))) (define anchors (sort (concatenate (n-par-map (parallel-job-count) (cut collect-anchors <>) (html-files #$manual))) (match-lambda* (((key1 . url1) (key2 . url2)) (if (string=? key1 key2) (string blocks (as produced by 'makeinfo --html')." (define build (with-extensions (list guile-lib guile-syntax-highlight) (with-imported-modules '((guix build utils)) #~(begin (use-modules (htmlprag) (syntax-highlight) (syntax-highlight scheme) (syntax-highlight lexers) (guix build utils) (srfi srfi-1) (srfi srfi-26) (ice-9 match) (ice-9 threads) (ice-9 vlist)) (%strict-tokenizer? #t) (define (pair-open/close lst) ;; Pair 'open' and 'close' tags produced by 'highlights' and ;; produce nested 'paren' tags instead. (let loop ((lst lst) (level 0) (result '())) (match lst ((('open open) rest ...) (call-with-values (lambda () (loop rest (+ 1 level) '())) (lambda (inner close rest) (loop rest level (cons `(paren ,level ,open ,inner ,close) result))))) ((('close str) rest ...) (if (> level 0) (values (reverse result) str rest) (begin (format (current-error-port) "warning: extra closing paren; context:~% ~y~%" (reverse result)) (loop rest 0 (cons `(close ,str) result))))) ((item rest ...) (loop rest level (cons item result))) (() (when (> level 0) (format (current-error-port) "warning: missing ~a closing parens; context:~% ~y%" level (reverse result))) (values (reverse result) "" '()))))) (define (highlights->sxml* highlights anchors) ;; Like 'highlights->sxml', but handle nested 'paren tags. This ;; allows for paren matching highlights via appropriate CSS ;; "hover" properties. When a symbol is encountered, look it up ;; in ANCHORS, a vhash, and emit the corresponding href, if any. (define (tag->class tag) (string-append "syntax-" (symbol->string tag))) (map (match-lambda ((? string? str) str) (('paren level open (body ...) close) `(span (@ (class ,(string-append "syntax-paren" (number->string level)))) ,open (span (@ (class "syntax-symbol")) ,@(highlights->sxml* body anchors)) ,close)) (('symbol text) ;; Check whether we can emit a hyperlink for TEXT. (match (vhash-assoc text anchors) (#f `(span (@ (class ,(tag->class 'symbol))) ,text)) ((_ . target) `(a (@ (class ,(tag->class 'symbol)) (href ,target)) ,text)))) ((tag text) `(span (@ (class ,(tag->class tag))) ,text))) highlights)) (define entity->string (match-lambda ("rArr" "⇒") ("rarr" "→") ("hellip" "…") ("rsquo" "’") ("nbsp" " ") (e (pk 'unknown-entity e) (primitive-exit 2)))) (define (concatenate-snippets pieces) ;; Concatenate PIECES, which contains strings and entities, ;; replacing entities with their corresponding string. (let loop ((pieces pieces) (strings '())) (match pieces (() (string-concatenate-reverse strings)) (((? string? str) . rest) (loop rest (cons str strings))) ((('*ENTITY* "additional" entity) . rest) (loop rest (cons (entity->string entity) strings))) ((('span _ lst ...) . rest) ;for (loop (append lst rest) strings)) ((('var name) . rest) ;for @var{name} within @lisp (loop rest (cons name strings))) ;XXX: losing formatting (something (pk 'unsupported-code-snippet something) (primitive-exit 1))))) (define (highlight-definition id category symbol args) ;; Produce stylable HTML for the given definition (an @deftp, ;; @deffn, or similar). `(dt (@ (id ,id) (class "symbol-definition")) (span (@ (class "symbol-definition-category")) ,@category) (span (@ (class "symbol-definition-prototype")) ,symbol " " ,@args))) (define (space? obj) (and (string? obj) (string-every char-set:whitespace obj))) (define (syntax-highlight sxml anchors) ;; Recurse over SXML and syntax-highlight code snippets. (let loop ((sxml sxml)) (match sxml (('*TOP* decl body ...) `(*TOP* ,decl ,@(map loop body))) (('head things ...) `(head ,@things (link (@ (rel "stylesheet") (type "text/css") (href #$syntax-css-url))))) (('pre ('@ ('class "lisp")) code-snippet ...) `(pre (@ (class "lisp")) ,@(highlights->sxml* (pair-open/close (highlight lex-scheme (concatenate-snippets code-snippet))) anchors))) ;; Replace the ugly used for @deffn etc., which ;; translate to
, with more stylable markup. (('dt ('@ ('id id)) ;raw Texinfo 6.8 ('span ('@ ('class "category")) category ...) ('span ('strong thing) anchor)) (highlight-definition id category thing '())) (('dt (@ ('id id)) ('span ('@ ('class "category")) category ...) ('span ('strong thing) (? space?) ('em args ...) anchor)) (highlight-definition id category thing args)) ((tag ('@ attributes ...) body ...) `(,tag (@ ,@attributes) ,@(map loop body))) ((tag body ...) `(,tag ,@(map loop body))) ((? string? str) str)))) (define (process-html file anchors) ;; Parse FILE and perform syntax highlighting for its Scheme ;; snippets. Install the result to #$output. (format (current-error-port) "processing ~a...~%" file) (let* ((shtml (call-with-input-file file html->shtml)) (highlighted (syntax-highlight shtml anchors)) (base (string-drop file (string-length #$input))) (target (string-append #$output base))) (mkdir-p (dirname target)) (call-with-output-file target (lambda (port) (write-shtml-as-html highlighted port))))) (define (copy-as-is file) ;; Copy FILE as is to #$output. (let* ((base (string-drop file (string-length #$input))) (target (string-append #$output base))) (mkdir-p (dirname target)) (catch 'system-error (lambda () (if (eq? 'symlink (stat:type (lstat file))) (symlink (readlink file) target) (link file target))) (lambda args (let ((errno (system-error-errno args))) (pk 'error-link file target (strerror errno)) (primitive-exit 3)))))) (define (html? file stat) (string-suffix? ".html" file)) (define language+node-anchors (match-lambda ((language files ...) (cons language (fold (lambda (file vhash) (let ((alist (call-with-input-file file read))) ;; Use 'fold-right' so that the first entry ;; wins (e.g., "car" from "Pairs" rather than ;; from "rnrs base" in the Guile manual). (fold-right (match-lambda* (((key . value) vhash) (vhash-cons key value vhash))) vhash alist))) vlist-null files))))) (define mono-node-anchors ;; List of language/vhash pairs, where each vhash maps an ;; identifier to the corresponding URL in a single-page manual. (map language+node-anchors '#$mono-node-indexes)) (define multi-node-anchors ;; Likewise for split-node manuals. (map language+node-anchors '#$split-node-indexes)) ;; Install a UTF-8 locale so we can process UTF-8 files. (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") ;; First process the mono-node 'guix.html' files. (for-each (match-lambda ((language . anchors) (let ((files (find-files (string-append #$input "/" language) "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$"))) (n-par-for-each (parallel-job-count) (cut process-html <> anchors) files)))) mono-node-anchors) ;; Process the multi-node HTML files. (for-each (match-lambda ((language . anchors) (let ((files (find-files (string-append #$input "/" language "/html_node") "\\.html$"))) (n-par-for-each (parallel-job-count) (cut process-html <> anchors) files)))) multi-node-anchors) ;; Last, copy non-HTML files as is. (for-each copy-as-is (find-files #$input (negate html?))))))) (computed-file name build)) (define* (stylized-html source input #:key (languages %languages) (manual %manual) (manual-css-url "/themes/initial/css/manual.css")) "Process all the HTML files in INPUT; add them MANUAL-CSS-URL as a