Artifact
79ed917ee51e326c32eee6441d053bd02bc27cba:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 20 6d 61 74 74 40 69 61 Welland. matt@ia
0030: 74 6f 61 2e 63 6f 6d 20 41 6c 6c 20 72 69 67 68 toa.com All righ
0040: 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b 20 ts reserved..;;
0050: 0a 3b 3b 20 6e 65 77 5f 61 63 63 6f 75 6e 74 2f .;; new_account/
0060: 63 6f 6e 74 72 6f 6c 2e 73 63 6d 0a 0a 28 6c 6f control.scm..(lo
0070: 61 64 20 28 73 3a 6d 6f 64 65 6c 2d 70 61 74 68 ad (s:model-path
0080: 20 22 70 65 72 73 6f 6e 22 29 29 0a 0a 28 64 65 "person"))..(de
0090: 66 69 6e 65 20 28 6e 65 77 5f 61 63 63 6f 75 6e fine (new_accoun
00a0: 74 3a 76 61 6c 69 64 61 74 65 2d 69 6e 70 75 74 t:validate-input
00b0: 73 20 70 61 73 73 77 6f 72 64 20 70 61 73 73 77 s password passw
00c0: 6f 72 64 2d 61 67 61 69 6e 20 65 6d 61 69 6c 2d ord-again email-
00d0: 61 64 64 72 65 73 73 20 65 6d 61 69 6c 2d 61 64 address email-ad
00e0: 64 72 65 73 73 2d 61 67 61 69 6e 29 0a 20 20 28 dress-again). (
00f0: 63 6f 6e 64 0a 20 20 20 28 28 6f 72 20 28 6e 6f cond. ((or (no
0100: 74 20 70 61 73 73 77 6f 72 64 29 28 6e 6f 74 20 t password)(not
0110: 70 61 73 73 77 6f 72 64 2d 61 67 61 69 6e 29 0a password-again).
0120: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 65 6d 61 (not ema
0130: 69 6c 2d 61 64 64 72 65 73 73 29 28 6e 6f 74 20 il-address)(not
0140: 65 6d 61 69 6c 2d 61 64 64 72 65 73 73 2d 61 67 email-address-ag
0150: 61 69 6e 29 29 0a 20 20 20 20 28 73 3a 73 65 74 ain)). (s:set
0160: 2d 65 72 72 20 22 46 6f 72 6d 20 69 73 20 69 6e -err "Form is in
0170: 63 6f 6d 70 6c 65 74 65 2e 20 50 6c 65 61 73 65 complete. Please
0180: 20 66 69 6c 6c 20 69 6e 20 61 6c 6c 20 66 69 65 fill in all fie
0190: 6c 64 73 20 61 6e 64 20 74 72 79 20 61 67 61 69 lds and try agai
01a0: 6e 22 29 0a 20 20 20 20 23 66 29 0a 20 20 20 28 n"). #f). (
01b0: 28 3c 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (< (string-lengt
01c0: 68 20 70 61 73 73 77 6f 72 64 29 20 32 29 0a 20 h password) 2).
01d0: 20 20 20 28 73 3a 73 65 74 2d 65 72 72 20 22 50 (s:set-err "P
01e0: 61 73 73 77 6f 72 64 20 69 73 20 74 6f 6f 20 73 assword is too s
01f0: 68 6f 72 74 2e 20 50 6c 65 61 73 65 20 74 72 79 hort. Please try
0200: 20 61 67 61 69 6e 22 29 0a 20 20 20 20 23 66 29 again"). #f)
0210: 0a 20 20 20 28 28 6e 6f 74 20 28 73 74 72 69 6e . ((not (strin
0220: 67 3d 3f 20 70 61 73 73 77 6f 72 64 20 70 61 73 g=? password pas
0230: 73 77 6f 72 64 2d 61 67 61 69 6e 29 29 0a 20 20 sword-again)).
0240: 20 20 28 73 3a 73 65 74 2d 65 72 72 20 22 50 61 (s:set-err "Pa
0250: 73 73 77 6f 72 64 73 20 64 6f 20 6e 6f 74 20 6d sswords do not m
0260: 61 74 63 68 2e 20 50 6c 65 61 73 65 20 74 72 79 atch. Please try
0270: 20 61 67 61 69 6e 22 29 0a 20 20 20 20 23 66 29 again"). #f)
0280: 0a 20 20 20 28 28 3e 20 28 73 74 72 69 6e 67 2d . ((> (string-
0290: 6c 65 6e 67 74 68 20 70 61 73 73 77 6f 72 64 29 length password)
02a0: 20 39 29 0a 20 20 20 20 28 73 3a 73 65 74 2d 65 9). (s:set-e
02b0: 72 72 20 22 50 61 73 73 77 6f 72 64 20 69 73 20 rr "Password is
02c0: 74 6f 6f 20 6c 6f 6e 67 2e 20 50 6c 65 61 73 65 too long. Please
02d0: 20 74 72 79 20 61 67 61 69 6e 22 29 0a 20 20 20 try again").
02e0: 20 23 66 29 0a 20 20 20 28 28 6e 6f 74 20 28 73 #f). ((not (s
02f0: 74 72 69 6e 67 3d 3f 20 65 6d 61 69 6c 2d 61 64 tring=? email-ad
0300: 64 72 65 73 73 20 65 6d 61 69 6c 2d 61 64 64 72 dress email-addr
0310: 65 73 73 2d 61 67 61 69 6e 29 29 0a 20 20 20 20 ess-again)).
0320: 28 73 3a 73 65 74 2d 65 72 72 20 22 45 6d 61 69 (s:set-err "Emai
0330: 6c 20 61 64 64 72 65 73 73 65 73 20 70 72 6f 76 l addresses prov
0340: 69 64 65 64 20 64 6f 20 6e 6f 74 20 6d 61 74 63 ided do not matc
0350: 68 2e 20 50 6c 65 61 73 65 20 74 72 79 20 61 67 h. Please try ag
0360: 61 69 6e 22 29 0a 20 20 20 20 23 66 29 0a 20 20 ain"). #f).
0370: 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 73 74 72 ((and (not (str
0380: 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 ing-match (regex
0390: 70 20 22 5e 5c 5c 73 2a 24 22 29 20 65 6d 61 69 p "^\\s*$") emai
03a0: 6c 2d 61 64 64 72 65 73 73 29 29 0a 20 20 20 20 l-address)).
03b0: 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e (not (strin
03c0: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
03d0: 22 5e 5b 5e 40 5d 2b 40 5b 5e 40 5d 2b 5c 5c 2e "^[^@]+@[^@]+\\.
03e0: 5b 5e 40 5d 2b 24 22 29 20 65 6d 61 69 6c 2d 61 [^@]+$") email-a
03f0: 64 64 72 65 73 73 29 29 29 0a 20 20 20 20 28 73 ddress))). (s
0400: 3a 73 65 74 2d 65 72 72 20 22 4e 6f 74 20 61 20 :set-err "Not a
0410: 76 61 6c 69 64 20 65 6d 61 69 6c 20 61 64 64 72 valid email addr
0420: 65 73 73 2c 20 70 6c 65 61 73 65 20 74 72 79 20 ess, please try
0430: 61 67 61 69 6e 22 29 0a 20 20 20 20 23 66 29 0a again"). #f).
0440: 20 20 20 28 65 6c 73 65 20 23 74 29 29 29 0a 0a (else #t)))..
0450: 28 64 65 66 69 6e 65 20 28 6e 65 77 5f 61 63 63 (define (new_acc
0460: 6f 75 6e 74 2d 61 63 74 69 6f 6e 20 61 63 74 69 ount-action acti
0470: 6f 6e 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 on). (case (str
0480: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 61 63 74 69 ing->symbol acti
0490: 6f 6e 29 0a 20 20 20 20 28 27 63 72 65 61 74 65 on). ('create
04a0: 0a 20 20 20 20 20 28 73 3a 6c 6f 67 20 22 47 6f . (s:log "Go
04b0: 74 20 68 65 72 65 2c 20 64 6f 69 6e 67 20 63 72 t here, doing cr
04c0: 65 61 74 65 20 6e 65 77 20 61 63 63 6f 75 6e 74 eate new account
04d0: 22 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 70 "). (let ((p
04e0: 61 73 73 77 6f 72 64 20 20 20 20 20 20 20 20 20 assword
04f0: 20 20 20 28 73 3a 67 65 74 2d 69 6e 70 75 74 20 (s:get-input
0500: 27 70 61 73 73 77 6f 72 64 29 29 0a 20 20 20 20 'password)).
0510: 20 20 20 20 20 20 20 28 70 61 73 73 77 6f 72 64 (password
0520: 2d 61 67 61 69 6e 20 20 20 20 20 20 28 73 3a 67 -again (s:g
0530: 65 74 2d 69 6e 70 75 74 20 27 70 61 73 73 77 6f et-input 'passwo
0540: 72 64 2d 61 67 61 69 6e 29 29 0a 20 20 20 20 20 rd-again)).
0550: 20 20 20 20 20 20 28 65 6d 61 69 6c 2d 61 64 64 (email-add
0560: 72 65 73 73 20 20 20 20 20 20 20 28 73 3a 73 74 ress (s:st
0570: 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 28 73 ring-downcase (s
0580: 3a 67 65 74 2d 69 6e 70 75 74 20 27 65 6d 61 69 :get-input 'emai
0590: 6c 2d 61 64 64 72 65 73 73 29 29 29 0a 20 20 20 l-address))).
05a0: 20 20 20 20 20 20 20 20 28 65 6d 61 69 6c 2d 61 (email-a
05b0: 64 64 72 65 73 73 2d 61 67 61 69 6e 20 28 73 3a ddress-again (s:
05c0: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
05d0: 28 73 3a 67 65 74 2d 69 6e 70 75 74 20 27 65 6d (s:get-input 'em
05e0: 61 69 6c 2d 61 64 64 72 65 73 73 2d 61 67 61 69 ail-address-agai
05f0: 6e 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 n)))). ;;
0600: 73 61 76 65 20 70 72 65 73 65 72 76 65 64 20 69 save preserved i
0610: 6e 70 75 74 73 0a 20 20 20 20 20 20 20 28 73 3a nputs. (s:
0620: 73 65 74 21 20 22 65 6d 61 69 6c 2d 61 64 64 72 set! "email-addr
0630: 65 73 73 22 20 65 6d 61 69 6c 2d 61 64 64 72 65 ess" email-addre
0640: 73 73 29 0a 20 20 20 20 20 20 20 28 73 3a 6c 6f ss). (s:lo
0650: 67 20 22 53 61 76 65 64 20 69 6e 70 75 74 73 2e g "Saved inputs.
0660: 20 4e 6f 77 20 63 68 65 63 6b 20 69 6e 70 75 74 Now check input
0670: 73 22 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 s"). (if (
0680: 6e 65 77 5f 61 63 63 6f 75 6e 74 3a 76 61 6c 69 new_account:vali
0690: 64 61 74 65 2d 69 6e 70 75 74 73 20 70 61 73 73 date-inputs pass
06a0: 77 6f 72 64 20 70 61 73 73 77 6f 72 64 2d 61 67 word password-ag
06b0: 61 69 6e 20 65 6d 61 69 6c 2d 61 64 64 72 65 73 ain email-addres
06c0: 73 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s .
06d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06e0: 20 20 20 20 20 20 20 20 20 20 20 65 6d 61 69 6c email
06f0: 2d 61 64 64 72 65 73 73 2d 61 67 61 69 6e 29 0a -address-again).
0700: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 47 72 ;; Gr
0710: 65 61 74 21 21 20 4e 6f 77 20 68 61 76 65 20 67 eat!! Now have g
0720: 6f 6f 64 20 69 6e 70 75 74 73 0a 20 20 20 20 20 ood inputs.
0730: 20 20 20 20 20 20 28 69 66 20 28 70 65 72 73 6f (if (perso
0740: 6e 3a 67 65 74 2d 64 61 74 20 65 6d 61 69 6c 2d n:get-dat email-
0750: 61 64 64 72 65 73 73 29 0a 09 20 20 20 20 20 20 address)..
0760: 20 28 73 3a 73 65 74 2d 65 72 72 20 22 54 68 65 (s:set-err "The
0770: 72 65 20 69 73 20 61 6c 72 65 61 64 79 20 61 6e re is already an
0780: 20 61 63 63 6f 75 6e 74 20 66 6f 72 20 74 68 61 account for tha
0790: 74 20 65 6d 61 69 6c 20 61 64 64 72 65 73 73 21 t email address!
07a0: 22 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 ").. (let
07b0: 28 28 70 64 61 74 20 28 70 65 72 73 6f 6e 3a 73 ((pdat (person:s
07c0: 65 74 2d 70 61 73 73 77 6f 72 64 20 65 6d 61 69 et-password emai
07d0: 6c 2d 61 64 64 72 65 73 73 20 70 61 73 73 77 6f l-address passwo
07e0: 72 64 29 29 29 0a 09 09 20 28 69 66 20 70 64 61 rd)))... (if pda
07f0: 74 0a 09 09 20 20 20 20 20 28 73 3a 73 65 74 2d t... (s:set-
0800: 65 72 72 20 22 53 55 43 43 45 53 53 21 21 20 59 err "SUCCESS!! Y
0810: 6f 75 20 63 61 6e 20 6e 6f 77 20 6c 6f 67 20 69 ou can now log i
0820: 6e 20 77 69 74 68 20 22 20 65 6d 61 69 6c 2d 61 n with " email-a
0830: 64 64 72 65 73 73 20 22 20 61 6e 64 20 79 6f 75 ddress " and you
0840: 72 20 70 61 73 73 77 6f 72 64 22 29 0a 09 09 20 r password")...
0850: 20 20 20 20 28 73 3a 73 65 74 2d 65 72 72 20 22 (s:set-err "
0860: 45 52 52 4f 52 21 21 20 55 6e 61 62 6c 65 20 74 ERROR!! Unable t
0870: 6f 20 61 75 74 6f 6d 61 74 69 63 61 6c 6c 79 20 o automatically
0880: 6c 6f 67 20 79 6f 75 20 6f 6e 20 77 69 74 68 20 log you on with
0890: 74 68 65 20 73 61 6d 65 20 63 72 65 64 65 6e 74 the same credent
08a0: 69 61 6c 73 20 75 73 65 64 20 74 6f 20 63 72 65 ials used to cre
08b0: 61 74 65 20 79 6f 75 72 20 61 63 63 6f 75 6e 74 ate your account
08c0: 2e 20 54 68 69 73 20 73 68 6f 75 6c 64 6e 27 74 . This shouldn't
08d0: 20 68 61 70 70 65 6e 2e 20 50 6c 65 61 73 65 20 happen. Please
08e0: 73 65 6e 64 20 65 6d 61 69 6c 20 74 6f 20 6d 61 send email to ma
08f0: 74 74 40 6b 69 61 74 6f 61 2e 63 6f 6d 20 61 62 tt@kiatoa.com ab
0900: 6f 75 74 20 74 68 69 73 22 29 29 29 29 0a 20 20 out this")))).
0910: 20 20 20 20 20 20 20 20 20 3b 3b 20 62 61 64 20 ;; bad
0920: 69 6e 70 75 74 73 0a 20 20 20 20 20 20 20 20 20 inputs.
0930: 20 20 23 66 29 29 29 0a 20 20 20 20 28 27 65 6c #f))). ('el
0940: 73 65 20 28 73 3a 6c 6f 67 20 22 50 6c 61 63 65 se (s:log "Place
0950: 68 6f 6c 64 65 72 20 66 6f 72 20 66 75 74 75 72 holder for futur
0960: 65 20 61 63 74 69 6f 6e 73 2e 20 53 68 6f 75 6c e actions. Shoul
0970: 64 6e 27 74 20 67 65 74 20 68 65 72 65 22 29 29 dn't get here"))
0980: 29 29 0a )).