(import (scheme)
        (chicken base)
        (chicken condition)
        (chicken errno)
        (chicken file posix)
        (chicken file)
        (chicken foreign)
        (chicken format)
        (chicken io)
        (chicken pathname)
        (chicken platform)
        (chicken port)
        (chicken process-context posix)
        (chicken process-context)
        (chicken process)
        (chicken sort)
        (chicken string)
        (chicken tcp))

(include-relative "socketpair")
(include-relative "dag")
(include-relative "http")
(include-relative "list")
(include-relative "string")

(define default-zcat (cond-expand (macosx "gzcat") ; zcat on macOS expects the filename to end with a .Z
                                  (else "zcat")))
(define default-jobs 4)
(define default-chicken-install (make-pathname
                                  (list (foreign-value "C_INSTALL_PREFIX" c-string) "bin")
                                  chicken-install-program))

(define chicken-major (car (string-split (chicken-version) ".")))
(define egg-tarballs-server "code.call-cc.org")
(define egg-tarballs-path   (string-append "/egg-tarballs/" chicken-major "/index.gz"))

(define cache-dir (or (get-environment-variable "CHICKEN_LAY_CACHE")
                      (make-pathname (system-cache-directory) "chicken-lay")))
(define eggs-file (make-pathname cache-dir "index.gz"))
(define etag-file (make-pathname cache-dir "etag"))
(define dag-file  (make-pathname cache-dir "dag"))

(define (write/flush data port)
  (write data port)
  (flush-output port))

;;
;; Cache utilities
;;
(define (cache-check)
  (all file-exists? (list eggs-file etag-file dag-file)))

(define (cache-clear)
  (handle-exceptions
    exn
    (cond-expand
      ((or chicken-5.0 chicken-5.1 chicken-5.2 chicken-5.3)
       (void))
      (else
        (unless (eq? (get-condition-property exn 'exn 'errno #f) errno/noent)
          (abort exn))))
    (delete-directory cache-dir #t)))

(define (cache-save etag data zcat)
  (create-directory (pathname-directory etag-file) #t)
  (with-output-to-file etag-file (cut write etag))

  (create-directory (pathname-directory eggs-file) #t)
  (with-output-to-file eggs-file (cut write-string data)) 

  (let* ((zcat-cmd (sprintf "~A ~A" zcat eggs-file))
         (index (with-input-from-pipe zcat-cmd read-list))
         (dag (dag-generate index)))
    (with-output-to-file dag-file (cut write dag))))


;;
;; Workers utility
;;
(define (worker-free! w) (set-car! w #t))
(define (worker-busy! w) (set-car! w #f))
(define (worker-free? w) (car w))
(define (worker-out w)   (cadr w))
(define (worker-in w)    (caddr w))

(define (worker-ack! w)
  (or (worker-free? w)
      (let ((result (read (worker-in w))))
        (unless result (error "worker error"))
        (worker-free! w)))
  w)

(define (worker-create chicken-install verbose)
  (define redirect (if verbose "" " > /dev/null"))
  (let-values (((p c) (socketpair)))
    (define (child)
      (let ((out (open-output-file* c))
            (in  (open-input-file* c)))
        (let loop ()
          (let ((cmd (read in)))
            (cond 
              ((eq? 'build (car cmd))
               (let* ((egg (cadr cmd))
                      (line (string-append
                              chicken-install 
                              " -no-install-dependencies -no-install "
                              (symbol->string egg)
                              redirect)))
                 (when verbose (print line))
                 (handle-exceptions exn
                   (begin
                     (print "error invoking: " line)
                     (write/flush #f out))
                   (system* line)
                   (write/flush #t out)
                   (loop))))
              ((eq? 'install (car cmd))
               (let* ((eggs (cdr cmd))
                      (line (string-append
                              chicken-install
                              " -cached "
                              (apply string-append
                                     (map
                                       (lambda (egg)
                                         (string-append " " (symbol->string egg)))
                                       eggs))
                              redirect)))
                 (when verbose (print line))
                 (system* line)
                 (write/flush #t out)
                 (loop)))
              ((eq? 'exit (car cmd)))
              (else (error "got unexpected command" cmd)))))))

    (let ((pid (process-fork child #t)))
      (if (zero? pid)
        (exit)
        (list #t ; worker is free
              (open-output-file* p)
              (open-input-file* p)
              pid)))))

(define (worker-build w egg)
  (worker-busy! w)
  (write/flush `(build ,egg) (worker-out w)))

(define (worker-install w eggs)
  (worker-busy! w)
  (write/flush `(install ,@eggs) (worker-out w)))

(define (workers-next-free workers)
  (let loop ((w workers))
    (cond
      ((null? w)
       (call-with-values
         (cut file-select (map (lambda (w) (port->fileno (worker-in w))) workers) #f)
         (lambda (ready-fds _)
           (car
             (map
               worker-ack!
               (filter
                 (lambda (w)
                   (memq (port->fileno (worker-in w)) ready-fds))
                 workers))))))
      ((worker-free? (car w))
       (car w))
      ((char-ready? (worker-in (car w)))
       (worker-ack! (car w)))
      (else (loop (cdr w))))))

(define (workers-wait workers)
  (for-each worker-ack! workers))

(define (workers-finish workers)
  (for-each
    (lambda (w)
      (write/flush '(exit) (worker-out w)))
    workers))

;;
;; Main logic
;;
(define (update-eggs-index)
  (let* ((local-etag (and (cache-check) 
                          (with-input-from-file etag-file read)))
         (headers (if local-etag
                    `((If-None-Match . ,(sprintf "~A" local-etag)))
                    '())))
    (let-values (((status headers body) (http-get egg-tarballs-server
                                                  egg-tarballs-path
                                                  headers)))
      (case status
        ((304) #f)
        ((200) (cons (alist-ref 'etag headers) body))
        (else
          (error (sprintf "cannot handle HTTP response with status: ~A, headers: ~A, body len: ~A"
                          status headers (string-length body))))))))

(define (resolve levels workers)
  (print "plan " levels)
  (call/cc
    (lambda (k)
      (handle-exceptions exn
        (begin
          (print-error-message exn)
          (k #f))
        (for-each
          (lambda (eggs)
            (print "level " eggs)
            (map
              (lambda (egg)
                (let ((w (workers-next-free workers)))
                  (print "build " egg)
                  (worker-build w egg)))
              eggs)
            (workers-wait workers)
            (worker-install (workers-next-free workers) eggs)
            (workers-wait workers))
          levels)))))

(define (run jobs zcat chicken-install verbose eggs)
  ; chicken-install creates these directories; make sure they are created here
  ; so we can call chicken-install in parallel without issues
  (create-directory chicken-install-cache-directory #t)
  (create-directory chicken-install-cache-metadata-directory #t)

  (let ((updated (update-eggs-index)))
    (when updated (cache-save (car updated) (cdr updated) zcat)))

  (let ((dag (dag-prune (with-input-from-file dag-file read) eggs)))
    (unless (null? dag)
      (let* ((levels (dag-to-levels dag))
             (workers (tabulate jobs (cut worker-create chicken-install verbose)))
             (ok (resolve levels workers)))
        (workers-finish workers)
        ok))))

(define (main)
  (let ((jobs default-jobs)
        (zcat default-zcat)
        (chicken-install default-chicken-install)
        (verbose #f)
        (eggs '())
        )
    (let loop ((args (command-line-arguments)))
      (if (null? args)
        (unless (null? eggs)
          (unless (run jobs zcat chicken-install verbose (map string->symbol eggs))
            (exit 1)))
        (case (string->symbol (car args))
          ((|-i|)
           (set! chicken-install (cadr args))
           (loop (cddr args)))
          ((|-c|)
           (cache-clear)
           (loop (cdr args)))
          ((|-v|)
           (set! verbose #t)
           (loop (cdr args)))
          ((|-h|)
           (print "Usage: lay [-h] [-c] [-v] [-j jobs] [-z zcat] egg ...")
           (print "    -h         display this help page and quit")
           (print "    -c         clear the local cache before doing anything else")
           (print "    -i prog    use 'prog' as chicken-install program (default: " chicken-install ")")
           (print "    -v         print verbose output")
           (print "    -j jobs    use at most 'jobs' parallel processes (default: " jobs ")")
           (print "    -z prog    use 'prog' as zcat program (default: " zcat ")")
           (exit 0))
          ((|-j|)
           (set! jobs (string->number (cadr args)))
           (loop (cddr args)))
          ((|-z|)
           (set! zcat (cadr args))
           (loop (cddr args)))
          (else
            => (lambda (egg)
                 (set! eggs (cons (symbol->string egg) eggs))
                 (loop (cdr args)))))))))

(main)