#lang scheme/base

(require scheme/file)

;; This module should be invoked when we're in the server directory
(provide server-dir)
(define server-dir
  (let ([dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))])
    (if (directory-exists? dir)
      dir
      (error 'config "handin server directory does not exist: ~e" dir))))

(define config-file (path->complete-path "config.ss" server-dir))

(define poll-freq 2000.0) ; poll at most once every two seconds

(define last-poll     #f)
(define last-filetime #f)
(define raw-config    #f)
(define config-cache  #f)

(provide get-conf)
(define (get-conf key)
  (unless (and raw-config
               (< (- (current-inexact-milliseconds) last-poll) poll-freq))
    (set! last-poll (current-inexact-milliseconds))
    (let ([filetime (file-or-directory-modify-seconds config-file)])
      (unless (and filetime (equal? filetime last-filetime))
        (set! last-filetime filetime)
        (with-handlers
            ([void (lambda (e)
                     (raise-user-error 'get-conf "could not read conf (~a): ~a"
                                       config-file (exn-message e)))])
          (when raw-config
            ;; can't use log-line from logger, since it makes a cycle,
            ;; but make sure it's written in one shot; in any case, don't
            ;; write anything if this is the first read, since the logger
            ;; is not initialized yet (and if there's an error at this
            ;; stage, the server will exit)
            (fprintf (current-error-port)
                     (format "reloading configuration from ~a\n"
                             config-file)))
          (let ([c (with-input-from-file config-file read)])
            (if (and (list? c)
                     (andmap (lambda (x)
                               (and (pair? x) (symbol? (car x))))
                             c))
              (set! raw-config c)
              (error "malformed configuration file content"))))
        (set! config-cache (make-hasheq)))))
  (hash-ref config-cache key
    (lambda ()
      (let*-values ([(default translate) (config-default+translate key)]
                    ;; translate = #f => this is a computed value
                    [(v) (if translate
                           (translate (cond [(assq key raw-config) => cadr]
                                            [else default]))
                           default)])
        (hash-set! config-cache key v)
        v))))

(define (id x) x)
(define (rx s) (if (regexp? s) s (regexp s)))
(define (path p) (path->complete-path p server-dir))
(define (path/false p) (and p (path p)))
(define (path-list l) (map path l))

(define (config-default+translate which)
  (case which
    [(active-dirs)             (values '()                   path-list    )]
    [(inactive-dirs)           (values '()                   path-list    )]
    [(port-number)             (values 7979                  id           )]
    [(use-https)               (values #t                    id           )]
    [(hook-file)               (values #f                    path/false   )]
    [(session-timeout)         (values 300                   id           )]
    [(session-memory-limit)    (values 40000000              id           )]
    [(default-file-name)       (values "handin.scm"          id           )]
    [(max-upload)              (values 500000                id           )]
    [(max-upload-keep)         (values 9                     id           )]
    [(user-regexp)             (values #rx"^[a-z][a-z0-9]+$" rx           )]
    [(user-desc)               (values "alphanumeric string" id           )]
    [(username-case-sensitive) (values #f                    id           )]
    [(allow-new-users)         (values #f                    id           )]
    [(allow-change-info)       (values #f                    id           )]
    [(master-password)         (values #f                    id           )]
    [(log-output)              (values #t                    id           )]
    [(log-file)                (values "log"                 path/false   )]
    [(web-log-file)            (values #f                    path/false   )]
    [(extra-fields)
     (values '(("Full Name" #f #f)
               ("ID#" #f #f)
               ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
                "a valid email address"))
             id)]
    ;; computed from the above (mark by translate = #f)
    [(all-dirs)
     (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)]
    [(names-dirs) ; see below
     (values (paths->map (get-conf 'all-dirs)) #f)]
    [(user-fields)
     (values (filter (lambda (f) (not (eq? '- (cadr f))))
                     (get-conf 'extra-fields))
             #f)]
    [else (error 'get-conf "unknown configuration entry: ~s" which)]))

;; This is used below to map names to submission directory paths and back
;; returns a (list-of (either (list name path) (list path name)))
(define (paths->map dirs)
  (define (path->name dir)
    (unless (directory-exists? dir)
      (if (file-exists? dir)
        (error 'get-conf "directory entry points at a file: ~e" dir)
        (make-directory* dir)))
    (let-values ([(_1 name _2) (split-path dir)])
      (path-element->string name)))
  (let ([names (map path->name dirs)])
    (append (map list names dirs) (map list dirs names))))

;; Translates an assignment name to a directory path or back
(provide assignment<->dir)
(define (assignment<->dir a/d)
  (cond [(assoc a/d (get-conf 'names-dirs)) => cadr]
        [else (error 'assignment<->dir "internal error: ~e" a/d)]))