#lang racket/base
(require (planet neil/path-misc))
(module+ test
(require (planet neil/overeasy:2)))
(define (%infidelity:any-files-in-directory? dir)
(let loop-dir ((dir (cleanse-path dir)))
(if (directory-exists? dir)
(let loop-lst ((lst (directory-list dir)))
(if (null? lst)
#false
(let* ((short-path (car lst))
(path (build-path dir short-path)))
(cond ((directory-exists? path)
(if (regexp-match? #rx"^\\.\\.?$" (path->string short-path))
(loop-lst (cdr lst))
(or (loop-dir path)
(loop-lst (cdr lst)))))
((file-exists? path) #true)
(else (loop-lst (cdr lst)))))))
#false)))
(define (%infidelity:get-names-of-installed-debian-non-free-packages)
(let-values (((sub stdout-in stdin-out stderr-in)
(subprocess #f #f #f "/usr/bin/dpkg-query"
"--showformat"
"${Package}\t${Section}\t${Status}\\n"
"--show")))
(dynamic-wind
void
(lambda ()
(let loop ((unsorted-result '()))
(let ((line (read-line stdout-in 'linefeed)))
(cond ((eof-object? line)
(sort unsorted-result string<?))
((regexp-match #rx"^([^\t]+)\t([^\t]+)\t([^\t]+)$" line)
=> (lambda (m)
(apply (lambda (all package section status)
(if (and (regexp-match? #rx"^non-free" section)
(regexp-match? #rx"installed" status))
(loop (cons package unsorted-result))
(loop unsorted-result)))
m)))
(else (error '!!!
"invalid line ~S"
line))))))
(lambda ()
(with-handlers ((exn:fail? void))
(close-input-port stdout-in))
(with-handlers ((exn:fail? void))
(close-input-port stderr-in))
(with-handlers ((exn:fail? void))
(close-output-port stdin-out))))))
(define (get-infidelity-evidence)
`(,@(let ((non-free-packages (%infidelity:get-names-of-installed-debian-non-free-packages)))
(if (null? non-free-packages)
'()
`((non-free-dpkgs ,(let ((n (length non-free-packages)))
(if (= 1 n)
"has a non-free package installed"
(format "has ~A non-free packages installed" n)))))))
,@(if (%infidelity:any-files-in-directory? "/lib/firmware")
'((lib-firmware "has files in /lib/firmware"))
'())
))
(define (%infidelity:english-and lst)
(let ((n (length lst)))
(case n
((0) #f)
((1) (car lst))
(else (apply string-append
(cons (car lst)
(let loop ((lst (cdr lst)))
(let ((next-lst (cdr lst)))
(if (null? next-lst)
(cons ", and "
(cons (car lst)
'()))
(cons ", "
(cons (car lst)
(loop next-lst))))))))))))
(module+ test
(test (%infidelity:english-and '())
#f)
(test (%infidelity:english-and '("a"))
"a")
(test (%infidelity:english-and '("a" "b"))
"a, and b")
(test (%infidelity:english-and '("a" "b" "c"))
"a, b, and c")
(test (%infidelity:english-and '("a" "b" "c" "d"))
"a, b, c, and d"))
(define (infidelity-evidence->english evidence)
(if (null? evidence)
#f
(string-append
(%infidelity:english-and (map (lambda (x)
(cadr x))
evidence))
)))
(provide get-infidelity-english)
(define (get-infidelity-english)
(infidelity-evidence->english (get-infidelity-evidence)))