#!/bin/env racket
;; -*- scheme -*-

#lang scheme/base

(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise
         scheme/file (only-in scheme/system system)
         (except-in scheme/mpair mappend)
         meta/checker (prefix-in dist: meta/dist-specs) meta/specs)

(define (/-ify x)
  (regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/"))
(define home/     (/-ify (expand-user-path "~scheme")))
(define binaries/ (/-ify (build-path home/ "binaries")))
(define target/   (/-ify (build-path home/ "pre-installers")))
(define racket/   (/-ify (or (getenv "PLTHOME")
                             (error 'bundle "PLTHOME is not defined"))))
(define racket-base/ (/-ify (simplify-path (build-path racket/ 'up) #f)))
(define racket/-name (let-values ([(base name dir?) (split-path racket/)])
                       (path-element->string name)))

(define cd current-directory)

(define *readme-file*
  (build-path racket/ "README"))
(define *info-domain-file*
  (build-path racket/ "collects" "info-domain" "compiled" "cache.rktd"))

(define *readme-cache* #f)
(define *info-domain-cache* #f)

(define-runtime-path *spec-file* "distribution-specs")

(define *verify?*  #t)
(define *btgz?*    #t)
(define *pack?*    #t)
(define *root?*    #t)
(define *release?* #f)
(define *verbose?* 'yes) ; #t, #f, or else -- show stderr stuff but not stdout

;;; ===========================================================================
;;; Utilities etc

(define concat string-append)

(define (sort* l)
  (sort l string<?))

(define (dir-list . args)
  (sort* (map path->string (apply directory-list args))))

(define (dprintf fmt . args)
  (when *verbose?*
    (apply fprintf (current-error-port) fmt args)
    (flush-output (current-error-port))))

;;; ===========================================================================
;;; Tree utilities

;; path -> tree
;; Same as get-tree, but lists the contents of a tgz file via pax.
(define (get-tgz-tree tgz)
  (define base (regexp-replace #rx"/$" (path->string (cd)) ""))
  (define tgz-name
    (regexp-replace #rx"^.*/" (if (path? tgz) (path->string tgz) tgz) ""))
  (define (tree+rest paths curdir)
    (define cur-rx (regexp (concat "^" (regexp-quote curdir))))
    (define m
      (let ([m (and (pair? paths)
                    (regexp-match-positions cur-rx (car paths)))])
        (and m (regexp-match-positions #rx"/.*/" (car paths) (cdar m)))))
    (if m
      ;; we have too many "/"s => need to reconstruct a fake intermediate dir
      (tree+rest (cons (substring (car paths) 0 (add1 (caar m))) paths) curdir)
      (let loop ([paths paths] [contents '()])
        (when (pair? paths)
          (prop-set! (car paths) 'tgz  tgz-name)
          (prop-set! (car paths) 'base base)
          (prop-set!
           (car paths) 'name
           (cond [(regexp-match #rx"^(?:.*/)?([^/]+)/?$" (car paths)) => cadr]
                 [else (error 'get-tgz-tree
                              "bad path name: ~s" (car paths))])))
        (if (and (pair? paths) (regexp-match? cur-rx (car paths)))
          ;; still in the same subtree
          (if (regexp-match? #rx"/$" (car paths))
            ;; new directory
            (let-values ([(tree rest) (tree+rest (cdr paths) (car paths))])
              (loop rest (cons tree contents)))
            ;; new file
            (loop (cdr paths) (cons (car paths) contents)))
          ;; in a new subtree
          (values (cons curdir (reverse contents)) paths)))))
  (define-values (p pout pin perr)
    (subprocess #f /dev/null-in (current-error-port) /tar "tzf" tgz))
  (parameterize ([current-input-port pout])
    (let loop ([lines '()])
      (let ([line (read-line)])
        (if (eof-object? line)
          (let ([paths (sort* (reverse lines))])
            (subprocess-wait p)
            (unless (eq? 0 (subprocess-status p))
              (error 'get-tgz-tree "`tar' failed."))
            (let-values ([(tree rest) (tree+rest paths "")])
              (if (null? rest)
                (cdr tree)
                (error 'get-tgz-tree "something bad happened (~s...)"
                       (car paths)))))
          (loop (cons line lines)))))))

;;; ===========================================================================
;;; Start working

(register-macros!)

(define *platforms* #f)
(define *bin-types* #f)
(define *src-types* #f)
(define *platform-tree-lists* #f)
(define /pax #f)
(define /tar #f)
(define /dev/null-out #f)
(define /dev/null-in  #f)

(define (process-command-line)
  (command-line
   #:multi
   ["+d" "Verify dependencies (default)"         (set! *verify?*  #t)]
   ["-d" "Don't verify dependencies"             (set! *verify?*  #f)]
   ["+v" "Verbose mode (on stdout)"              (set! *verbose?* #t)]
   ["-v" "Normal output (only stderr) (default)" (set! *verbose?* 'yes)]
   ["-q" "Quiet mode"                            (set! *verbose?* #f)]
   ["+b" "Create binary tgzs (default)"          (set! *btgz?*    #t)]
   ["-b" "Skip binary tgzs, re-use binary trees" (set! *btgz?*    #f)]
   ["+p" "Pack distributions (default)"          (set! *pack?*    #t)]
   ["-p" "Skip packing"                          (set! *pack?*    #f)]
   ["+r" "chown the contents to root (default)"  (set! *root?*    #t)]
   ["-r" "Do not chown the contents to root"     (set! *root?*    #f)]
   ["++release" "Build for a release"            (set! *release?* #t)]
   ["-o" dest "Destination directory" (set! target/ (/-ify dest))]
   ["--text" "Stands for -d +v -b -p -r (useful for debugging)"
    (set!-values (*verify?* *verbose?* *btgz?* *pack?* *root?*)
                 (values #f #t #f #f #f))])
  (current-verbose-port (and *verbose?* current-error-port)))

;; specs can have `lambda' expressions to evaluate, do it in this context
(define-namespace-anchor bundle-specs)

(define (read-spec-file file [param *specs*])
  (process-specs
   (with-input-from-file file
     (lambda ()
       (let loop ([xs '()])
         (let ([x (read)])
           (if (eof-object? x) (reverse xs) (loop (cons x xs)))))))
   param))

(define (read-specs)
  (current-namespace (namespace-anchor->namespace bundle-specs))
  (dprintf "Reading specs...")
  (dist:register-specs!)
  (dprintf " done.\n"))

(define (input-tgz-name? f)
  (let ([f (if (path? f) (path->string f) f)])
    ;; names of tgzs that are not the generated binary ones
    (and (regexp-match? #rx"\\.tgz$" f)
         (not (regexp-match? #rx"-binaries\\.tgz$" f)))))

(define (initialize)
  (when *release?* (*environment* (cons 'release (*environment*))))
  (set! /pax (or (find-executable-path "pax" #f)
                 (error "error: couldn't find a `pax' executable")))
  (set! /tar (or (find-executable-path "gtar" #f)
                 (error "error: couldn't find a `gtar' executable")))
  (set! /dev/null-out (open-output-file "/dev/null" #:exists 'append))
  (set! /dev/null-in  (open-input-file  "/dev/null"))
  (unless (directory-exists? target/) (make-directory target/))
  (let ([d (ormap (lambda (x) (and (not (directory-exists? x)) x))
                  (list home/ racket/ binaries/ target/))])
    (when d (error 'bundle "directory not found: ~a" d)))
  (set! *platforms*
        (parameterize ([cd binaries/])
          (filter (lambda (x)
                    (and (not (regexp-match? #rx"^[.]" x))
                         (directory-exists? x)))
                  (dir-list))))
  (set! *bin-types* (map string->symbol *platforms*))
  (set! *src-types*
        (let loop ([bins *bin-types*] [r '()])
          (if (null? bins)
            (reverse r)
            (let* ([bin (car bins)] [src (get-tag bin)])
              (cond
                [(not src) (error 'binaries "no type assigned to `~e'" bin)]
                [(not (= 1 (length src)))
                 (error 'binaries "bad type assignment for `~e': ~e" bin src)]
                [else (loop (cdr bins)
                            (if (memq (car src) r) r (cons (car src) r)))])))))
  (dprintf "Scanning full tgzs")
  (set! *platform-tree-lists*
        (parameterize ([cd binaries/])
          (map (lambda (platform)
                 (dprintf ".")
                 (parameterize ([cd platform])
                   ;; if no btgz *and* "racket" already created then use
                   ;; get-tree (useful when debugging stuff so re-use pre made
                   ;; ones) should work the same with an old tree
                   (if (and (directory-exists? "racket") (not *btgz?*))
                     (filtered-map
                      (lambda (x) ; only directories contain stuff we need
                        (and (directory-exists? x) (get-tree x)))
                      (dir-list))
                     (let ([trees (filtered-map
                                   (lambda (x)
                                     (and (file-exists? x) (input-tgz-name? x)
                                          (get-tgz-tree x)))
                                   (dir-list))])
                       (tag (list (string->symbol platform))
                         (map (lambda (tree) (tree-filter 'binaries tree))
                              (apply append trees)))))))
               *platforms*)))
  (dprintf " done.\n")
  (for-each (lambda (platform trees)
              (when (null? trees)
                (error 'binaries "no binaries found for ~s" platform)))
            *platforms* *platform-tree-lists*)
  ;; Get the racket tree, remove junk and binary stuff
  (set-racket-tree! racket-base/ racket/-name *platform-tree-lists*)
  (set-bin-files-delayed-lists!
   (delay (map (lambda (trees)
                 (sort* (mappend tree-flatten (add-trees trees))))
               *platform-tree-lists*))))

(define (make-info-domain trees)
  (unless (= 1 (length trees))
    (error 'make-info-domain "got zero or multiple trees: ~e" trees))
  (let* ([collects (or (tree-filter "/racket/collects/" (car trees))
                       (error 'make-info-domain "got no collects in tree"))]
         [info (filter (lambda (x)
                         (let ([x (path->string (bytes->path (car x)))])
                           (pair? (tree-filter (concat "/racket/collects/" x)
                                               collects))))
                       *info-domain-cache*)])
    (lambda () (write info) (newline))))

(define readme-skeleton
  (delay (let ([m (regexp-match #rx"^(.*?\n====+\n)\n*(.*)$" *readme-cache*)])
           ;; title, rest (without generic source reference)
           (if m
             (list (cadr m)
                   (regexp-replace #rx"\nInstructions for building[^\n]*\n"
                                   (caddr m)
                                   ""))
             (error 'readme-skeleton "unexpected toplevel README")))))
(define (make-readme)
  (for-each
   ;; convert to CRLF on Windows
   (if (memq 'win (*environment*))
     (lambda (x) (display (regexp-replace* #rx"\r?\n" x "\r\n")))
     display)
   `(,(car (force readme-skeleton))
     "\n"
     ,@(expand-spec 'readme-header)
     "\n"
     ,(cadr (force readme-skeleton)))))

(define (create-binaries platform trees)
  (parameterize ([cd (build-path binaries/ platform)])
    (let ([full-tgz (concat "racket-"platform"-full.tgz")]
          [bin-tgz  (concat "racket-"platform"-binaries.tgz")]
          [all-tgzs (filter input-tgz-name?
                            (map path->string (directory-list)))])
      (unless (and (directory-exists? "racket") (not *btgz?*))
        (dprintf "Unpacking binaries in ~s ~a\n" platform all-tgzs)
        ;; even if a "racket" directory exists, we just overwrite the same
        ;; stuff
        (unless (member full-tgz all-tgzs)
          (error 'create-binaries "~a/~a not found" (cd) full-tgz))
        (for ([tgz all-tgzs]) (unpack tgz trees)))
      (when *btgz?*
        (dprintf "Creating ~s\n" bin-tgz)
        (when (file-exists? bin-tgz) (delete-file bin-tgz))
        (let-values ([(p pout pin perr)
                      (subprocess
                       (current-output-port) /dev/null-in (current-error-port)
                       ;; see below for flag explanations
                       /pax "-w" "-x" "ustar" "-z" "-f" bin-tgz
                       ;; only pack the racket dir (only exception is Libraries
                       ;; on OSX, but that has its own dir)
                       "racket")])
          (subprocess-wait p))))))

(define (pack archive trees prefix)
  ;; `pax' is used to create the tgz archives -- the main reasons for using it
  ;; is the fact that it can generate portable "ustar" tar files, and that it
  ;; is flexible enough to allow replacing file names, so we can collect files
  ;; from different directories and make them all appear in a single one in the
  ;; resulting archive.
  (when (eq? #t *verbose?*) (printf "~a:\n" archive))
  (cond [*pack?*
         (dprintf " packing...")
         (when (file-exists? archive) (delete-file archive))
         (let*-values ([(output) (if (eq? #t *verbose?*)
                                   (current-output-port) /dev/null-out)]
                       [(p pout pin perr)
                        ;; Note: pax prints converted paths on stderr, so
                        ;; silence it too unless verbose.  Use only for
                        ;; debugging.
                        (subprocess
                         output #f output
                         /pax
                         "-w"         ; write
                         "-x" "ustar" ; create a POSIX ustar format
                         "-z"         ; gzip the archive
                         "-d"         ; dont go down directories implicitly
                         "-s" (format ",^~a,,p" prefix) ; delete base paths
                         "-f" archive ; pack to this file
                         )])
           (parameterize ([current-output-port pin])
             (for ([t trees]) (print-tree t 'full)))
           (close-output-port pin)
           (subprocess-wait p)
           (unless (eq? 0 (subprocess-status p))
             (error 'pack "`pax' failed.")))]
        [(eq? #t *verbose?*) (for ([t trees]) (print-tree t))])
  (when (eq? #t *verbose?*) (newline))
  (flush-output))

(define (unpack archive trees)
  ;; unpack using tar (doesn't look like there's a way to unpack according to
  ;; files from stdin with pax, and it uses gnu format with @LongLinks).
  (let-values
      ([(p pout pin perr)
        (subprocess
         (current-output-port) #f (current-error-port) /tar
         "x"              ; extract
         "-z"             ; gunzip the archive
         "-p"             ; preserve permissions
         "--files-from=-" ; read files from stdin
         "-f" archive     ; unpack this file
         )]
       [(trees)
        (map (lambda (t)
               (tree-filter
                (lambda (t)
                  ;; Problem: if this returns #t/#f only, then the sources can
                  ;; come from multiple tgz since each file will be identified
                  ;; by itself.  But if this is done, then no empty directories
                  ;; will be included (see `tree-filter' comment) and this will
                  ;; later be a problem (to have an empty dir in the tree but
                  ;; not on disk) -- so return '+ and as soon as a root is
                  ;; identified with the tgz, all of it will be used.
                  (and
                   (equal? archive
                           (prop-get (tree-path t) 'tgz
                                     (lambda ()
                                       (error 'unpack
                                              "no `tgz' property for ~e" t))))
                   '+))
                t))
             trees)])
    (parameterize ([current-output-port pin])
      (for ([t trees]) (print-tree t 'only-files)))
    (close-output-port pin)
    (subprocess-wait p)
    (unless (eq? 0 (subprocess-status p)) (error 'unpack "`tar' failed."))))

;; This code implements the binary filtering of 3m/cgc files, see
;; `binary-keep/throw-templates' in "distribution-specs.ss".
;; Careful when editing!
(define (filter-bintree tree)
  (define (get-pattern spec)
    (let ([rx (expand-spec spec)])
      (if (and (pair? rx) (null? (cdr rx)) (string? (car rx)))
        (car rx)
        (error 'filter-bintree "bad value for ~e: ~e" spec rx))))
  (define keep-pattern  (get-pattern 'binary-keep))
  (define throw-pattern (get-pattern 'binary-throw))
  (define keep-rx  (regexpify-spec (string-append "*" keep-pattern  "*")))
  (define throw-rx (regexpify-spec (string-append "*" throw-pattern "*")))
  (define templates
    (let ([ts (expand-spec 'binary-keep/throw-templates)])
      (for ([t ts])
        (unless (and (string? t)
                     ;; verify that it has exactly one "<...!...>" pattern
                     (regexp-match? #rx"^[^<!>]*<[^<!>]*![^<!>]*>[^<!>]*$" t))
          (error 'filter-bintree "bad keep/throw template: ~e" t)))
      ts))
  (define (make-matcher x) ; matchers return match-positions or #f
    (let ([rxs (map (lambda (t)
                      (let* ([x (regexp-replace #rx"!" t x)]
                             [x (object-name (regexpify-spec x #t))]
                             [x (regexp-replace #rx"<(.*)>" x "(\\1)")])
                        (regexp x)))
                    templates)])
      (lambda (p) (ormap (lambda (rx) (regexp-match-positions rx p)) rxs))))
  (define (rassoc x l)
    (and (pair? l) (if (equal? x (cdar l)) (car l) (rassoc x (cdr l)))))
  (define keep?  (make-matcher keep-pattern))
  (define throw? (make-matcher throw-pattern))
  (define existing-paths (tree-flatten tree))
  ;; The two `*-paths' values are association lists: ((<path> . <plain>) ...)
  ;; both sides are unique in each list, the lhs is always an existing path
  (define (find-paths pred? mode rx)
    (define res '())
    (let loop ([t tree])
      (let ([p (tree-path t)])
        (cond [(pred? p)
               => (lambda (m)
                    (let ([plain (string-append (substring p 0 (caadr m))
                                                (substring p (cdadr m)))])
                      (when (rassoc plain res)
                        (error 'filter-bintree
                               "two ~s templates have the same plain: ~e -> ~e"
                               mode p plain))
                      (set! res `((,p . ,plain) ,@res)))
                    #t)]
              [(regexp-match? rx p)
               ;; other matches are not allowed, unless on a directory where
               ;; all files are selected
               (when (or (not (pair? t))
                         (memq #f (map loop (cdr t))))
                 (error 'filter-bintree
                        "~s path uncovered by patterns: ~e" mode p))
               #t]
              [(pair? t) (not (memq #f (map loop (cdr t))))]
              [else #f])))
    res)
  (define keep-paths  (find-paths keep?  'keep  keep-rx))
  (define throw-paths (find-paths throw? 'throw throw-rx))
  (for ([k keep-paths])
    (when (assoc (car k) throw-paths)
      (error 'filter-bintree
             "a path matched both keep and throw patterns: ~s" (car k))))
  (let* ([ps (map cdr keep-paths)]
         [ps (append ps (remove* ps (map cdr throw-paths)))]
         [scan (lambda (f paths)
                 (map (lambda (p) (cond [(f p paths) => car] [else #f])) ps))]
         [plain (scan member existing-paths)]
         [keep  (scan rassoc keep-paths)]
         [throw (scan rassoc throw-paths)])
    (define del
      (map (lambda (p k t)
             (cond
               [(and p k t) (error 'filter-bintree "got keep+throw+plain")]
               [(or k t) (or t p)]
               [else (error 'filter-bintree "internal error")]))
           plain keep throw))
    (tree-filter `(not (or ,(lambda (t) (and (memq (tree-path t) del) '+))
                           binary-throw-more))
                 tree)))

;; This is hooked below as a `distribute!' spec macro, and invoked through
;; expand-spec.
(define (distribute!)
  (define (distribute tree) (tree-filter 'distribution tree))
  (let* ([features (filter string? (reverse (*environment*)))]
         [name     (apply concat (cdr (mappend (lambda (x) (list "-" x))
                                               features)))]
         [features (map string->symbol features)]
         [bin?     (memq 'bin  features)]
         [src?     (memq 'src  features)]
         [full?    (memq 'full features)])
    (when (and bin? src?)
      (error 'distribute! "bad configuration (both bin & src): ~e" features))
    (unless (or bin? src?)
      (error 'distribute! "bad configuration (both bin & src): ~e" features))
    (for ([type      (if bin? *bin-types*           *src-types*)]
          ;; this is unused if bin? is false
          [bin-trees (if bin? *platform-tree-lists* *src-types*)])
      (tag (cons type features)
        (let ([name (format "~a-~a.tgz" name type)])
          (dprintf "Creating ~s: filtering..." name)
          (let ([trees (add-trees
                        (cons (distribute (get-racket-tree))
                              (if bin?
                                (tag 'in-binary-tree
                                  (map (if full?
                                         distribute
                                         (lambda (t)
                                           (distribute (filter-bintree t))))
                                       bin-trees))
                                '())))])
            ;; make it possible to write these files
            (chown 'me *readme-file* *info-domain-file*)
            (with-output-to-file *readme-file* #:exists 'truncate make-readme)
            (with-output-to-file *info-domain-file* #:exists 'truncate
              (make-info-domain trees))
            (chown 'root *readme-file* *info-domain-file*)
            (pack (concat target/ name) trees
                  (if bin?
                    (format "\\(~a\\|~a~a/\\)" racket-base/ binaries/ type)
                    racket-base/)))
          (dprintf " done.\n")))))
  '())
(register-spec! 'distribute!
  (lambda () (when (or *pack?* (eq? #t *verbose?*)) (distribute!))))

(register-spec! 'verify! (lambda () (when *verify?* (verify!))))

(define (read-orig-files)
  (set! *readme-cache* (file->string *readme-file*))
  (set! *info-domain-cache* (with-input-from-file *info-domain-file* read)))
(define (write-orig-files)
  (display-to-file *readme-cache* *readme-file* #:exists 'truncate)
  (with-output-to-file *info-domain-file* #:exists 'truncate
    (lambda () (write *info-domain-cache*) (newline))))

;; mimic the chown syntax
(define (chown #:rec [rec #f] who path . paths)
  (when (and *root?* *pack?*)
    (let ([user:group
           (case who [(root) "root:root"] [(me) (force whoami)]
                     [else (error 'chown "unknown user spec: ~e" who)])]
          [paths (map (lambda (x) (if (path? x) (path->string x) x))
                      (cons path paths))])
      (when (ormap (lambda (x) (regexp-match? #rx"[^/a-zA-Z0-9_ .+-]" x)) paths)
        (error 'chown "got a path that needs shell-quoting: ~a" paths))
      (system (format "sudo chown ~a ~a ~a" (if rec "-R" "") user:group
                      (apply string-append
                             (map (lambda (p) (format " \"~a\"" p)) paths)))))))

(define whoami
  (delay (parameterize ([current-output-port (open-output-string)])
           (system "echo \"`id -nu`:`id -ng`\"")
           (regexp-replace
            #rx"[ \r\n]*$" (get-output-string (current-output-port)) ""))))

(define (chown-dirs-to who)
  (when (and *root?* *pack?*)
    (dprintf "Changing owner to ~a..." who)
    (for ([dir (list racket/ binaries/)])
      (parameterize ([cd dir]) (chown #:rec #t who ".")))
    (dprintf " done.\n")))

(process-command-line)
(read-specs)
(initialize)
(for-each create-binaries *platforms* *platform-tree-lists*)
(dynamic-wind
  (lambda () (read-orig-files) (chown-dirs-to 'root))
  ;; Start the verification and distribution
  (lambda () (expand-spec 'distributions) (void))
  (lambda () (chown-dirs-to 'me) (write-orig-files)))