(module users mzscheme
(require "hwikireq.scm")
(require "config.scm")
(require "context.scm")
(provide users
user-name
user-account
user-pass
user-role)
(define (user-name u)
(user-account u))
(define (user-account u)
(car u))
(define (user-pass u)
(cadr u))
(define (user-role u)
(caddr u))
(def-class
(this (users context))
(supers)
(private
(define _paths (cfile context))
(define _users (list (list "admin" "admin" 'admin)))
(define (lock)
#t)
(define (unlock)
#t)
(define (load)
(let ((fh (with-handlers ((exn:fail? (lambda (exn) #f)))
(open-input-file (-> _paths filename 'admin "users")))))
(if (not (eq? fh #f))
(begin
(set! _users (read fh))
(close-input-port fh)))))
(define (save)
(let ((fh (open-output-file (-> _paths filename 'admin "users") 'replace)))
(write _users fh)
(close-output-port fh)))
)
(public
(define (set-user user pass role)
(lock)
(load)
(set! _users (cons (list user pass role)
(letrec ((f (lambda (users)
(if (null? users)
(list)
(if (string-ci=? user (caar users))
(f (cdr users))
(cons (car users) (f (cdr users))))))))
(f _users))))
(save)
(unlock))
(define (check user pass)
(load)
(letrec ((f (lambda (users)
(if (null? users)
'not-found
(if (string-ci=? user (caar users))
(if (string-ci=? pass (cadar users))
(caddar users)
'wrong-pass)
(f (cdr users)))))))
(f _users)))
(define (set-editor user pass)
(set-user user pass 'editor))
(define (set-admin user pass)
(set-user user pass 'admin))
(define (users)
(load)
_users)
(define (exists? name)
(letrec ((f (lambda (U)
(if (null? U)
#f
(if (string-ci=? name (user-name (car U)))
#t
(f (cdr U)))))))
(f (users))))
(define (set-pass name pass)
(letrec ((f (lambda (U)
(if (null? U)
(list)
(if (string-ci=? name (user-name (car U)))
(cons (list name pass (user-role (car U)))
(f (cdr U)))
(cons (car U) (f (cdr U))))))))
(set! _users (f (users)))
(save)))
(define (remove-user name)
(letrec ((f (lambda (U)
(if (null? U)
(list)
(if (string-ci=? name (user-name (car U)))
(f (cdr U))
(cons (car U) (f (cdr U))))))))
(set! _users (f (users)))
(save)))
)
(constructor)
)
)