#lang scheme/base

(require "util.scm"
         (planet "digest.ss" ("soegaard" "digest.plt" 1 2))
         "form.scm"
         "repository.scm"
         "record.scm"
         "web-support.scm"
         "closures.scm"
         "settings.scm"
         "session.scm")

(provide current-user
         logout-user!
         if-login
         get-user-rec
         unauthenticated-login!
         register-form
         welcome-message
         created-by?
         created-by-str
         stamp-user-on-rec!
         if-these-users
         )

(define-syntax if-these-users
  (syntax-rules ()
    ((_ usernames sesh
        then
        else)
     (let ((u (current-user sesh)))
       (if (aand u (rec-prop u 'username) (member it (map ->string usernames)))
           then
           else)))))

(define (stamp-user-on-rec! rec user)
  (rec-set-rec-prop! rec 'created_by user))

(define (get-user-rec username)
  (load-one-where `((type . user) (username . ,username))))

;; returns #f if there is no logged in user
(define (current-user sesh)
  (aand (session-get-val sesh 'logged_in_as)
        (load-rec it)))

(define (logout-user! sesh)
  (session-remove-entry! sesh 'logged_in_as))

;; be careful...no password required
(define (unauthenticated-login! user-rec sesh)
  (session-put-val! sesh 'logged_in_as (rec-id user-rec)))

;; returns a user-rec if successful; #f o/w
(define (authenticated-login! username password sesh)
  (aand (get-user-rec username)
        (and (string=? (md5 (string->bytes/utf-8 (string-append password
                                                                (rec-prop it 'salt))))
                       (rec-prop it 'hashed-pass))
             (begin (session-put-val! sesh 'logged_in_as (rec-id it))
                    it))))

(define-syntax if-login
  (syntax-rules ()
    ((_ sesh (user-iden) then else)
     (let ((user-iden (current-user sesh)))
       (if user-iden
           then
           else)))))

;; MMM any way to redirect back to the "current page" before the closure invocation?

(define (welcome-message sesh
                         #:redirect-to (url (setting *WEB_APP_URL*))
                         #:no-register (no-register #f)
                         #:on-login-success (on-login-success #f))
  (if-login sesh (u)
            `(group ,(format "Welcome, ~A " (rec-prop u 'username))
                    ,(web-link "Sign out" (body-as-url r =>
                                                       (logout-user! sesh)
                                                       (redirect-to url))))
            `(group ,(web-link "Sign in" (body-as-url r => (login-form sesh
                                                                       #:on-success
                                                                       on-login-success)))
                    ,@(splice-if
                       (not no-register)
                       `(group " or "
                               ,(web-link "Register"
                                          (body-as-url
                                           r =>
                                           (register-form sesh
                                                          #:redirect-to url))))))))

;; XXX what about a "group" function which is just well, you know...
  
(define (login-form sesh
                    #:redirect-to (url (setting *WEB_APP_URL*))
                    #:on-success (success-fn #f))
  (form '((username "Username" text) (password "Password" password))
        #:skip-save #t
        #:on-done (lambda (login-rec)
                    (aif (authenticated-login! (rec-prop login-rec 'username)
                                              (rec-prop login-rec 'password)
                                              sesh)
                         (if success-fn (success-fn it) (redirect-to url))
                         `(em "Bad login.")))))

(define (register-form sesh #:redirect-to (url (setting *WEB_APP_URL*)))
  (form '((username "Username" text) (password "Password" password)
          (retype-password "Re-type password" password))
        #:skip-save #t
        #:validate (lambda (reg-data)
                     (if (and (string=? (rec-prop reg-data 'password)
                                        (rec-prop reg-data 'retype-password)))
                         #f
                         "Passwords don't match."))
        #:on-done (cut make-fresh-user <> sesh url)))

;; XXX need to do validation here...build some in to the forms engine
(define (make-fresh-user user-reg-rec sesh redirect-to-url)
  (let* ((pass (rec-prop user-reg-rec 'password))
         (salt (random-key-string 20))
         (hashed-pass (md5 (string->bytes/utf-8 (string-append pass salt))))
         (new-user (fresh-rec-from-data `((type . user)
                                          (username . ,(rec-prop user-reg-rec 'username))
                                          (hashed-pass . ,hashed-pass)
                                          (salt . ,salt)))))
    (store-rec! new-user)
    (unauthenticated-login! new-user sesh)
    (redirect-to redirect-to-url)))

(define (created-by? rec user-rec)
  (aand (rec-prop rec 'created_by)
        (string=? it (rec-id user-rec))))

;; returns "" if no creator is available in the given rec.
(define (created-by-str rec)
  (aif (aand (rec-rec-prop rec 'created_by) (rec-prop it 'username))
       (format "by ~A" it)
       ""))