release-tool

#!/usr/bin/env scheme-script
;; -*- mode: scheme; coding: utf-8 -*- !#
;; release-tool - Release tool for Industria
;; Copyright © 2010, 2011, 2012 Göran Weinholt <goran@weinholt.se>

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
#!r6rs

;; Checks documentation, runs tests, lists files, etc.

(import (rnrs)
        (rnrs eval)
        (only (srfi :1 lists) take drop-right append-map
              delete-duplicates last)
        (only (srfi :13 strings) string-prefix? string-contains string-suffix?
              string-join)
        (srfi :26 cut)
        (srfi :48 intermediate-format-strings)
        (weinholt text strings)
        (only (xitomatl file-system base compat)
              directory-list file-regular? file-directory?
              file-symbolic-link? file-size)
        (only (xitomatl common) pretty-print)
        (xitomatl AS-match))

(unless (file-exists? "documentation/industria.texinfo")
  (error 'release-tool "Could not find documentation/industria.texinfo"))

(define *private-libraries*
  '((weinholt crypto aes private)
    (weinholt disassembler private)
    (weinholt net ssh algorithms)
    (weinholt net ssh kex-dh-gex)
    (weinholt net ssh kexdh)
    (weinholt net ssh private)
    (weinholt net tls)
    (weinholt struct pack-aux)))

(define *released-libraries*
  '((weinholt archive tar)
    ;;(weinholt assembler x86)
    (weinholt binfmt elf)
    (weinholt bytevectors)
    (weinholt compression adler-32)
    (weinholt compression inflate)
    (weinholt compression gzip)
    (weinholt compression xz)
    (weinholt compression zip)
    (weinholt compression zlib)
    (weinholt crypto aes)
    (weinholt crypto arcfour)
    (weinholt crypto blowfish)
    (weinholt crypto crc)
    (weinholt crypto des)
    (weinholt crypto dsa)
    (weinholt crypto ec)
    (weinholt crypto ec dsa)
    (weinholt crypto entropy)
    (weinholt crypto hmac)
    (weinholt crypto math)
    (weinholt crypto md5)
    (weinholt crypto openpgp)
    (weinholt crypto password)
    (weinholt crypto rsa)
    (weinholt crypto sha-1)
    (weinholt crypto sha-2)
    (weinholt crypto ssh-public-key)
    (weinholt crypto x509)
    (weinholt disassembler i8080)
    (weinholt disassembler m68hc12)
    (weinholt disassembler mips)
    (weinholt disassembler x86)
    ;;(weinholt net dns)
    (weinholt net irc fish)
    (weinholt net irc)
    (weinholt net otr)
    (weinholt net ssh)
    (weinholt net tcp)
    (weinholt net tls simple)
    (weinholt net tls)
    (weinholt struct der)
    (weinholt struct pack)
    (weinholt text base64)
    (weinholt text internet)
    ;;(weinholt text punycode)
    (weinholt text random-art)))

(define *properly-docmented*
  ;; These libraries export identifiers that show up in the check for
  ;; undocumented exports, for some good reason.
  '((weinholt compression adler-32)
    (weinholt crypto dh)
    (weinholt crypto dsa)
    (weinholt crypto sha-1)
    (weinholt crypto sha-2)))

(define *implementations* '(chezscheme
                            ikarus
                            ironscheme
                            guile
                            larceny
                            mosh
                            mzscheme
                            sagittarius
                            vicare
                            ypsilon))

(define-record-type file
  (fields path))

(define-record-type library
  (parent file)
  (fields name version implementation exports imports))

(define-record-type program
  (parent file)
  (fields imports))

(define-record-type document
  (parent file)
  (fields nodes defines))

(define import-name
  (match-lambda
   (((? symbol? ids) ...)
    ids)
   (((? symbol? ids) ... (_ ...))
    ids)
   (((or 'library 'only 'for 'except 'rename 'prefix) (ids ...) . _)
    (import-name ids))
   (x
    (error 'import-name "Bug" x))))

(define (locate-docs fn)
  (delete-duplicates
   (cons fn
         (append-map
          (lambda (line)
            (match (string-split line #\space)
              (("@include" fn*)
               (locate-docs (string-join (append
                                          (drop-right (string-split fn #\/) 1)
                                          (list fn*))
                                         "/")))
              (_ '())))
          (string-split (call-with-input-file fn get-string-all) #\newline)))))

(define (parse-doc fn)
  (let ((lines (string-split (call-with-input-file fn get-string-all) #\newline)))
    (let ((nodes
           (append-map
            (lambda (line)
              (match (string-split line #\space)
                (("@node" node ...) (list (map string->symbol node)))
                (_ '())))
            lines))
          (defines
           (append-map
            (lambda (line)
              (match (string-split line #\space)
                (("@deffn" _ name . _) (list (string->symbol name)))
                (("@item" name) (list (string->symbol name)))
                (_ '())))
            lines)))
      (make-document fn nodes defines))))

(define (read-program pgm)
  (assert (program? pgm))
  (call-with-input-file (file-path pgm)
    (lambda (p)
      (get-line p)                      ;skip over #!/
      (read p)                          ;skip over imports
      (let lp ()
        (let ((d (read p)))
          (if (eof-object? d) '() (cons d (lp))))))))

(define (find-docs start)
  (append (list (make-document "LICENSE.txt" '() '())
                (make-document "README" '() '())
                (make-document "NEWS" '() '()))
          (map parse-doc (locate-docs start))))

(define (examine-file path)
  (define (impl fn)
    (match (string-split fn #\.)
      ((_ impl "sls") (string->symbol impl))
      (_ #f)))
  (define parse-export
    (match-lambda
     (('rename (local-names export-names) ...) export-names)
     ((? symbol? x) (list x))
     (_ '())))
  (define maybe-library
    (match-lambda
      (('library (name ...)
         ('export exports ...)
         ('import imports ...)
         . _)
       (let ((ver (find list? name)))
         (make-library path
                       (if ver (drop-right name 1) name)
                       (or ver '())
                       (impl path)
                       (append-map parse-export exports)
                       imports)))
      (_ #f)))
  (define maybe-program
    (match-lambda
     (('import imports ...)
      (make-program path imports))
     (_ #f)))
  (guard (exn
          (else
           (format (current-error-port)
                   ";;; Exception while reading ~S: ~S~%"
                   path exn)
           #f))
    (call-with-input-file path
      (lambda (port)
        (let ((start (port-position port)))
          (let ((line1 (get-line port)))
            (cond ((or (string-prefix? "#! " line1)
                       (string-prefix? "#!/" line1))
                   (maybe-program (read port)))
                  (else
                   (set-port-position! port start)
                   (let ((data (read port)))
                     (or (maybe-program data)
                         (maybe-library data)))))))))))

;; Takes a directory name and a list of files contained in it. Returns
;; a list of (program ...) and (library ...).
(define (find-files basepath files)
  (let ((files (list-sort string<? files)))
    (append-map
     (lambda (fn)
       (let ((path (string-append basepath fn)))
         (cond ((or (string-prefix? "." fn)
                    (string-suffix? "~" fn)
                    (file-symbolic-link? fn))
                '())
               ((file-regular? path)
                (cond ((examine-file path) => list)
                      (else
                       (format (current-error-port)
                               ";;; File ~S rejected by examine-file~%" path)
                       '())))
               ((file-directory? path)
                (find-files (string-append path "/")
                            (directory-list path)))
               (else '()))))
     files)))

(define libraries (find-files "weinholt/" (directory-list "weinholt")))
(define docs (find-docs "documentation/industria.texinfo"))
(define tests (find-files "tests/" (directory-list "tests")))
(define programs (find-files "programs/" (directory-list "programs")))

;;; Find the set of released libraries

(define (find-dependencies lib-name)
  (let ((lib (find (lambda (lib) (equal? (library-name lib) lib-name))
                   libraries)))
    (unless lib
      (error 'find-released-set
             "Bad library included in the released set"
             lib-name))
    (map import-name (library-imports lib))))

(define (find-released-set start-set)
  (define (traverse add! added? library)
    (let ((deps (filter (match-lambda (('weinholt . _) #t) (_ #f))
                        (find-dependencies library))))
      (add! library)
      (for-each (lambda (dep)
                  (unless (added? dep)
                    (format (current-error-port)
                            ";;; Adding extra library to release: ~S.~%" dep)
                    (traverse add! added? dep)))
                deps)))
  (letrec ((libs (make-hashtable (lambda (x) (string-hash (format #f "~a" x)))
                                 equal?))
           (add! (cut hashtable-set! libs <> #t))
           (added? (cut hashtable-ref libs <> #f)))
    (for-each add! start-set)
    (for-each (cut traverse add! added? <>) start-set)
    (filter (lambda (lib) (added? (library-name lib)))
            libraries)))

(define release-libraries (find-released-set *released-libraries*))

(define (release-program? test type)
  (define (good-import? import)
    (define (ret import ok)
      (unless ok
        (format (current-error-port)
                ";;; Removing ~a program ~S from release because of import ~S.~%"
                type (file-path test) import))
      ok)
    (match (import-name import)
      (('srfi . _) #t)
      (('rnrs . _) #t)
      (('weinholt . _)
       (let ((v (find (lambda (lib)
                        (equal? (import-name import)
                                (library-name lib)))
                      release-libraries)))
         (ret import v)))
      ((or ('xitomatl . _) ('ikarus . _))
       (ret import (eq? type 'demo)))
      (else (ret import #f))))
  (for-all good-import? (program-imports test)))

(define release-tests (filter (cut release-program? <> 'test) tests))
(define release-programs (filter (cut release-program? <> 'demo) programs))

(define release-files (append docs
                              release-programs
                              release-tests
                              release-libraries))

(define (list-unreleased)
  (for-each (lambda (lib)
              (unless (memq lib release-files)
                (format #t "~a~%" (file-path lib))))
            (append programs tests libraries)))

;;; Completeness tests

(define (check-complete-portability)
  ;; Go over each library that has implementation-specific overrides
  ;; and print missing overrides.
  (for-each
   (lambda (lib-name)
     (for-each (lambda (impl)
                 (unless (find (lambda (lib)
                                 (and (equal? impl (library-implementation lib))
                                      (equal? lib-name (library-name lib))))
                               libraries)
                   (format #t "Missing implementation of ~S for ~S.~%"
                           lib-name (or impl "the default"))))
               (cons #f *implementations*)))
   (delete-duplicates
    (map library-name (filter library-implementation libraries)))))

(define (check-complete-documentation)
  ;; Check that documentation exists for each library that will be
  ;; included in the release. Also check that documentation isn't
  ;; provided for unreleased libraries. Future work: check that all
  ;; exports are documented.
  (define (library-name? syms)
    (define (lowercased? s)
      (string=? (string-downcase (symbol->string s))
                (symbol->string s)))
    (and (> (length syms) 1)
         (for-all lowercased? syms)))
  (let ((docs (append-map document-nodes docs))
        (defines (append-map document-defines docs))
        (libs (delete-duplicates release-libraries
                                 (lambda (lib1 lib2)
                                   (equal? (library-name lib1)
                                           (library-name lib2))))))
    (for-each
     (lambda (library)
       (let ((lib-name (library-name library)))
         (unless (member lib-name *private-libraries*)
           (if (member (cdr lib-name) docs)
               (unless (member lib-name *properly-docmented*)
                 (for-each
                  (lambda (export)
                    (unless (memq export defines)
                      (format #t "Export ~S from ~S seems undocumented.~%" export
                              (library-name library))))
                  (library-exports library)))
               (format #t "Missing documentation for ~S.~%" lib-name)))))
     libs)
    (for-each
     (lambda (doc-name)
       (when (library-name? doc-name)
         (unless (member (cons 'weinholt doc-name)
                         (map library-name libs))
           (format #t "Extra documentation for unreleased ~S.~%"
                   (cons 'weinholt doc-name)))))
     docs)
    ;; only finds false positives:
    #;
    (let ((exports (append-map library-exports libs)))
      (for-each
       (lambda (define)
         (unless (memq define exports)
           (format #t "Extra documentation for unexported identifer ~S~%" define)))
       defines))))

(define (check-complete-testing)
  (for-each
   (lambda (lib-name)
     (unless (or (member lib-name *private-libraries*)
                 (exists
                  (lambda (test)
                    (member lib-name (map import-name (program-imports test))))
                  tests))
       (format #t "No test case imports ~S.~%" lib-name)))
   (delete-duplicates (map library-name release-libraries))))

;;; Check which SRFIs are required to use all the libraries

(define (srfi<? . xs)
  (define (f s)
    (let ((s (symbol->string s)))
      (string->number (substring s 1 (string-length s)))))
  (apply < (map f (map cadr xs))))

(define (srfi=? x y) (eq? (cadr x) (cadr y)))

(define srfi? (match-lambda (('srfi . _) #t) (_ #f)))

(define *srfis*
  (list-sort srfi<?
             (delete-duplicates
              (filter srfi?
                      (map import-name
                           (append-map library-imports
                                       (remp library-implementation
                                             release-libraries))))
              srfi=?)))

(define (list-required-srfis)
  (for-each (cut format #t "~S~%" <>) *srfis*))

;;; Run test programs

(define (run-test test record!)
  ;; XXX: this has to fight the fact that Scheme "scripts" can mix
  ;; defines with other expressions at the top level. The test
  ;; programs are written so that they can be wrapped in (let () ...).
  (define srfi-78
    '((define *success* 0)
      (define *failure* 0)
      (define (do-check expr v e equal? =>)
        (pretty-print expr)
        (display =>)
        (newline)
        (pretty-print v)
        (cond ((equal? v e)
               (set! *success* (+ *success* 1))
               (display "; Correct.\n\n"))
              (else
               (set! *failure* (+ *failure* 1))
               (display "; Bad result! This is the expected result:\n")
               (pretty-print e)
               (display "\n\n"))))
      (define (check-report)
        (values *success* *failure*))
      (define-syntax check
        (lambda (x)
          (syntax-case x (=>)
            ((_ expr => expect)
             #'(define dummy (do-check 'expr expr expect equal? '=>)))
            ((_ expr (=> equal?) expect)
             #'(define dummy (do-check 'test expr expect equal? '(=> equal?)))))))))
  (format #t ";;; Running ~S which uses ~a...~%"
          (file-path test)
          (string-join
           (map (cut format #f "~s" <>)
                (filter
                 (match-lambda (('weinholt . _) #t) (else #f))
                 (map import-name (program-imports test))))
           ", "))
  (let ((imports (program-imports test))
        (code (read-program test)))
    (guard (exn
            (else
             (record! test 'exception exn)
             (format #t ";;; Exception from ~s: ~s~%" (file-path test) exn)))
      (let-values (((c f)
                    (eval `(let ()
                             ,@srfi-78
                             ,@code)
                          (apply environment
                                 '(only (xitomatl common) pretty-print)
                                 (remove '(srfi :78 lightweight-testing)
                                         imports)))))
        (record! test 'correct c)
        (record! test 'failed f)))))

(define (run-tests tests)
  (define correct 0)
  (define failed 0)
  (define failures '())
  (define (record! test msg p)
    (case msg
      ((correct) (set! correct (+ correct p)))
      ((failed)
       (unless (zero? p)
         (set! failures (cons (format #f "Failed ~a tests in ~a.~%" p (file-path test))
                              failures))
         (set! failed (+ failed p))))
      #;((bad-output)
         (set! failures (cons (format #f "Bad output from ~a.~%" (file-path test))
                              failures)))
      ((exception)
       (set! failures (cons (format #f "Exception from ~a: ~s.~%" (file-path test) p)
                            failures)))))
  (for-each (cut run-test <> record!)
            tests)
  (format #t "Summary:~%~% Test programs: ~a~% Correct tests: ~a~% Failed tests: ~a~%~%"
          (length tests) correct failed)
  (for-each display failures))

;;; Package manifests

(define synopsis "Cryptography, compression, OTR, TLS, etc.")
(define description
  "Industria is a collection of portable R6RS Scheme libraries for
cryptography (AES, HMAC, SHA-1, SHA-2, RSA, DSA, ECDSA, etc.), zlib/xz
decompression, disassemblers for various machine architectures,
Off-The-Record messaging, bytevector pack/unpack syntax, TLS connections
via custom binary ports, Secure Shell, and a few more things.")

(define homepage "http://weinholt.se/industria/")

;; This file should be named pkg-list.scm
(define (dorodango-package-list version)
  (define (build-srfis)
    (map (lambda (srfi)
           ;; (srfi :1 lists) => srfi-1
           (let ((str (symbol->string (cadr srfi))))
             (list
              (string->symbol
               (string-append "srfi-" (substring str 1 (string-length str)))))))
         *srfis*))
  (format #t ";; Dorodango package, see http://home.gna.org/dorodango/~%")
  (pretty-print
   `(package (industria ,(map string->number (string-split version #\.)))
             (depends ,@(build-srfis))
             (synopsis ,synopsis)
             (description ,description)
             (homepage ,homepage)
             (libraries "weinholt"))))

;; This file should be named MANIFEST
(define (ucl-manifest version)
  (define (print . x) (for-each write x) (newline))
  (format #t ";; UCL package, see http://ucl.willdonnelly.net/~%")
  (print '(package industria))
  (print `(version ,@(map string->number (string-split version #\.))))
  (print '(category "Cryptography" "Compression"))
  (print `(synopsis ,synopsis))
  (print `(description ,description))
  (print '(author "Göran Weinholt"))
  (print '(email "goran@weinholt.se"))
  (print `(url ,homepage))
  (print '(license MIT))
  (print '(license-file "LICENSE.txt"))
  (print `(code ,@(map file-path release-libraries)))
  ;;(print `(symlink (,(string-append "industria-" version "/weinholt") . "weinholt")))
  ;; TODO: missing SRFI dependencies
  (print `(depends))
  (print `(schemes ,@*implementations*)))

(define package-files
  (append (if (file-exists? "pkg-list.scm") '("pkg-list.scm") '())
          ;; XXX: UCL can't use the release tarball because UCL
          ;; packages are tarbombs.
          #;(if (file-exists? "MANIFEST") '("MANIFEST") '())))

;;; Invocation

(match (command-line)
  ((_ "check-complete")
   (check-complete-portability)
   (check-complete-documentation)
   (check-complete-testing))
  ((_ "list-srfis")
   (list-required-srfis))
  ((_ "run-tests") (run-tests release-tests))
  ((_ "run-all-tests") (run-tests tests))
  ((_ "list")
   ;; These are all the files to be included in a release tarball.
   (for-each (lambda (x)
               (format #t "~a~%" x))
             (append package-files (map file-path release-files))))
  ((_ "list-unreleased")
   ;; These files will not be included in the release.
   (list-unreleased))
  ((_ "dorodango" version) (dorodango-package-list version))
  ((_ "ucl" version) (ucl-manifest version))
  ((name . _)
   (format (current-error-port)
           "Usage: ~a check-complete|list-srfis|run-tests|run-all-tests|list|list-unreleased~%"
           name)
   (format (current-error-port)
           "Usage: ~a dorodango|ucl package-version~%"
           name)
   (exit 1)))

(format (current-error-port) ";;; done.~%")