runner: use dynamic-rerequire to reload applications

Related to #19.  Significantly improves the time it takes to reload
applications after a change.

Technically, this is a breaking change for the runner.  Apps may need
to add a `before-reload` function to their "dynamic.rkt" module and
instruct libraries like deta to be more lenient.

koyo-lib/blueprints/minimal/app-name-here/dynamic.rkt

@@ -33,7 +33,8 @@
 
 (provide
  prod-system
- start)
+ start
+ before-reload)
 
 (define/contract (start)
   (-> (-> void?))
@@ -53,6 +54,8 @@
     (system-stop prod-system)
     (stop-logger)))
 
+(define (before-reload)
+  (void))
 
 (module+ main
   (define stop (start))

koyo-lib/blueprints/standard/app-name-here/dynamic.rkt

@@ -3,6 +3,7 @@
 (require (for-syntax racket/base)
          component
          db
+         deta/reflect
          koyo/database
          koyo/database/migrator
          koyo/flash
@@ -80,7 +81,8 @@
 
 (provide
  prod-system
- start)
+ start
+ before-reload)
 
 (define/contract (start)
   (-> (-> void?))
@@ -104,6 +106,9 @@
     (current-system #f)
     (stop-logger)))
 
+(define (before-reload)
+  (schema-registry-allow-conflicts? #t))
+
 
 (module+ main
   (define stop (start))

koyo-lib/koyo/cli.rkt

@@ -235,16 +235,16 @@
           (write-string replaced-contents out))))))
 
 (define (handle-serve)
-  (define recompile? #t)
+  (define recompile? #f)
   (define errortrace? #f)
   (define dynamic-module-path
     (command-line
      #:program (current-program-name)
      #:once-each
      [("--errortrace") "run the application with errortrace"
                        (set! errortrace? #t)]
-     [("--disable-recompile") "don't recompile changed files on reload"
-                              (set! recompile? #f)]
+     [("--enable-recompile") "recompile changed files after reload"
+                             (set! recompile? #t)]
      #:args ([dynamic-module-path #f])
      (or dynamic-module-path (infer-dynamic-module-path))))
 

koyo-lib/koyo/job/registry.rkt

@@ -4,8 +4,15 @@
  lookup
  register!)
 
+(module+ private
+  (provide
+   clear!))
+
 (define REGISTRY (make-hash))
 
+(define (clear!)
+  (hash-clear! REGISTRY))
+
 (define (register! qualified-id job)
   (when (hash-has-key? REGISTRY qualified-id)
     (raise-user-error 'define-job "a job named ~s already exists" qualified-id))

koyo-lib/koyo/private/mod.rkt

@@ -0,0 +1,82 @@
+#lang racket/base
+
+;; Prior to racket/racket@14f0f86, dynamic-rerequire did not handle
+;; transitive dependencies correctly so this module can be used to
+;; force it to reload dependencies properly on those versions.
+
+(require racket/list
+         racket/match
+         "version.rkt")
+
+(provide
+ should-touch-dependents?
+ touch-dependents)
+
+(define should-touch-dependents?
+  (< (version-number) 8002000004))
+
+(define (touch-dependents root mod)
+  (define (touch path)
+    (eprintf "  [touching ~a]~n" path)
+    (with-handlers ([exn:fail:filesystem? void])
+      (file-or-directory-modify-seconds path (current-seconds))))
+  (for ([path (find-dependents root mod)])
+    (touch path)
+    (touch (mod-path->zo-path path))))
+
+;; TODO: Handle complete compiled paths.
+(define (mod-path->zo-path p)
+  (define-values (dir filename _)
+    (split-path p))
+  (define compiled
+    (let ([l (use-compiled-file-paths)])
+      (if (pair? l) (car l) "compiled")))
+  (build-path dir compiled (path-replace-extension filename #"_rkt.zo")))
+
+(define (find-dependents root mod)
+  (define dependents-tree
+    (build-dependents-tree (simplify-path root)))
+
+  (let loop ([dependents null]
+             [modules (list (simplify-path mod))])
+    (match modules
+      [(list)
+       (remove-duplicates dependents)]
+
+      [(list mod mods ...)
+       (define dependents* (hash-ref dependents-tree mod null))
+       (loop (append dependents dependents*)
+             (append dependents* mods))])))
+
+(define (build-dependents-tree mod)
+  (let loop ([dependents (hash)]
+             [mods (list mod)]
+             [seen (hash)])
+    (match mods
+      [(list)
+       dependents]
+
+      [(list (? (λ (mod) (hash-has-key? seen mod))) mods ...)
+       (loop dependents mods seen)]
+
+      [(list mod mods ...)
+       (parameterize ([current-load-relative-directory (simplify-path (build-path mod 'up))])
+         (define dependencies (find-dependencies mod))
+         (define dependents*
+           (for/fold ([dependents dependents])
+                     ([dependency (in-list dependencies)])
+             (hash-update dependents dependency (λ (mods) (cons mod mods)) null)))
+
+         (loop dependents* (append mods dependencies) (hash-set seen mod #t)))])))
+
+(define (find-dependencies mod)
+  (for*/fold ([dependencies null])
+             ([phase (module->imports mod)]
+              [dependency (cdr phase)]
+              #:when (local? dependency))
+    (cons (resolved-module-path-name (module-path-index-resolve dependency)) dependencies)))
+
+(define (local? mpi)
+  (define-values (name _)
+    (module-path-index-split mpi))
+  (string? name))

koyo-lib/koyo/private/version.rkt

@@ -0,0 +1,13 @@
+#lang racket/base
+
+(require racket/string)
+
+(provide
+ version-number)
+
+(define (version-number [v (version)])
+  (define parts
+    (map string->number (string-split v ".")))
+  (for/sum ([e (in-list '(10 7 4 0))]
+            [p (in-sequences parts '(0 0 0 0))])
+    (* p (expt 10 e))))

koyo-lib/koyo/runner.rkt

@@ -51,34 +51,39 @@
 
 (define/contract (run-forever dynamic-module-path
                               #:recompile? [recompile? #t]
-                              #:errortrace? [errortrace? #t])
+                              #:errortrace? [errortrace? #t]
+                              #:server-timeout [server-timeout 30])
   (->* (path-string?)
        (#:recompile? boolean?
-        #:errortrace? boolean?) void?)
+        #:errortrace? boolean?
+        #:server-timeout (and/c real? positive?))
+       void?)
 
   (file-stream-buffer-mode (current-output-port) 'line)
   (file-stream-buffer-mode (current-error-port) 'line)
 
   (define root-path (simplify-path (build-path dynamic-module-path 'up 'up)))
   (define command-args
     (if errortrace?
-        (list "-l" "errortrace" "-t" dynamic-module-path)
-        (list dynamic-module-path)))
+        (list "-l" "errortrace" "-l" "koyo/runner" "--" "--verbose" dynamic-module-path)
+        (list "-l" "koyo/runner" "--" "--verbose" dynamic-module-path)))
 
   (define (run)
+    (define-values (command-in command-out)
+      (make-pipe))
     (define-values (stderr-in stderr-out)
       (make-pipe))
-    (match-define (list in out pid err control)
+    (match-define (list _in _out pid err control)
       (parameterize ([subprocess-group-enabled #t])
         (apply process*/ports
                (current-output-port)
-               (current-input-port)
+               command-in
                stderr-out
                racket-exe
                command-args)))
 
     (define ready? (make-semaphore))
-    (define stderr-filter
+    (define _stderr-filter
       (thread
        (lambda ()
          (parameterize ([current-output-port (current-error-port)])
@@ -95,49 +100,120 @@
        (lambda (_)
          (control 'status))))
 
-    (unless (sync/timeout 10 stopped-evt ready?)
+    (unless (sync/timeout server-timeout stopped-evt ready?)
       (log-runner-warning "timed out while waiting for 'listening' output"))
     (log-runner-info "application process started with pid ~a" pid)
 
     (values
      stopped-evt
+     (lambda (changed-path)
+       (log-runner-info "reloading application because '~a' changed" changed-path)
+       (write `(reload ,(path->string changed-path)) command-out)
+       (sync/timeout
+        server-timeout
+        (handle-evt stopped-evt void)
+        (handle-evt
+         ready?
+         (λ (_)
+           (log-runner-info "application reloaded")))))
      (lambda ()
        (control 'interrupt)
        (control 'wait)
-       (close-output-port stderr-out))))
+       (close-output-port stderr-out)
+       (close-input-port command-in)
+       (close-output-port command-out))))
 
   (define (make! [parallel? #f])
     (if parallel?
-        (raco "make" "-j" (~a (processor-count)) dynamic-module-path)
-        (raco "make" dynamic-module-path)))
+        (raco "make" "--disable-constant" "-j" (~a (processor-count)) dynamic-module-path)
+        (raco "make" "--disable-constant" "-v" dynamic-module-path)))
 
-  (when recompile?
-    (log-runner-info "compiling application")
-    (make! #t))
+  (define compiler
+    (thread
+     (lambda ()
+       (let loop ()
+         (match (thread-receive)
+           ['(compile)
+            (log-runner-info "compiling application")
+            (make! #t)
+            (loop)]
+
+           [`(recompile ,changed-path)
+            (when recompile?
+              (log-runner-info "recompiling because '~a' changed" changed-path)
+              (make!))
+            (loop)])))))
+  (define (compile-app)
+    (thread-send compiler '(compile)))
+  (define (recompile-app changed-path)
+    (thread-send compiler `(recompile ,changed-path)))
 
+  (compile-app)
   (log-runner-info "starting application process")
+  (let process-loop ()
+    (let-values ([(stopped-evt reload stop) (run)])
+      (let application-loop ()
+        (with-handlers ([exn:break?
+                         (lambda (_e)
+                           (stop))])
+          (sync/enable-break
+           (handle-evt
+            stopped-evt
+            (lambda (status)
+              (when (eq? status 'done-error)
+                (log-runner-warning "application process failed; waiting for changes before reloading")
+                (sync (code-change-evt root-path)))
+
+              (log-runner-info "restarting application process")
+              (process-loop)))
+           (handle-evt
+            (code-change-evt root-path)
+            (lambda (changed-path)
+              (reload changed-path)
+              (recompile-app changed-path)
+              (application-loop)))))))))
+
+(module+ main
+  (require racket/cmdline
+           racket/rerequire
+           setup/collects
+           (prefix-in jobs: (submod "job/registry.rkt" private))
+           "private/mod.rkt")
+
+  (define verbose? #f)
+  (define dynamic-module-path
+    (command-line
+     #:once-each
+     [("--verbose") "turn on verbose logging" (set! verbose? #t)]
+     #:args (dynamic-module-path)
+     dynamic-module-path))
+
+  (define mod-path (path->module-path dynamic-module-path))
+  (define (start)
+    (jobs:clear!)
+    (dynamic-rerequire #:verbosity (if verbose? 'reload 'none) mod-path)
+    (values
+     ((dynamic-require mod-path 'start))
+     (dynamic-require mod-path 'before-reload (λ () void))))
+
   (let loop ()
-    (let-values ([(stopped-evt stop) (run)])
-      (with-handlers ([exn:break?
-                       (lambda _
-                         (stop))])
-        (sync/enable-break
-         (handle-evt
-          stopped-evt
-          (lambda (status)
-            (when (eq? status 'done-error)
-              (log-runner-warning "application process failed; waiting for changes before reloading")
-              (sync (code-change-evt root-path)))
-
-            (log-runner-info "restarting application process")
-            (loop)))
-         (handle-evt
-          (code-change-evt root-path)
-          (lambda (changed-path)
-            (when recompile?
-              (log-runner-info (format "recompiling because '~a' changed" changed-path))
-              (make!))
-            (when stop
-              (log-runner-info "stopping application process")
-              (stop))
-            (loop))))))))
+    (let-values ([(stop before-reload) (start)])
+      (let inner-loop ()
+        (with-handlers ([exn:break?
+                         (lambda (_)
+                           (stop))])
+          (sync/enable-break
+           (handle-evt
+            (current-input-port)
+            (lambda (_)
+              (match (read)
+                [`(reload ,changed-path)
+                 (stop)
+                 (when should-touch-dependents?
+                   (touch-dependents dynamic-module-path changed-path))
+                 (before-reload)
+                 (loop)]
+
+                [message
+                 (eprintf "koyo/runner: unhandled message ~e~n" message)
+                 (inner-loop)])))))))))

koyo-test/koyo/session.rkt

@@ -9,10 +9,11 @@
 (provide session-tests)
 
 (define session-manager
-  ((make-session-manager-factory #:cookie-name "session-id"
-                                 #:shelf-life 86400
-                                 #:secret-key #"supercalifragilisticexpialidocious"
-                                 #:store (make-memory-session-store))))
+  ((make-session-manager-factory
+    #:cookie-name "session-id"
+    #:shelf-life 86400
+    #:secret-key #"supercalifragilisticexpialidocious"
+    #:store (make-memory-session-store))))
 
 (define session-tests
   (test-suite