#cs
(module handin-server mzscheme
  (require (lib "thread.ss")
	   (lib "port.ss")
	   (lib "mzssl.ss" "openssl")
	   (lib "file.ss")
	   (lib "date.ss")
	   (lib "list.ss")
	   (lib "string.ss")
	   "md5.ss"
	   "lock.ss"
	   "web-status-server.ss"
	   "run-status.ss")

  (define log-port (open-output-file "log.ss" 'append))

  (define current-session (make-parameter 0))

  (define (write+flush port . xs)
    (for-each (lambda (x) (write x port) (newline port)) xs)
    (flush-output port))

  (define-struct alist (name l))
  (define (a-set! alist key val)
    (let ([l (alist-l alist)])
      (cond [(assq key l) => (lambda (p) (set-cdr! p val))]
            [else (set-alist-l! alist (cons (cons key val) l))])))
  (define (a-ref alist key . default)
    (cond [(assq key (alist-l alist)) => cdr]
          [(pair? default) (car default)]
          [else (error (alist-name alist) "no value for `~s'" key)]))

  (provide LOG)
  (define (LOG str . args)
    ;; Assemble log into into a single string, to make
    ;;  interleaved log lines unlikely:
    (let ([line
	   (format "(~a ~s ~s)\n"
		   (current-session)
		   (parameterize ([date-display-format 'iso-8601])
		     (date->string (seconds->date (current-seconds)) #t))
		   (apply format str args))])
      (display line log-port)
      (flush-output log-port)))

  (define server-dir (current-directory))
  (define config-file (build-path server-dir "config.ss"))
  (unless (file-exists? config-file)
    (error 'handin-server
           "must be started from a properly configured directory"))

  (define (get-config which default)
    (get-preference which (lambda () default) #f config-file))

  (define PORT-NUMBER        (get-config 'port-number 7979))
  (define HTTPS-PORT-NUMBER  (get-config 'https-port-number (add1 PORT-NUMBER)))
  (define SESSION-TIMEOUT    (get-config 'session-timeout 300))
  (define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
  (define DEFAULT-FILE-NAME  (get-config 'default-file-name "handin.scm"))
  (define MAX-UPLOAD         (get-config 'max-upload 500000))
  (define MAX-UPLOAD-KEEP    (get-config 'max-upload-keep 9))
  (define USER-REGEXP        (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
  (define USER-DESC          (get-config 'user-desc "alphanumeric string"))
  (define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
  (define ALLOW-NEW-USERS?   (get-config 'allow-new-users #f))
  (define ALLOW-CHANGE-INFO? (get-config 'allow-change-info #f))
  (define MASTER-PASSWD      (get-config 'master-password #f))
  (define EXTRA-FIELDS
    (get-config 'extra-fields
                '(("Full Name" #f #f)
                  ("ID#" #f #f)
                  ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
                   "a valid email address"))))

  (define orig-custodian (current-custodian))

  ;; On startup, check that the users file is not locked:
  (put-preferences null null 
		   (lambda (f)
		     (delete-file f)
		     (put-preferences null null 
				      (lambda (f)
					(error 'handin-server
					       "unable to clean up lock file: ~s" f))
				      "users.ss"))
		   "users.ss")

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define ATTEMPT-DIR "ATTEMPT")

  (define (success-dir n)
    (format "SUCCESS-~a" n))
  (define (make-success-dir-available n)
    (let ([name (success-dir n)])
      (when (directory-exists? name)
	(if (< n MAX-UPLOAD-KEEP)
	    (begin
	      (make-success-dir-available (add1 n))
	      (rename-file-or-directory name (success-dir (add1 n))))
	    (delete-directory/files name)))))

  (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR)))
  (define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+"))))
  (define SUCCESS-GOOD (map success-dir '(0 1)))

  (define (cleanup-submission-body)
    ;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it
    ;; means that there was a failed submission and the next one will
    ;; re-create ATTEMPT.
    (let* ([dirlist (map path->string (directory-list))]
	   [dir (quicksort
		 (filter (lambda (d)
			   (and (directory-exists? d)
				(regexp-match SUCCESS-RE d)))
			 dirlist)
		 string<?)]
	   [dir (and (pair? dir) (car dir))])
      (when dir
	(unless (member dir SUCCESS-GOOD)
	  (LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
	       (build-path (current-directory) dir)))
	;; We have a submission directory -- copy all newer things (extra
	;; things that exist in the main submission directory but not in
	;; SUCCESS, or things that are newer in the main submission
	;; directory are kept (but subdirs in SUCCESS will are copied as
	;; is))
	(for-each
	 (lambda (f)
	   (define dir/f (build-path dir f))
	   (cond [(not (or (file-exists? f) (directory-exists? f)))
		  ;; f is in dir but not in the working directory
		  (copy-directory/files dir/f f)]
		 [(or (<= (file-or-directory-modify-seconds f)
			  (file-or-directory-modify-seconds dir/f))
		      (and (file-exists? f) (file-exists? dir/f)
			   (not (= (file-size f) (file-size dir/f)))))
		  ;; f is newer in dir than in the working directory
		  (delete-directory/files f)
		  (copy-directory/files dir/f f)]))
	 (directory-list dir)))))

  (define cleanup-sema (make-semaphore 1))
  (define (cleanup-submission dir)
    ;; This is called at a lock cleanup, so it is important that it does not
    ;; throw an exception, or the whole server will be locked down.  It is
    ;; invoked just before the lock is released, so fine to assume that we have
    ;; exclusive access to the directory contents.
    (with-handlers ([void
                     (lambda (e)
                       (LOG "*** ERROR DURING (cleanup-submission ~s) : ~a"
                            dir (if (exn? e) (exn-message e) e)))])
      (when (directory-exists? dir) ; submissions can fail before mkdir
        (parameterize ([current-directory dir])
          (call-with-semaphore cleanup-sema cleanup-submission-body)))))

  (define (cleanup-all-submissions)
    (LOG "Cleaning up all submission directories")
    (for-each (lambda (top)
                (when (directory-exists? top)
                  (parameterize ([current-directory top])
                    (for-each (lambda (pset)
                                (when (directory-exists? pset) ; filter non-dirs
                                  (parameterize ([current-directory pset])
                                    (for-each (lambda (sub)
                                                (when (directory-exists? sub)
                                                  (cleanup-submission sub)))
                                              (directory-list)))))
                              (directory-list)))))
              '("active" "inactive")))

  ;; On startup, we scan all submissions, then repeat at random intervals (only
  ;; if clients connected in that time), and check often for changes in the
  ;; active/inactive directories and run a cleanup if there was a change
  (define connection-num 0)
  (thread (lambda ()
            (define last-active/inactive #f)
            (define last-connection-num #f)
            (let loop ()
              (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
                (when (>= n 0)
                  (let ([new (map (lambda (x) 
				    (if (directory-exists? x) 
					(directory-list x)
					null))
				  '("active" "inactive"))])
                    (if (equal? new last-active/inactive)
                      (begin (sleep 30) (loop (sub1 n)))
                      (begin (set! last-active/inactive new)
                             (set! last-connection-num #f))))))
              (unless (equal? last-connection-num connection-num)
                (cleanup-all-submissions)
                (set! last-connection-num connection-num))
              (loop))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (save-submission s part)
    (with-output-to-file part
      (lambda () (display s))))

  (define (accept-specific-submission data r r-safe w)
    ;; Note: users are always sorted
    (define users       (a-ref data 'usernames))
    (define assignments (a-ref data 'assignments))
    (define assignment  (a-ref data 'assignment))
    (define dirname
      (apply string-append (car users)
             (map (lambda (u) (string-append "+" u)) (cdr users))))
    (define len #f)
    (unless (member assignment assignments)
      (error 'handin "not an active assignment: ~a" assignment))
    (LOG "assignment for ~a: ~a" users assignment)
    (write+flush w 'ok)
    (set! len (read r-safe))
    (unless (and (number? len) (integer? len) (positive? len))
      (error 'handin "bad length: ~s" len))
    (unless (len . < . MAX-UPLOAD)
      (error 'handin
             "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
             MAX-UPLOAD len))
    (parameterize ([current-directory (build-path "active" assignment)])
      (wait-for-lock dirname
        (let ([dir (build-path (current-directory) dirname)])
          (lambda () (cleanup-submission dir))))
      (when (and (pair? users) (pair? (cdr users)))
        ;; two or more users -- lock each one
        (for-each wait-for-lock users))
      (write+flush w 'go)
      (unless (regexp-match #rx"[$]" r-safe)
        (error 'handin "did not find start-of-content marker"))
      (let ([s (read-bytes len r)])
        (unless (and (bytes? s) (= (bytes-length s) len))
          (error 'handin "error uploading (got ~e, expected ~s bytes)"
                 (if (bytes? s) (bytes-length s) s) len))
        ;; we have a submission, need to create a directory if needed, make
        ;; sure that no users submitted work with someone else
        (unless (directory-exists? dirname)
          (for-each
           (lambda (dir)
             (for-each
              (lambda (d)
                (when (member d users)
                  (error 'handin
                         "bad submission: ~a has an existing submission (~a)"
                         d dir)))
              (regexp-split #rx" *[+] *" (path->string dir))))
           (directory-list))
          (make-directory dirname))
        (parameterize ([current-directory dirname]
                       [current-messenger
                        (case-lambda
                         [(msg) (write+flush w 'message msg)]
                         [(msg styles)
                          (if (eq? 'final styles)
                            (write+flush w 'message-final msg)
                            (begin (write+flush w 'message-box msg styles)
                                   (read (make-limited-input-port r 50))))])])
          ;; Clear out old ATTEMPT, if any, and make a new one:
          (when (directory-exists? ATTEMPT-DIR)
            (delete-directory/files ATTEMPT-DIR))
          (make-directory ATTEMPT-DIR)
          (save-submission s (build-path ATTEMPT-DIR "handin"))
          (timeout-control 'reset)
          (LOG "checking ~a for ~a" assignment users)
          (let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
                 [checker* (and (file-exists? checker*)
                                (parameterize ([current-directory server-dir])
                                  (dynamic-require checker* 'checker)))])
            (define-values (pre checker post)
              (cond [(not checker*) (values #f #f #f)]
                    [(procedure? checker*) (values #f checker* #f)]
                    [(and (list? checker*) (= 3 (length checker*)))
                     (apply values checker*)]
                    [else (error 'handin-configuration
                                 "bad checker value: ~e" checker*)]))
            (when pre
              (let ([dir (current-directory)])
                (with-handlers
                    ([void (lambda (e)
                             (parameterize ([current-directory dir])
                               (unless (ormap
                                        (lambda (d)
                                          (and (directory-exists? d)
                                               (regexp-match SUCCESS-RE d)))
                                        (map path->string (directory-list)))
                                 (parameterize ([current-directory ".."])
                                   (when (directory-exists? dirname)
                                     (delete-directory/files dirname)))))
                             (raise e))])
                  (parameterize ([current-directory ATTEMPT-DIR])
                    (pre users s)))))
            (let ([part (if checker
                          (parameterize ([current-directory ATTEMPT-DIR])
                            (checker users s))
                          DEFAULT-FILE-NAME)])
              (write+flush w 'confirm)
              (let ([v (read (make-limited-input-port r 50))])
                (if (eq? v 'check)
                  (begin
                    (LOG "saving ~a for ~a" assignment users)
                    (parameterize ([current-directory ATTEMPT-DIR])
                      (rename-file-or-directory "handin" part))
                    ;; Shift successful-attempt directories so that there's
                    ;;  no SUCCESS-0:
                    (make-success-dir-available 0)
                    (rename-file-or-directory ATTEMPT-DIR (success-dir 0))
                    (when post
                      (parameterize ([current-directory (success-dir 0)])
                        (post users s))))
                  (error 'handin "upload not confirmed: ~s" v)))))))))

  (define (retrieve-specific-submission data w)
    ;; Note: users are always sorted
    (define users       (a-ref data 'usernames))
    (define assignments (a-ref data 'assignments))
    (define assignment  (a-ref data 'assignment))
    (define dirname
      (apply string-append (car users)
             (map (lambda (u) (string-append "+" u)) (cdr users))))
    (define submission-dir (build-path "active" assignment dirname))
    (unless (member assignment assignments)
      (error 'handin "not an active assignment: ~a" assignment))
    (unless (directory-exists? submission-dir)
      (error 'handin "no ~a submission directory for ~a" assignment users))
    (LOG "retrieving assignment for ~a: ~a" users assignment)
    (parameterize ([current-directory (build-path "active" assignment dirname)])
      (define file
        ;; find the newest wxme file
        (let loop ([files (directory-list)] [file #f] [time #f])
          (if (null? files)
            file
            (let ([f (car files)])
              (if (and (file-exists? f)
                       (equal? #"WXME" (with-input-from-file f
                                         (lambda () (read-bytes 4))))
                       (or (not file)
                           (> (file-or-directory-modify-seconds f) time)))
                (loop (cdr files) f (file-or-directory-modify-seconds f))
                (loop (cdr files) file time))))))
      (if file
        (let ([len (file-size file)])
          (write+flush w len)
          (display "$" w)
          (display (with-input-from-file file (lambda () (read-bytes len))) w)
          (flush-output w))
        (error 'handin "no ~a submission file found for ~a" assignment users))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (put-user-data username data)
    ;; Although we don't have to worry about trashing the
    ;;  prefs file, we do have to worry about a thread
    ;;  getting killed while it locks the pref file.
    ;; Avoid the problem by using orig-custodian.
    (call-in-nested-thread
     (lambda ()
       (put-preferences
        (list (string->symbol username)) (list data)
        (lambda (f)
          (error 'handin "user database busy; please try again, and alert the adminstrator if problems persist"))
        "users.ss"))
     orig-custodian))

  (define (get-user-data username)
    (get-preference (string->symbol username) (lambda () #f) #f "users.ss"))
  (define (check-field value field-re field-name field-desc)
    (unless (cond [(or (string? field-re) (regexp? field-re))
                   (regexp-match field-re value)]
                  [(list? field-re) (member value field-re)]
                  [(not field-re) #t]
                  [else (error 'handin "bad spec: field-regexp is ~e"
                               field-re)])
      (error 'handin "bad ~a: \"~a\"~a" field-name value
             (if field-desc (format "; need ~a" field-desc) ""))))

  (define (add-new-user data)
    (define username     (a-ref data 'username/s))
    (define passwd       (a-ref data 'password))
    (define extra-fields (a-ref data 'extra-fields))
    (unless ALLOW-NEW-USERS?
      (error 'handin "new users not allowed: ~a" username))
    (check-field username USER-REGEXP "username" USER-DESC)
    ;; Since we're going to use the username in paths, and + to split names:
    (when (regexp-match #rx"[+/\\:|\"<>]" username)
      (error 'handin "username must not contain one of the following: + / \\ : | \" < >"))
    (when (regexp-match
           #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
           (string-foldcase username))
      (error 'handin "username must not be a Windows special file name"))
    (when (regexp-match #rx"^[ .]|[ .]$" username)
      (error 'handin "username must not begin or end with a space or period"))
    (when (regexp-match #rx"^solution" username)
      (error 'handin "the username prefix \"solution\" is reserved"))
    (when (string=? "checker.ss" username)
      (error 'handin "the username \"checker.ss\" is reserved"))
    (when (get-user-data username)
      (error 'handin "username already exists: `~a'" username))
    (for-each
     (lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
     extra-fields EXTRA-FIELDS)
    (wait-for-lock "+newuser+")
    (LOG "create user: ~a" username)
    (put-user-data username (cons passwd extra-fields)))

  (define (change-user-info data)
    (define usernames  (a-ref data 'usernames))
    (define user-datas (a-ref data 'user-datas))
    (define passwd     (a-ref data 'new-password))
    (define extra-fields (a-ref data 'extra-fields))
    (unless (= 1 (length usernames))
      (error 'handin "cannot change a password for multiple users: ~a"
             usernames))
    ;; the new data is the same as the old one for every empty string
    (let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
                         (car user-datas) (cons passwd extra-fields))])
      (unless (or ALLOW-CHANGE-INFO? (equal? (cdr new-data) (cdar user-datas)))
        (error 'handin "changing information not allowed: ~a" (car usernames)))
      (when (equal? new-data (car user-datas))
        (error 'handin "no fields changed: ~a" (car usernames)))
      (for-each
       (lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
       (cdr new-data) EXTRA-FIELDS)
      (LOG "change info for ~a ~s -> ~s" (car usernames) new-data (car user-datas))
      (put-user-data (car usernames) new-data)))

  (define (get-user-info data)
    (define usernames  (a-ref data 'usernames))
    (unless (= 1 (length usernames))
      (error 'handin "cannot get user-info for multiple users: ~a" usernames))
    (cdar (a-ref data 'user-datas)))

  (define crypt
    (let ([c #f] [sema (make-semaphore 1)])
      ;; use only when needed so it doesn't blow up on non-unix platforms
      (lambda (passwd salt)
        (unless c (set! c (dynamic-require '(lib "crypt.ss" "ffi") 'crypt)))
        ;; crypt is not reentrant
        (call-with-semaphore sema
          (lambda () (bytes->string/utf-8 (c passwd salt)))))))
  (define (has-password? raw md5 passwords)
    (define (good? passwd)
      (cond [(string? passwd) (equal? md5 passwd)]
            [(and (list? passwd) (= 2 (length passwd))
                  (eq? 'unix (car passwd)) (string? (cadr passwd))
                  ;; find the salt part
                  (regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)" (cadr passwd)))
             => (lambda (m)
                  (equal? (crypt raw (car m)) (cadr passwd)))]
            [else (LOG "ERROR: bad password in user database: ~s" passwd)
                  ;; do not show the bad password...
                  (error 'handin "bad password in user database")]))
    (or (member md5 passwords) ; very cheap search first
        (ormap good? passwords)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (handle-connection r r-safe w)
    (define msg #f)
    (define active-assignments (assignment-list))
    (define data
      (make-alist 'protocol-data `((assignments . ,active-assignments))))
    (define (perror fmt . args) (apply error 'handin-protocol fmt args))
    (let loop ()
      (set! msg (read r-safe))
      (case msg
        ;; ----------------------------------------
        ;; getting information from the client
        [(set)
         (let* ([key (read r-safe)] [val (read r-safe)])
           (unless (symbol? key) (perror "bad key value: ~e" key))
           (unless (if (eq? 'extra-fields key)
                     (and (list? val)
                          (- (length val) (length EXTRA-FIELDS))
                          (andmap string? val))
                     (string? val))
             (perror "bad value for set: ~e" val))
           (when (a-ref data key #f) (perror "multiple values for ~e" key))
           (case key
             [(username/s)
              (unless USERNAME-CASE-SENSITIVE?
                (set! val (string-foldcase val)))
              (let ([usernames
                     ;; Username lists must always be sorted, and never empty
                     ;; (regexp-split will not return an empty list)
                     (quicksort (regexp-split #rx" *[+] *" val) string<?)])
                (a-set! data 'usernames usernames)
                (a-set! data 'user-datas (map get-user-data usernames)))]
             [(password new-password)
              ;; empty passwords are left empty for change-user-info to re-use
              ;; an existing password value
              (when (eq? key 'password) (a-set! data 'raw-password val))
              (unless (equal? "" val) (set! val (md5 val)))]
             [(usernames user-datas raw-password assignments)
              ;; forbid setting these directly
              (perror "bad key for `set': ~e" key)])
           (a-set! data key val))
         (loop)]
        ;; ----------------------------------------
        ;; sending information to the client
        [(get-active-assignments)
         (write+flush w active-assignments)
         (loop)]
        [(get-extra-fields)
         (write+flush w EXTRA-FIELDS)
         (loop)]
        ;; ----------------------------------------
        ;; action handlers
        ;; (don't loop back except get-user-info which needs authorization)
        [(create-user) (add-new-user data)]
        [(bye) #t] ; <- general disconnection
        ;; other messages require a login: valid users and a good password
        [else
         (when (eof-object? msg)
           (let ([username/s (a-ref data 'username/s #f)])
             (apply error 'handin
                    (if username/s `("hangup (~a)" ,username/s) `("hangup")))))
         (let ([usernames  (a-ref data 'usernames #f)]
               [user-datas (a-ref data 'user-datas #f)])
           (when (or (memq #f user-datas)
                     (not (has-password?
                           (a-ref data 'raw-password)
                           (a-ref data 'password)
                           (cons MASTER-PASSWD (map car user-datas)))))
             (LOG "failed login: ~a" (a-ref data 'username/s))
             (error 'handin "bad username or password for ~a"
                    (a-ref data 'username/s)))
           (LOG "login: ~a" usernames))
         (case msg
           [(change-user-info) (change-user-info data)]
           [(save-submission) (accept-specific-submission data r r-safe w)]
           [(get-submission) (retrieve-specific-submission data w)]
           [(get-user-info) (write+flush w (get-user-info data)) (loop)]
           [else (perror "bad message `~a'" msg)])]))
    (write+flush w 'ok)) ; final confirmation for *all* actions

  (define (assignment-list)
    (quicksort (map path->string (directory-list "active")) string<?))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define no-limit-warning? #f) ; will be set to #t if no memory limits

  (define current-timeout-control (make-parameter #f))
  (provide timeout-control)
  (define (timeout-control msg)
    (LOG "timeout-control: ~s" msg)
    ((current-timeout-control) msg))

  (define (with-watcher w proc)
    (let ([session-cust (make-custodian)]
          [session-channel (make-channel)]
          [timeout #f]
          [status-box (box #f)])
      (define (timeout-control msg)
        (if (rational? msg)
          (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
          (case msg
            [(reset) (timeout-control SESSION-TIMEOUT)]
            [(disable) (set! timeout #f)]
            [else (error 'timeout-control "bad argument: ~s" msg)])))
      (current-timeout-control timeout-control)
      (timeout-control 'reset)
      (unless no-limit-warning?
        (with-handlers ([exn:fail:unsupported?
                         (lambda (x)
                           (set! no-limit-warning? #t)
                           (LOG "WARNING: per-session memory limit not supported by MrEd"))])
          (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust)))
      (let* ([watcher
              (parameterize ([current-custodian orig-custodian])
                (thread
                 (lambda ()
                   (let ([session-thread (channel-get session-channel)])
                     (let loop ([timed-out? #f])
                       (cond
                        [(sync/timeout 3 session-thread)
                         (LOG "session killed ~awhile ~s"
                              (if timed-out? "(timeout) " "")
                              (unbox status-box))
                         (write+flush
                          w (format "handin terminated due to ~a (program doesn't terminate?)~a"
                                    (if timed-out? "time limit" "excessive memory use")
                                    (if (unbox status-box)
                                      (format " while ~a" (unbox status-box))
                                      "")))
                         (close-output-port w)
                         (channel-put session-channel 'done)]
                        [(let ([t timeout]) ; grab value to avoid races
                           (and t ((current-inexact-milliseconds) . > . t)))
                         ;; Shutdown here to get the handin-terminated error
                         ;;  message, instead of relying on
                         ;;  SESSION-TIMEOUT at the run-server level
                         (custodian-shutdown-all session-cust)
                         (loop #t)]
                        [else
                         (collect-garbage)
                         (LOG "running ~a ~a"
                              (current-memory-use session-cust)
                              (if no-limit-warning?
                                "(total)"
                                (list (current-memory-use orig-custodian)
                                      (current-memory-use))))
                         (loop #f)]))))))])
        ;; Run proc in a thread under session-cust:
        (let ([session-thread
               (parameterize ([current-custodian session-cust]
                              [current-run-status-box status-box])
                 (thread
                  (lambda ()
                    (proc (lambda ()
                            ;; Proc has succeeded...
                            (parameterize ([current-custodian orig-custodian])
                              (kill-thread watcher))))
                    (channel-put session-channel 'done-normal))))])
          (channel-put session-channel session-thread)
          ;; Wait until the proc is done or killed (and kill is reported):
          (channel-get session-channel)))))


  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (LOG "server started ------------------------------")

  (define stop-status (serve-status HTTPS-PORT-NUMBER get-config))

  (define session-count 0)

  (parameterize ([error-display-handler
		  (lambda (msg exn)
		    (LOG msg))])
    (run-server
     PORT-NUMBER
     (lambda (r w)
       (set! connection-num (add1 connection-num))
       (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT)
	 (collect-garbage))
       (parameterize ([current-session (begin
					 (set! session-count (add1 session-count))
					 session-count)])
	 (let-values ([(here there) (ssl-addresses r)])
	   (LOG "connect from ~a" there))
	 (with-watcher
	  w
	  (lambda (kill-watcher)
	    (let ([r-safe (make-limited-input-port r 2048)])
	      (write+flush w 'handin)
	      ;; Check protocol:
	      (with-handlers ([exn:fail?
			       (lambda (exn)
				 (let ([msg (if (exn? exn)
						(exn-message exn)
						(format "~e" exn))])
				   (kill-watcher)
				   (LOG "ERROR: ~a" msg)
				   (write+flush w msg)
				   ;; see note on close-output-port below
				   (close-output-port w)))])
                (let ([protocol (read r-safe)])
		  (if (eq? protocol 'ver1)
		      (write+flush w 'ver1)
		      (error 'handin "unknown protocol: ~s" protocol)))
		(handle-connection r r-safe w)
		(LOG "normal exit")
		(kill-watcher)
		;; This close-output-port should not be necessary, and it's
		;; here due to a deficiency in the SLL binding.
		;; The problem is that a custodian shutdown of w is harsher
		;; for SSL output than a normal close. A normal close
		;; flushes an internal buffer that's not supposed to exist, while
		;; the shutdown gives up immediately.
		(close-output-port w)))))))
     #f ; `with-watcher' handles our timeouts
     (lambda (exn)
       (printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
     (lambda (port-k cnt reuse?)
       (let ([l (ssl-listen port-k cnt #t)])
	 (ssl-load-certificate-chain! l "server-cert.pem")
	 (ssl-load-private-key! l "private-key.pem")
	 l))
     ssl-close
     ssl-accept
     ssl-accept/enable-break)))