<commit_before>(module dispatch-passwords mzscheme
  (require (lib "kw.ss")
           (lib "contract.ss"))
  (require "dispatch.ss"
           "../private/util.ss"
           "../private/configuration.ss"
           "../private/servlet-helpers.ss"
           "../private/connection-manager.ss"
           "../private/response.ss")  
  (provide/contract
   [interface-version dispatcher-interface-version?])
  (provide ; XXX contract kw
   make)
  
  (define interface-version 'v1)
  (define/kw (make #:key
                   [password-file "passwords"]
                   [password-connection-timeout 300]
                   [authentication-responder 
                    (gen-authentication-responder "forbidden.html")]
                   [passwords-refresh-responder
                    (gen-passwords-refreshed "passwords-refresh.html")])
    (define last-read-time (box #f))
    (define password-cache (box #f))
    (define (update-password-cache!)
      (define cur-mtime (file-or-directory-modify-seconds password-file))
      (when (or (not (unbox last-read-time))
                (cur-mtime . > . (unbox last-read-time))
                (not (unbox password-cache)))                
        (set-box! last-read-time cur-mtime)
        ; more here - a malformed password file will kill the connection
        (set-box! password-cache (read-passwords password-file))))
    (define (read-password-cache)
      (update-password-cache!)
      (unbox password-cache))
    (lambda (conn req)
      (define-values (uri method path) (decompose-request req))
      (cond
        [(access-denied? method path (request-headers/raw req) (read-password-cache))
         => (lambda (realm)
              (adjust-connection-timeout! conn password-connection-timeout)
              (request-authentication conn method uri
                                      authentication-responder
                                      realm))]
        [(string=? "/conf/refresh-passwords" path)
         ;; more here - send a nice error page
         (update-password-cache!)
         (output-response/method
          conn
          (passwords-refresh-responder)
          method)]
        [else
         (next-dispatcher)])))
  
  ;; ****************************************
  ;; ****************************************
  ;; ACCESS CONTROL
  
  ;; pass-entry = (make-pass-entry str regexp (list sym str))
  (define-struct pass-entry (domain pattern users))
  
  ;; access-denied? : Method string x-table denied? -> (or/c false str)
  ;; denied?: str sym str -> (or/c str #f)
  ;; the return string is the prompt for authentication
  (define (access-denied? method uri-str headers denied?)    
    (define user-pass (extract-user-pass headers))
    (if user-pass
        (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
        (denied? uri-str fake-user "")))
  
  (define-struct (exn:password-file exn) ())
  
  ;; : host -> (str sym str -> (or/c str #f))
  ;; to produce a function that checks if a given url path is accessible by a given user with a given
  ;; password.  If not, the produced function returns a string, prompting for the password.
  ;; If the password file does not exist, all accesses are allowed.  If the file is malformed, an
  ;; exn:password-file is raised.
  (define (read-passwords password-path)
    (with-handlers ([void (lambda (exn)
                            (raise (make-exn:password-file (string->immutable-string
                                                            (format "could not load password file ~a" password-path))
                                                           (current-continuation-marks))))])
      (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path)))
          (let ([passwords
                 (let ([raw (load password-path)])
                   (unless (password-list? raw)
                     (raise "malformed passwords"))
                   (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
                        raw))])
            
            ;; string symbol bytes -> (or/c #f string)
            (lambda (request-path user-name password)
              (ormap (lambda (x)
                       (and (regexp-match (pass-entry-pattern x) request-path)
                            (let ([name-pass (assq user-name (pass-entry-users x))])
                              (if (and name-pass
                                       (string=?
                                        (cadr name-pass)
                                        (bytes->string/utf-8 password)))
                                  #f
                                  (pass-entry-domain x)))))
                     passwords)))
          (lambda (req user pass) #f))))
  
  (define fake-user (gensym))
  
  ;; password-list? : TST -> bool
  <commit_msg>bug<commit_after>(module dispatch-passwords mzscheme
  (require (lib "kw.ss")
           (lib "contract.ss"))
  (require "dispatch.ss"
           "../private/util.ss"
           "../private/configuration.ss"
           "../private/servlet-helpers.ss"
           "../private/connection-manager.ss"
           "../private/response.ss")  
  (provide/contract
   [interface-version dispatcher-interface-version?])
  (provide ; XXX contract kw
   make)
  
  (define interface-version 'v1)
  (define/kw (make #:key
                   [password-file "passwords"]
                   [password-connection-timeout 300]
                   [authentication-responder 
                    (gen-authentication-responder "forbidden.html")]
                   [passwords-refresh-responder
                    (gen-passwords-refreshed "passwords-refresh.html")])
    (define last-read-time (box #f))
    (define password-cache (box #f))
    (define (update-password-cache!)
      (when (and (file-exists? password-file) (memq 'read (file-or-directory-permissions password-file)))
          (let ([cur-mtime (file-or-directory-modify-seconds password-file)])
            (when (or (not (unbox last-read-time))
                      (cur-mtime . > . (unbox last-read-time))
                      (not (unbox password-cache)))                
              (set-box! last-read-time cur-mtime)
              ; more here - a malformed password file will kill the connection
              (set-box! password-cache (read-passwords password-file))))))
    (define (read-password-cache)
      (update-password-cache!)
      (unbox password-cache))
    (lambda (conn req)
      (define-values (uri method path) (decompose-request req))
      (define denied? (read-password-cache))
      (cond
        [(and denied?
              (access-denied? method path (request-headers/raw req) denied?))
         => (lambda (realm)
              (adjust-connection-timeout! conn password-connection-timeout)
              (request-authentication conn method uri
                                      authentication-responder
                                      realm))]
        [(string=? "/conf/refresh-passwords" path)
         ;; more here - send a nice error page
         (update-password-cache!)
         (output-response/method
          conn
          (passwords-refresh-responder)
          method)]
        [else
         (next-dispatcher)])))
  
  ;; ****************************************
  ;; ****************************************
  ;; ACCESS CONTROL
  
  ;; pass-entry = (make-pass-entry str regexp (list sym str))
  (define-struct pass-entry (domain pattern users))
  
  ;; access-denied? : Method string x-table denied? -> (or/c false str)
  ;; denied?: str sym str -> (or/c str #f)
  ;; the return string is the prompt for authentication
  (define (access-denied? method uri-str headers denied?)
    (define user-pass (extract-user-pass headers))
    (if user-pass
        (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
        (denied? uri-str fake-user "")))
  
  (define-struct (exn:password-file exn) ())
  
  ;; : host -> (str sym str -> (or/c str #f))
  ;; to produce a function that checks if a given url path is accessible by a given user with a given
  ;; password.  If not, the produced function returns a string, prompting for the password.
  ;; If the password file does not exist, all accesses are allowed.  If the file is malformed, an
  ;; exn:password-file is raised.
  (define (read-passwords password-path)
    (with-handlers ([void (lambda (exn)
                            (raise (make-exn:password-file (string->immutable-string
                                                            (format "could not load password file ~a" password-path))
                                                           (current-continuation-marks))))])
      (let ([passwords
             (let ([raw (load password-path)])
               (unless (password-list? raw)
                 (raise "malformed passwords"))
               (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
                    raw))])
        
        ;; string symbol bytes -> (or/c #f string)
        (lambda (request-path user-name password)
          (ormap (lambda (x)
                   (and (regexp-match (pass-entry-pattern x) request-path)
                        (let ([name-pass (assq user-name (pass-entry-users x))])
                          (if (and name-pass
                                   (string=?
                                    (cadr name-pass)
                                    (bytes->string/utf-8 password)))
                              #f
                              (pass-entry-domain x)))))
                 passwords)))))
  
  (define fake-user (gensym))
  
  ;; password-list? : TST -> bool
  
{'fraction_non_alphanumeric': 0.13771099217785096, 'fraction_numerical': 0.0010292301358583778, 'mean_word_length': 1.7029207232267038, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 21, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6884217', 'n_tokens_mistral': 2672, 'n_tokens_neox': 2587, 'n_words': 700}