#lang racket/base

(require racket/gui/base

;; This tool adds a "Create Javascript Package" button to the Racket menu.

(provide tool@)

;; make-reasonable-package-name: path -> string
;; Tries to pick a reasonable default for the zip file name.
(define (make-reasonable-package-name a-path)
  (let-values ([(base name dir?)
                (split-path a-path)])
    (string-append (remove-filename-extension name)

;; make-package-subdirectory-name: path -> path
(define (make-package-subdirectory-name a-path)
  (let-values ([(base name dir?)
                (split-path a-path)])
    (remove-filename-extension name)))

;; find-open-port: -> number
;; Tries to find an open port.
(define (find-open-port)
  (let* ([T 84]
          (let loop (;; Numerology at work  (P = 80, L = 76, T=84).
                     [portno 8076]
                     [attempts 0]) 
            (with-handlers ((exn:fail:network? (lambda (exn)
                                                 (cond [(< attempts T)
                                                        (loop (add1 portno)
                                                              (add1 attempts))]
                                                        (raise exn)]))))
              ;; There's still a race condition here... Not sure how to do this right.
              (let ([port (tcp-listen portno 4 #t #f)])
                (tcp-close port)

(define tool@
    (import drracket:tool^)
    (export drracket:tool-exports^)
    ;; We're not doing anything language specific, so I don't think we need
    ;; to plug into phase1 or phase2.
    (define (phase1) (void))
    (define (phase2) (void))

    ;; unit-frame<%>: interface
    ;; Just a helper interface used for the mixin below.
    (define unit-frame<%> (class->interface drracket:unit:frame%))

    ;; Here we mix in a menu item into the unit frame's Racket menu.
     (mixin (unit-frame<%>) (unit-frame<%>)
       (inherit get-language-menu

       ;; check-cleanliness: (-> X) (-> x) (-> X) -> void
       ;; Does a check to see if the file being editing is unsaved
       ;; or dirty.
       (define (check-cleanliness #:on-unsaved on-unsaved 
                                  #:on-dirty on-dirty 
                                  #:on-ok on-ok)
         (let* ([a-text (get-definitions-text)]
                [a-filename (send a-text get-filename)])
             [(not (path-string? a-filename))
             [(send a-text is-modified?)
       ;; click!: menu-item% control-event% -> void
       ;; On selection, prompts for a output zip file name,
       ;; and then writes a zip with the contents.
       (define (click! a-menu-item a-control-event)
         (let* ([a-text (get-definitions-text)]
                [a-filename (send a-text get-filename)])
            (lambda ()
              (message-box "Create Javascript Package"
                           "Your program needs to be saved first before packaging."))
            (lambda ()
              (message-box "Create Javascript Package"
                           "Your program has changed since your last save or load; please save before packaging."))
            (lambda ()
              (let ([output-file
                     (finder:put-file (make-reasonable-package-name a-filename)
                                      "Where should the Javascript package be written to?"
                  [(eq? output-file #f)
                   (let ([notify-port 
                           #:title "Creating Javascript Package")])
                     (parameterize ([current-log-port notify-port])
                             (lambda (exn)
                               (fprintf notify-port
                                        "An internal error occurred during compilation: ~a\n"
                                        (exn-message exn))
                               (raise exn))])
                         (let-values ([(ip dont-care)
                                        (make-package-subdirectory-name output-file)
                                        (lambda (output-path)                                 
                                          (fprintf notify-port "Compiling Javascript...\n")
                                          (create-javascript-package a-filename
                           (call-with-output-file output-file
                             (lambda (op) 
                               (fprintf notify-port "Writing package to file ~a...\n" output-file)
                               (copy-port ip op))
                             #:exists 'replace)
                           (fprintf notify-port "Done!\n")))))]))))))
       ;; make-web-serving-dispatcher: path -> dispatcher/c
       (define (make-web-serving-dispatcher a-filename)
         (let* ([tmpdir
                 (make-temporary-file "mztmp~a"
            (lambda () (void))
            (lambda ()
              (create-javascript-package a-filename tmpdir)
              (make-web-dispatcher tmpdir))
            (lambda () (delete-directory/files tmpdir)))))
       (define (run! a-menu-item a-click-event)
            (lambda ()
              (message-box "Run Javascript in Browser"
                           "Your program needs to be saved first before we can Javascript-compile and run it."))
            (lambda ()
              (message-box "Run Javascript in Browser"
                           "Your program has changed since your last save or load; please save first."))
            (lambda ()
              (parameterize ([current-custodian (let* ([a-rep (get-interactions-text)])
                                                  (send a-rep get-user-custodian))])
                (let ([notify-port 
                        #:title "Running Javascript")])
                  (parameterize ([current-log-port notify-port])
                    (fprintf notify-port "Starting up web server.\n")
                    (let* ([a-text (get-definitions-text)]
                            (send a-text get-filename)]
                            (make-web-serving-dispatcher a-filename)])
                      (let* ([port (find-open-port)]
                             [url (format "http://localhost:~a/index.html" port)])
                        ;; Runs the server under the user custodian
                        ;; so it properly gets cleaned up.
                        (serve #:dispatch dispatcher
                               #:port port)
                        (send-url url)
                        (fprintf notify-port 
                                 "Server should be running on ~a, and will stay up until the next Run.\n"
       ;;; Initialization
       (let ([racket-menu (get-language-menu)])
         (new separator-menu-item% [parent racket-menu])
         (new menu-item% 
              [parent racket-menu]
              [label "Create Javascript Package"]
              [callback click!])
         (new menu-item%
              [parent racket-menu]
              [label "Run Javascript in Browser"]
              [callback run!])