suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

User registration moved from API backend to frontend, for spam prevention reasons

Browse Source
This commit is contained in:
Tony Garnock-Jones 2021-02-18 20:16:07 +01:00
parent aa95ca4fb8
commit 6d42a5ea87
7 changed files with 171 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
README.md
View File

@ -4,7 +4,9 @@
You will need to install the following Racket packages:
raco pkg install --skip-installed reloadable
raco pkg install --skip-installed \
https://github.com/racket/infrastructure-userdb.git#main \
reloadable
## Configuration
@ -50,6 +52,11 @@ Keys useful for deployment:
statically. The source file `static.rkt` in this codebase knows
precisely which files and directories within
`pkg-index-generated-directory` to upload to the final site.
- *user-directory*: directory containing the user database; should be
the same as `pkg-index` uses.
- *email-sender-address*: string; defaults to `pkgs@racket-lang.org`.
Used as the "from" address when sending authentication emails on
behalf of the server.
Keys useful for development:

2
configs/live.rkt
View File

@ -9,6 +9,8 @@
(format "file://~a/public_html/pkg-index-static/pkgs-all.json.gz" var)
'backend-baseurl "https://localhost:9004"
'pkg-index-generated-directory (build-path var "public_html/pkg-index-static")
'user-directory (build-path var "pkg-index/users.new")
'email-sender-address "The Racket Package Server <pkgs@racket-lang.org>"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To configure a split, S3-based setup, comment out the following lines:
;;

13
configs/pkgd.rkt
View File

@ -1,13 +0,0 @@
#lang racket/base
;; Configuration for pkgd
(require "../src/main.rkt")
(main (hash 'port 8444
'backend-baseurl "https://localhost:9004"
'package-index-url "file:///home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/pkgs-all.json.gz"
'static-output-type 'aws-s3
'aws-s3-bucket+path "pkgn.racket-lang.org/"
'dynamic-urlprefix "https://pkgd.racket-lang.org/pkgn"
'static-urlprefix "https://pkgn.racket-lang.org"
'dynamic-static-urlprefix "https://pkgn.racket-lang.org"
'pkg-index-generated-directory "/home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/"
))

3
configs/tonyg.rkt
View File

@ -9,6 +9,9 @@
'ssl? #f
'reloadable? #t
'package-index-url (format "file://~a/pkgs-all.json.gz" pkg-index-generated-directory)
'user-directory (build-path (find-system-path 'home-dir)
"src/pkg-index/official/root/users.new")
'email-sender-address "tonyg@racket-lang.org"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Either:
;;

43
src/html-utils.rkt
View File

@ -1,10 +1,13 @@
#lang racket/base
;; A utilities module :-/
(require web-server/servlet)
(provide maybe-splice
define-form-bindings)
define-form-bindings/xform
define-form-bindings
define-form-bindings/trim)
(require web-server/servlet)
(require (only-in racket/string string-trim))
;; Boolean XExpr ... -> (Listof XExpr)
;; Useful for optionally splicing in some contents to a list.
@ -12,22 +15,28 @@
(define-syntax-rule (maybe-splice guard contents ...)
(if guard (list contents ...) '()))
;; Extracts named single-valued bindings from the given request.
;; If a given binding is missing, the extracted value will be #f.
(define-syntax-rule (define-form-bindings req (specs ...))
(begin (define bs (request-bindings req))
(define-form-bindings* bs (specs ...))))
(define-syntax define-form-bindings*
(syntax-rules ()
[(_ bs ())
[(_ bs xform ())
(begin)]
[(_ bs ([name fieldname defaultval] rest ...))
[(_ bs xform ([name fieldname defaultval] rest ...))
(begin (define name (if (exists-binding? 'fieldname bs)
(extract-binding/single 'fieldname bs)
(xform (extract-binding/single 'fieldname bs))
defaultval))
(define-form-bindings* bs (rest ...)))]
[(_ bs ([name defaultval] rest ...))
(define-form-bindings* bs ([name name defaultval] rest ...))]
[(_ bs (name rest ...))
(define-form-bindings* bs ([name #f] rest ...))]))
(define-form-bindings* bs xform (rest ...)))]
[(_ bs xform ([name defaultval] rest ...))
(define-form-bindings* bs xform ([name name defaultval] rest ...))]
[(_ bs xform (name rest ...))
(define-form-bindings* bs xform ([name #f] rest ...))]))
;; Extracts named single-valued bindings from the given request.
;; If a given binding is missing, the extracted value will be #f.
(define-syntax-rule (define-form-bindings/xform req xform (specs ...))
(begin (define bs (request-bindings req))
(define-form-bindings* bs xform (specs ...))))
(define-syntax-rule (define-form-bindings req (specs ...))
(define-form-bindings/xform req values (specs ...)))
(define-syntax-rule (define-form-bindings/trim req (specs ...))
(define-form-bindings/xform req string-trim (specs ...)))

119
src/site.rkt
View File

@ -10,7 +10,7 @@
(require racket/match)
(require racket/format)
(require racket/date)
(require racket/string)
(require (only-in racket/string string-join string-split))
(require racket/port)
(require (only-in racket/list filter-map drop-right))
(require (only-in racket/exn exn->string))
@ -32,6 +32,7 @@
(require "package-source.rkt")
(require "http-utils.rkt")
(require "challenge.rkt")
(require "users.rkt")
(define static-urlprefix
(or (@ (config) static-urlprefix)
@ -358,38 +359,28 @@
(p ,error-message))))
,(form-group 4 5 (primary-button "Log in"))))))))
(define (authenticate-with-server! email password code)
(simple-json-rpc! #:sensitive? #t
#:include-credentials? #f
backend-baseurl
"/api/authenticate"
(hash 'email email
'passwd password
'code code)))
(define (create-session-from-authentication-success! email password success)
;; An "authentication success" is either #t, signalling a new user,
;; or a hash-table with interesting facts in it.
(define user-facts (cond [(eq? success #t) (hasheq)]
[(hash? success) success]
[else (log-warning "Bad auth success for user ~v: ~v" email success)
(hasheq)]))
(define (create-session-after-authentication-success! email password)
(define user-facts
(simple-json-rpc! #:sensitive? #t
#:include-credentials? #f
backend-baseurl
"/api/authenticate"
(hash 'email email
'passwd password)))
(when (not (hash? user-facts)) ;; Uh-oh. Something went wrong
(error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email))
(create-session! email password
#:curator? (if (hash-ref user-facts 'curation #f) #t #f)
#:superuser? (if (hash-ref user-facts 'superuser #f) #t #f)))
(define (process-login-credentials request)
(define-form-bindings request (email password))
(if (or (equal? (string-trim email) "")
(equal? (string-trim password) ""))
(login-form "Please enter your email address and password.")
(match (authenticate-with-server! email password "")
[(or "wrong-code" (? eof-object?))
(login-form "Something went awry; please try again.")]
[(or "emailed" #f)
(summarise-code-emailing "Incorrect password, or nonexistent user." email)]
[success
(create-session-from-authentication-success! email password success)])))
(define-form-bindings/trim request (email password))
(cond [(or (equal? email "") (equal? password ""))
(login-form "Please enter your email address and password.")]
[(not (login-password-correct? email password))
(login-form "Incorrect password, or nonexistent user.")]
[else
(create-session-after-authentication-success! email password)]))
(define (register-form #:email [email ""]
#:email_for_code [email_for_code ""]
@ -465,45 +456,38 @@
,(form-group 4 5 (primary-button "Continue")))))))))
(define (apply-account-code request)
(define-form-bindings request (email code password confirm_password))
(define-form-bindings/trim request (email code password confirm_password))
(define (retry msg)
(register-form #:email email
#:code code
#:step2-error-message msg))
(cond
[(equal? (string-trim email) "")
(retry "Please enter your email address.")]
[(equal? (string-trim code) "")
(retry "Please enter the code you received in your email.")]
[(not (equal? password confirm_password))
(retry "Please make sure the two password fields match.")]
[(equal? (string-trim password) "")
(retry "Please enter a password.")]
[else
(match (authenticate-with-server! email password code)
[(? eof-object?)
(retry "Something went awry. Please try again.")]
["wrong-code"
(retry "The code you entered was incorrect. Please try again.")]
[(or "emailed" #f)
(retry "Something went awry; you have been emailed another code. Please check your email.")]
[success
;; The email and password combo we have been given is good to go.
;; Set a cookie and consider ourselves logged in.
(create-session-from-authentication-success! email password success)])]))
[(equal? email "")
(retry "Please enter your email address.")]
[(equal? code "")
(retry "Please enter the code you received in your email.")]
[(not (equal? password confirm_password))
(retry "Please make sure the two password fields match.")]
[(equal? password "")
(retry "Please enter a password.")]
[(not (registration-code-correct? email code))
(retry "The code you entered was incorrect. Please try again.")]
[else
(register-or-update-user! email password)
(create-session-after-authentication-success! email password)]))
(define ((check-challenge challenge) request)
(define-form-bindings request (email_for_code question_answer))
(define-form-bindings/trim request (email_for_code question_answer))
(define (retry msg-a msg-b)
(register-form #:email_for_code email_for_code
#:step1a-error-message msg-a
#:step1b-error-message msg-b))
(cond
[(equal? (string-trim email_for_code) "")
[(equal? email_for_code "")
(log-info "REGISTRATION/RESET EMAIL: address missing")
(retry "Please enter your email address."
"Don't forget to answer the new question!")]
[(equal? (string-trim question_answer) "")
[(equal? question_answer "")
(log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
(retry #f
"Please answer the anti-spam question. (It changes each time!)")]
@ -523,21 +507,18 @@
(log-info " ✓ expected answer: ~v" (~a (challenge-answer challenge)))
(log-info " ✓ provided answer: ~v" question_answer)
(log-info " ✓ HTTP request details: ~v" request)
(authenticate-with-server! email_for_code "" "") ;; TODO check result?
(summarise-code-emailing "Account registration/reset code emailed" email_for_code)]))
(define (summarise-code-emailing reason email)
(with-site-config
(send/suspend/dispatch/dynamic
(lambda (embed-url)
(bootstrap-response reason
`(p
"We've emailed an account registration/reset code to "
(code ,email) ". Please check your email and then click "
"the button to continue:")
`(a ((class "btn btn-primary")
(href ,(embed-url (lambda (req) (register-form)))))
"Enter your code"))))))
(send-registration-or-reset-email! email_for_code)
(with-site-config
(send/suspend/dispatch/dynamic
(lambda (embed-url)
(bootstrap-response "Account registration/reset code emailed"
`(p
"We've emailed an account registration/reset code to "
(code ,email_for_code) ". Please check your email and then click "
"the button to continue:")
`(a ((class "btn btn-primary")
(href ,(embed-url (lambda (req) (register-form)))))
"Enter your code")))))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1324,7 +1305,7 @@
(define ((update-draft draft0) request)
(define draft (read-draft-form draft0 (request-bindings request)))
(define-form-bindings request (action new_version))
(define-form-bindings/trim request (action new_version))
(match action
["save_changes"
(if (save-draft! draft)
@ -1336,7 +1317,7 @@
draft))]
["add_version"
(cond
[(equal? (string-trim new_version) "")
[(equal? new_version "")
(package-form "Please enter a version number to add." draft)]
[(assoc new_version (draft-package-versions draft))
(package-form (format "Could not add version ~a, as it already exists." new_version)

82
src/users.rkt Normal file
View File

@ -0,0 +1,82 @@
#lang racket/base
;; User management - userdb, plus registration and emailing
(provide login-password-correct?
send-registration-or-reset-email!
registration-code-correct?
register-or-update-user!)
(require net/sendmail)
(require reloadable)
(require infrastructure-userdb)
(require "config.rkt")
(require "hash-utils.rkt")
(define-logger racket-pkg-website/users)
(define userdb (userdb-config (@ (config) user-directory)
#t ;; writeable!
))
(define *codes*
(make-persistent-state '*codes* (lambda () (make-registration-state))))
(define (login-password-correct? email given-password)
(log-racket-pkg-website/users-info "Checking password for ~v" email)
(user-password-correct? (lookup-user userdb email) given-password))
(define (send-registration-or-reset-email! email)
(if (user-exists? userdb email)
(send-password-reset-email! email)
(send-account-registration-email! email)))
(define (sender-address)
(or (@ (config) user-directory)
"pkgs@racket-lang.org"))
(define (send-password-reset-email! email)
(log-racket-pkg-website/users-info "Sending password reset email to ~v" email)
(send-mail-message
(sender-address)
"Account password reset for Racket Package Catalog"
(list email)
'()
'()
(list
"Someone tried to login with your email address for an account on the Racket Package Catalog, but failed."
"If this was you, please use this code to reset your password:"
""
(generate-registration-code! (*codes*) email)
""
"This code will expire, so if it is not available, you'll have to try again.")))
(define (send-account-registration-email! email)
(log-racket-pkg-website/users-info "Sending account registration email to ~v" email)
(send-mail-message
(sender-address)
"Account confirmation for Racket Package Catalog"
(list email)
'()
'()
(list
"Someone tried to register your email address for an account on the Racket Package Catalog."
"If you want to proceed, use this code:"
""
(generate-registration-code! (*codes*) email)
""
"This code will expire, so if it is not available, you'll have to try to register again.")))
(define (registration-code-correct? email given-code)
(log-racket-pkg-website/users-info "Checking registration code for ~v" email)
(check-registration-code (*codes*)
email
given-code
(lambda () #t)
(lambda () #f)))
(define (register-or-update-user! email password)
(log-racket-pkg-website/users-info "Updating user record ~v" email)
(save-user! userdb
(user-password-set (or (lookup-user userdb email)
(make-user email password))
password)))