rackout-infidelity.rkt
#lang racket/base
;; Copyright Neil Van Dyke.  See file "info.rkt".

;; TODO: Maybe start documentation with this quote:
;; "When you look for the bad in mankind, expecting to find it, you surely will."
;; -- (italic "Pollyanna") " (1960)"

;; TODO: Try to determine whether Adobe Flash Player is installed manually.  Same with acroread.

(require (planet neil/path-misc))

(module+ test
  (require (planet neil/overeasy:2)))

(define (%infidelity:any-files-in-directory? dir)
  ;; TODO: !!! this does not detect infinite loops.  maybe use canonicalize-path.  an easy way might be to just use canonicalize-path's loop detection, and not detect loops otherwise
  (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 ; stdout
                            #f ; stdin
                            #f ; stderr
                            "/usr/bin/dpkg-query"
                            "--showformat"
                            "${Package}\t${Section}\t${Status}\\n"
                            "--show")))
    (dynamic-wind
     void
     (lambda ()
       ;; TODO: Really, we should redo this for smarter I/O, to check stderr,
       ;; to not block on read-line, and to have timeout.
       ;; Make higher-level library for processes.
       (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"))
          '())
    
    
    ;; !!! (list 'lib-firmware   "files in /lib/firmware")
    ))

(define (%infidelity:english-and lst)
  (let ((n (length lst)))
    (case n
      ((0) #f)
      ((1) (car lst))
      ;;      ((2) (string-append (car lst)
      ;;                          " and "
      ;;                          (cadr 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)))