#lang scheme/base
(require mzlib/thread
         scheme/port
         openssl
         scheme/file
         "private/logger.ss"
         "private/config.ss"
         "private/lock.ss"
         "private/md5.ss"
         "private/run-status.ss"
         "private/reloadable.ss"
         "private/hooker.ss"
         "web-status-server.ss"
         ;; this sets some global parameter values, and this needs
         ;; to be done in the main thread, rather than later in a
         ;; user session thread (that will make the global changes
         ;; not to be global.)
         "sandbox.ss")

(install-logger-port)

;; errors to the user: no need for a "foo: " prefix
(define (error* fmt . args)
  (error (apply format fmt args)))

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

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

(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 (get-conf '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 (sort (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-line "*** 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-line "*** 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-line "Cleaning up all submission directories")
  (for-each (lambda (pset)
              (when (directory-exists? pset) ; just in case
                (parameterize ([current-directory pset])
                  (for-each (lambda (sub)
                              (when (directory-exists? sub) ; filter non-dirs
                                (cleanup-submission sub)))
                            (directory-list)))))
            (get-conf 'all-dirs)))

;; 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)
(void
 (thread (lambda ()
           (define last-all-dirs #f)
           (define last-connection-num #f)
           (let loop ()
             (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
               (when (>= n 0)
                 (let ([new (get-conf 'all-dirs)])
                   (if (equal? new last-all-dirs)
                     (begin (sleep 30) (loop (sub1 n)))
                     (begin (set! last-all-dirs 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 (users->dirname users)
  (apply string-append (car users)
         (map (lambda (u) (string-append "+" u)) (cdr users))))

(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     (users->dirname users))
  (define len #f)
  (unless (member assignment assignments)
    (error* "not an active assignment: ~a" assignment))
  (log-line "assignment for ~a: ~a" users assignment)
  (hook 'submission-received `([usernames ,users] [assignment ,assignment]))
  (write+flush w 'ok)
  (set! len (read r-safe))
  (unless (and (number? len) (integer? len) (positive? len))
    (error* "bad length: ~s" len))
  (unless (len . < . (get-conf 'max-upload))
    (error* "max handin file size is ~s bytes, file to handin is too big (~s bytes)"
            (get-conf 'max-upload) len))
  (parameterize ([current-directory (assignment<->dir 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* "did not find start-of-content marker"))
    (let ([s (read-bytes len r)])
      (unless (and (bytes? s) (= (bytes-length s) len))
        (error* "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* "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-line "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])
                                (auto-reload-value
                                 `(file ,(path->string 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* "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
                                                    (path->string d))))
                                            (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))
                        (get-conf 'default-file-name))])
            (write+flush w 'confirm)
            (let ([v (read (make-limited-input-port r 50))])
              (if (eq? v 'check)
                (begin
                  (log-line "saving ~a for ~a" assignment users)
                  (parameterize ([current-directory ATTEMPT-DIR])
                    (cond [part (unless (equal? part "handin")
                                  (rename-file-or-directory "handin" part))]
                          [(file-exists? "handin") (delete-file "handin")]))
                  ;; 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))
                  (hook 'submission-committed
                        `([usernames ,users] [assignment ,assignment]))
                  (when post
                    (parameterize ([current-directory (success-dir 0)])
                      (post users s))))
                (error* "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     (users->dirname users))
  (define submission-dir (build-path (assignment<->dir assignment) dirname))
  (unless (member assignment assignments)
    (error* "not an active assignment: ~a" assignment))
  (unless (directory-exists? submission-dir)
    (error* "no ~a submission directory for ~a" assignment users))
  (log-line "retrieving assignment for ~a: ~a" users assignment)
  (parameterize ([current-directory submission-dir])
    (define magics '(#"WXME"
                     #"<<<MULTI-SUBMISSION-FILE>>>"
                     #"#reader(lib\"read.ss\"\"wxme\")WXME"))
    (define mlen (apply max (map bytes-length magics)))
    (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)
                     (let ([m (with-input-from-file f
                                (lambda () (read-bytes mlen)))])
                       (ormap (lambda (magic)
                                (equal? magic
                                        (subbytes m 0 (bytes-length magic))))
                              magics))
                     (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)
        (hook 'submission-retrieved
              `([usernames ,users] [assignment ,assignment])))
      (error* "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* "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]
                [(eq? field-re '-) #t] ; -> hidden field, no check
                [else (error* "bad spec: field-regexp is ~e" field-re)])
    (error* "bad ~a: \"~a\"~a" field-name value
            (if field-desc (format "; need ~a" field-desc) ""))))

;; Utility for the next two functions: reconstruct a full list of
;; extra-fields from user-fields, using "" for hidden fields
(define (add-hidden-to-user-fields user-fields)
  (let ([user-field-name->user-field
         (map cons (get-conf 'user-fields) user-fields)])
    (map (lambda (f)
           (cond [(assq f user-field-name->user-field) => cdr]
                 [else ""]))
         (get-conf 'extra-fields))))

(define (add-new-user data)
  (define username     (a-ref data 'username/s))
  (define passwd       (a-ref data 'password))
  (define user-fields  (a-ref data 'user-fields))
  (define extra-fields (add-hidden-to-user-fields user-fields))
  (unless (get-conf 'allow-new-users)
    (error* "new users not allowed: ~a" username))
  (check-field username (get-conf 'user-regexp) "username"
               (get-conf 'user-desc))
  ;; Since we're going to use the username in paths, and + to split names:
  (when (regexp-match #rx"[+/\\:|\"<>]" username)
    (error* "username must not contain these characters: + / \\ : | \" < >"))
  (when (regexp-match
         #rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
         (string-foldcase username))
    (error* "username must not be a Windows special file name"))
  (when (regexp-match #rx"^[ .]|[ .]$" username)
    (error* "username must not begin or end with a space or period"))
  (when (regexp-match #rx"^solution" username)
    (error* "the username prefix \"solution\" is reserved"))
  (when (string=? "checker.ss" username)
    (error* "the username \"checker.ss\" is reserved"))
  (when (get-user-data username)
    (error* "username already exists: `~a'" username))
  (for-each (lambda (str info)
              (check-field str (cadr info) (car info) (caddr info)))
            extra-fields (get-conf 'extra-fields))
  (wait-for-lock "+newuser+")
  (log-line "create user: ~a" username)
  (hook 'user-create `([username ,username] [fields ,extra-fields]))
  (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 user-fields  (a-ref data 'user-fields))
  (define extra-fields (add-hidden-to-user-fields user-fields))
  (unless (= 1 (length usernames))
    (error* "cannot change a password for multiple users: ~a" usernames))
  ;; the new data is the same as the old one for every empty string (includes
  ;; hidden fields)
  (let* ([username (car usernames)]
         [old-data (car user-datas)]
         [new-data (map (lambda (old new) (if (equal? "" new) old new))
                        old-data (cons passwd extra-fields))])
    (unless (or (get-conf 'allow-change-info)
                (equal? (cdr new-data) (cdr old-data)))
      (error* "changing information not allowed: ~a" username))
    (when (equal? new-data old-data)
      (error* "no fields changed: ~a" username))
    (for-each (lambda (str info)
                (check-field str (cadr info) (car info) (caddr info)))
              (cdr new-data) (get-conf 'extra-fields))
    (log-line "change info for ~a ~s -> ~s" username old-data new-data)
    (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change
      (hook 'user-change `([username ,username]
                           [old ,(cdr old-data)]
                           [new ,(cdr new-data)])))
    (put-user-data username new-data)))

(define (get-user-info data)
  (define usernames  (a-ref data 'usernames))
  (unless (= 1 (length usernames))
    (error* "cannot get user-info for multiple users: ~a" usernames))
  ;; filter out hidden fields
  (let ([all-data (cdar (a-ref data 'user-datas))])
    (filter values (map (lambda (d f)
                          (and (memq f (get-conf 'user-fields)) d))
                        all-data (get-conf 'extra-fields)))))

(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)
    (define (bad-password msg)
      (log-line "ERROR: ~a -- ~s" msg passwd)
      (error* "bad password in user database"))
    (cond [(string? passwd) (equal? md5 passwd)]
          [(and (list? passwd) (= 2 (length passwd))
                (symbol? (car passwd)) (string? (cadr passwd)))
           (case (car passwd)
             [(plaintext) (equal? raw (cadr passwd))]
             [(unix)
              (let ([salt (regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)"
                                        (cadr passwd))])
                (unless salt (bad-password "badly formatted unix password"))
                (equal? (crypt raw (car salt)) (cadr passwd)))]
             [else (bad-password "bad password type in user database")])]
          [else (bad-password "bad password value 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 . ,(box 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? 'user-fields key)
                   (and (list? val)
                        (- (length val) (length (get-conf 'user-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 (get-conf '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)
                   (sort (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-user-fields)
       (write+flush w (map car (get-conf 'user-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 (get-conf 'master-password)
                               (map car user-datas)))))
           (log-line "failed login: ~a" (a-ref data 'username/s))
           (error* "bad username or password for ~a"
                   (a-ref data 'username/s)))
         (log-line "login: ~a" usernames)
         (hook 'login `([usernames ,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)
  (map assignment<->dir (get-conf 'active-dirs)))

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

(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-line "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 (get-conf '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-line "WARNING: per-session memory limit not supported by MrEd"))])
        (custodian-limit-memory session-cust
                                (get-conf '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)
                       (let* ([status (unbox status-box)]
                              [status (if status
                                        (format " while ~a" status)
                                        "")])
                         (log-line "session killed ~a~a"
                                   (if timed-out? "(timeout) " "(memory)")
                                   status)
                         (write+flush
                          w (format "handin terminated due to ~a (program doesn't terminate?)~a"
                                    (if timed-out? "time limit" "excessive memory use")
                                    status))
                         (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 a timeout at the
                       ;;  run-server level
                       (custodian-shutdown-all session-cust)
                       (loop #t)]
                      [else
                       (collect-garbage)
                       (log-line "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-line "server started ------------------------------")
(hook 'server-start `([port ,(get-conf 'port-number)]))

(define stop-status
  (cond [(get-conf 'https-port-number) => serve-status]
        [else void]))

(define session-count 0)

(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))])
  (run-server
   (get-conf 'port-number)
   (lambda (r w)
     (set! connection-num (add1 connection-num))
     (when ((current-memory-use) . > . (get-conf '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-line "connect from ~a" there)
         (hook 'server-connect `([from ,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-line "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-line "normal exit")
              (kill-watcher)
              ;; This close-output-port should not be necessary, and it's
              ;; here due to a deficiency in the SSL 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))