Merge pull request #977 from herbie-fp/zane-server-clean-up

Server clean up, Part 1

infra/merge.rkt

@@ -5,7 +5,8 @@
          "../src/utils/profile.rkt"
          "../src/api/datafile.rkt"
          "../src/reports/timeline.rkt"
-         "../src/syntax/load-plugin.rkt")
+         "../src/syntax/load-plugin.rkt"
+         "../src/reports/common.rkt")
 
 (define (merge-timelines outdir . dirs)
   (define tls
@@ -21,7 +22,8 @@
                          (curry write-json joint-tl))
   (call-with-output-file (build-path outdir "timeline.html")
                          #:exists 'replace
-                         (λ (out) (make-timeline "Herbie run" joint-tl out #:info info))))
+                         (λ (out)
+                           (write-html (make-timeline "Herbie run" joint-tl #:info info) out))))
 
 (define (merge-profiles outdir . dirs)
   (define pfs

src/api/demo.rkt

@@ -18,25 +18,18 @@
          "../config.rkt"
          "../syntax/read.rkt"
          "../utils/errors.rkt")
-(require "../syntax/types.rkt"
-         "../syntax/sugar.rkt"
-         "../utils/alternative.rkt"
+(require "../syntax/sugar.rkt"
          "../core/points.rkt"
-         "../api/sandbox.rkt"
-         "../utils/float.rkt")
+         "../api/sandbox.rkt")
 (require "datafile.rkt"
          "../reports/pages.rkt"
          "../reports/common.rkt"
          "../reports/core2mathjs.rkt"
-         "../reports/history.rkt"
-         "../reports/plot.rkt"
          "server.rkt")
 
 (provide run-demo)
 
-(define *demo?* (make-parameter false))
 (define *demo-prefix* (make-parameter "/"))
-(define *demo-output* (make-parameter false))
 (define *demo-log* (make-parameter false))
 
 (define (add-prefix url)
@@ -48,9 +41,9 @@
    (and (not (and (*demo-output*) ; If we've already saved to disk, skip this job
                   (directory-exists? (build-path (*demo-output*) x))))
         (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)])
-          (and m (get-results-for (second m))))))
+          (and m (server-check-on (second m))))))
  (λ (x)
-   (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (get-results-for (if m (second m) x)))))
+   (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (server-check-on (if m (second m) x)))))
 
 (define-bidi-match-expander hash-arg hash-arg/m hash-arg/m)
 
@@ -74,32 +67,10 @@
                   [((hash-arg) (string-arg)) generate-page]
                   [("results.json") generate-report]))
 
-(define (generate-page req result-hash page)
+(define (generate-page req job-id page)
   (define path (first (string-split (url->string (request-uri req)) "/")))
   (cond
-    [(set-member? (all-pages result-hash) page)
-     ;; Write page contents to disk
-     (when (*demo-output*)
-       (make-directory (build-path (*demo-output*) path))
-       (for ([page (all-pages result-hash)])
-         (call-with-output-file
-          (build-path (*demo-output*) path page)
-          (λ (out)
-            (with-handlers ([exn:fail? (page-error-handler result-hash page out)])
-              (make-page page out result-hash (*demo-output*) #f)))))
-       (update-report result-hash
-                      path
-                      (get-seed)
-                      (build-path (*demo-output*) "results.json")
-                      (build-path (*demo-output*) "index.html")))
-     (response 200
-               #"OK"
-               (current-seconds)
-               #"text"
-               (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count)))))
-               (λ (out)
-                 (with-handlers ([exn:fail? (page-error-handler result-hash page out)])
-                   (make-page page out result-hash (*demo-output*) #f))))]
+    [(check-and-send path job-id page)]
     [else (next-dispatcher)]))
 
 (define (generate-report req)
@@ -234,19 +205,6 @@
                (a ([href "./index.html"]) " See what formulas other users submitted."))]
             [else `("all formulas submitted here are " (a ([href "./index.html"]) "logged") ".")])))))
 
-(define (update-report result-hash dir seed data-file html-file)
-  (define link (path-element->string (last (explode-path dir))))
-  (define data (get-table-data-from-hash result-hash link))
-  (define info
-    (if (file-exists? data-file)
-        (let ([info (read-datafile data-file)])
-          (struct-copy report-info info [tests (cons data (report-info-tests info))]))
-        (make-report-info (list data) #:seed seed #:note (if (*demo?*) "Web demo results" ""))))
-  (define tmp-file (build-path (*demo-output*) "results.tmp"))
-  (write-datafile tmp-file info)
-  (rename-file-or-directory tmp-file data-file #t)
-  (copy-file (web-resource "report.html") html-file #t))
-
 (define (post-with-json-response fn)
   (lambda (req)
     (define post-body (request-post-data/raw req))

src/api/run.rkt

@@ -11,7 +11,8 @@
          "../core/sampling.rkt"
          "../reports/pages.rkt"
          "thread-pool.rkt"
-         "../reports/timeline.rkt")
+         "../reports/timeline.rkt"
+         "../reports/common.rkt")
 
 (provide make-report
          rerun-report
@@ -84,9 +85,10 @@
   (define profile (merge-profile-jsons (read-json-files info dir "profile.json")))
   (call-with-output-file (build-path dir "profile.json") (curry write-json profile) #:exists 'replace)
 
-  (call-with-output-file (build-path dir "timeline.html")
-                         #:exists 'replace
-                         (λ (out) (make-timeline "Herbie run" timeline out #:info info #:path ".")))
+  (call-with-output-file
+   (build-path dir "timeline.html")
+   #:exists 'replace
+   (λ (out) (write-html (make-timeline "Herbie run" timeline #:info info #:path ".") out)))
 
   ; Delete old files
   (let* ([expected-dirs (map string->path

src/api/server.rkt

@@ -3,6 +3,8 @@
 (require openssl/sha1)
 (require (only-in xml write-xexpr)
          json)
+(require net/url)
+(require web-server/http)
 
 (require "sandbox.rkt"
          "../core/points.rkt"
@@ -17,19 +19,28 @@
          "../utils/common.rkt"
          "../utils/errors.rkt"
          "../utils/float.rkt"
+         "../reports/pages.rkt"
+         "datafile.rkt"
          (submod "../utils/timeline.rkt" debug))
 
 (provide make-path
          get-improve-table-data
          make-improve-result
+         server-check-on
          get-results-for
          get-timeline-for
          job-count
          is-server-up
          create-job
          start-job
          wait-for-job
-         start-job-server)
+         start-job-server
+         check-and-send
+         *demo?*
+         *demo-output*)
+
+(define *demo?* (make-parameter false))
+(define *demo-output* (make-parameter false))
 
 ; verbose logging for debugging
 (define verbose #f) ; Maybe change to log-level and use 'verbose?
@@ -50,6 +61,45 @@
                     #:timeline-disabled? [timeline-disabled? #f])
   (herbie-command command test seed pcontext profile? timeline-disabled?))
 
+;; TODO move these side worker/manager
+(define (check-and-send path job-id page)
+  (define result-hash (get-results-for job-id))
+  (cond
+    [(set-member? (all-pages result-hash) page)
+     ;; Write page contents to disk
+     (when (*demo-output*)
+       (write-results-to-disk result-hash path))
+     (response 200
+               #"OK"
+               (current-seconds)
+               #"text"
+               (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count)))))
+               (λ (out)
+                 (with-handlers ([exn:fail? (page-error-handler result-hash page out)])
+                   (make-page page out result-hash (*demo-output*) #f))))]
+    [else #f]))
+
+(define (write-results-to-disk result-hash path)
+  (make-directory (build-path (*demo-output*) path))
+  (for ([page (all-pages result-hash)])
+    (call-with-output-file (build-path (*demo-output*) path page)
+                           (λ (out)
+                             (with-handlers ([exn:fail? (page-error-handler result-hash page out)])
+                               (make-page page out result-hash (*demo-output*) #f)))))
+  (define link (path-element->string (last (explode-path path))))
+  (define data (get-table-data-from-hash result-hash link))
+  (define data-file (build-path (*demo-output*) "results.json"))
+  (define html-file (build-path (*demo-output*) "index.html"))
+  (define info
+    (if (file-exists? data-file)
+        (let ([info (read-datafile data-file)])
+          (struct-copy report-info info [tests (cons data (report-info-tests info))]))
+        (make-report-info (list data) #:seed (get-seed) #:note (if (*demo?*) "Web demo results" ""))))
+  (define tmp-file (build-path (*demo-output*) "results.tmp"))
+  (write-datafile tmp-file info)
+  (rename-file-or-directory tmp-file data-file #t)
+  (copy-file (web-resource "report.html") html-file #t))
+
 ; computes the path used for server URLs
 (define (make-path id)
   (format "~a.~a" id *herbie-commit*))
@@ -67,6 +117,13 @@
   (log "Getting timeline for job: ~a.\n" job-id)
   (place-channel-get a))
 
+; Returns #f if there is no job returns the job-id if there is a completed job.
+(define (server-check-on job-id)
+  (define-values (a b) (place-channel))
+  (place-channel-put manager (list 'check job-id b))
+  (log "Checking on: ~a.\n" job-id)
+  (place-channel-get a))
+
 (define (get-improve-table-data)
   (define-values (a b) (place-channel))
   (place-channel-put manager (list 'improve b))
@@ -251,6 +308,8 @@
           [else
            (log "Job complete, no timeline, send result.\n")
            (place-channel-put handler (hash-ref completed-work job-id #f))])]
+       [(list 'check job-id handler)
+        (place-channel-put handler (if (hash-has-key? completed-work job-id) job-id #f))]
        ; Returns the current count of working workers.
        [(list 'count handler) (place-channel-put handler (hash-count busy-workers))]
        ; Retreive the improve results for results.json