radiofreqs/radiofreqs-signup-form
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity
master
radiofreqs-signup-form/signup-server.forth
nonlinear e4f011a147 update links
2019-06-09 03:14:10 +00:00

599 lines
18 KiB
Forth
Executable File
Raw Permalink Blame History

#!/usr/bin/env retro
Copyright 2019 Matthew Wishek
LICENSE: GPLv3
An HTML form processor written Retro, a dialect of Forth
(http://forth.works)
System configuration and template processing words.
~~~
'/var/www/htdocs 'WEBROOT s:const
'\_header.html s:format 'HEADER s:const
'\_footer.html s:format 'FOOTER s:const
~~~
Determine if a username is already registed on the system.
Uses the 'finger' command. Code provided by Charles Childers
and available on the Retro examples page
(http://forth.works/examples/unix-does-user-exist.forth.html)
~~~
:pipe> (s-s) file:R unix:popen [ file:read-line ] [ unix:pclose ] bi ;
{{
:command 'finger_%s_2>&1 s:format ;
:parse ASCII:SPACE s:tokenize ;
:login? #0 a:th fetch 'Login: s:eq? ;
---reveal---
:user:exists? (s-f)
&Heap [ command pipe> parse login? ] v:preserve ;
}}
~~~
LISP like `defstruct` function to create a data-structure
with and associated functions. Used as-is from examples
provided in the Retro distribution (http://forthworks.com/retro)
Used to store form fields and data.
~~~
{{
:make-helper (nsq-) [ d:create , ] dip does ;
:make-struct (ns-) d:create , [ here swap fetch allot ] does ;
---reveal---
:defstruct (sa-)
dup a:length
[ n:dec swap
[ 'ab 'aabab reorder
'@ s:append [ fetch + fetch ] make-helper
'! s:append [ fetch + store ] make-helper
n:dec
] a:for-each drop
] sip swap make-struct ;
}}
~~~
Storage for HTTP GET/POST header
~~~
'Requested d:create #8193 allot
'Host d:create #1025 allot
'Method d:create #1025 allot
'Contype d:create #129 allot
'Formdata d:create #8193 allot
~~~
Form field definition and initialization
~~~
'Fields d:create #129 allot
{ 'username
'email
'interests
'pubkey
'ham
'callsign } &Fields a:copy
'Form &Fields defstruct
&Fields [ [ s:empty s:keep &Form ] dip '! s:append s:evaluate ] a:for-each
'no s:keep &Form ham!
TRUE 'username-ok? var<n>
TRUE 'email-ok? var<n>
TRUE 'interests-ok? var<n>
TRUE 'pubkey-ok? var<n>
TRUE 'ham-ok? var<n>
TRUE 'callsign-ok var<n>
~~~
URL decoding
~~~
'rptr var
'wptr var
:get-next (-c)
@rptr fetch-next swap !rptr ;
:put-next (c-)
@wptr store-next !wptr ;
:c:hextodec (c-n)
dup c:digit? [ #48 - ] [ c:to-upper #55 - ] choose ;
:c:%decode (cc-c)
[ c:hextodec ] bi@ swap #16 * + ;
:decode-string [ get-next dup
[ $% [ drop get-next get-next c:%decode put-next FALSE ] case
$+ [ drop ASCII:SPACE put-next FALSE ] case
ASCII:NUL [ put-next TRUE ] case
drop put-next FALSE
] call
] until ;
:url-decode [ !rptr ] [ !wptr ] bi decode-string ;
~~~
Username field decoding and validation
~~~
'Forbidden d:create #1025 allot
'Forbidden-substrings d:create #1025 allot
{ '0x0
'abuse
'admin
'administrator
'autoconfig
'broadcasthost
'forum
'hostmaster
'localdomain
'localhost
'mailer-daemon
'marketing
'marketting
'noreply
'pop3
'postmaster
'radiofreqs
'radiofreq
'radioverse
'retro
'sales
'security
'smtp
'ssladmin
'ssladministrator
'sslwebmaster
'sysadmin
'usenet
'uucp
'webmaster
'www
'xmpp
'znc } &Forbidden-substrings a:copy
{ 'auth
'bbj
'chat
'cloud
'git
'gopher
'ftp
'imap
'info
'irc
'is
'isatap
'it
'jabber
'lounge
'mail
'mis
'news
'nobody
'noc
'pop
'radio
'retro
'root
'social
'team
'wpad } &Forbidden a:copy
FALSE 'valid var<n>
:username-too-long 'Username_is_too_long,_must_be_32_characters_or_less. '%s\n s:format ;
:username-not-alpha 'Username_is_invalid,_must_start_with_a_letter_and_contain_only_numbers_and_letters. '%s\n s:format ;
:username-not-allowed 'Username_is_reserved. '%s\n s:format ;
:username-exists 'Username_is_already_registered. '%s\n s:format ;
'Uname_error d:create #1025 allot
:username-error-msg &Uname_error swap s:append &Uname_error s:copy ;
:username-length? &Form username@ s:length #32 lteq? dup [ username-too-long username-error-msg ] -if ;
:username-first? &Form username@ fetch c:letter? !valid ;
:username-all?
username-first?
&Form username@ [ [ c:letter? ] sip c:digit? or &valid [ and ] v:update ] s:for-each
@valid [ username-not-alpha username-error-msg ] -if @valid ;
:username-allowed?
&valid v:on
&Forbidden-substrings [ s:to-upper &Form username@ s:to-upper swap s:contains-string? not &valid [ and ] v:update ] a:for-each
&Forbidden [ s:to-upper &Form username@ s:to-upper swap s:eq? not &valid [ and ] v:update ] a:for-each
@valid [ username-not-allowed username-error-msg ] -if @valid ;
:username-not-registered?
&Form username@ user:exists? not !valid
@valid [ username-exists username-error-msg ] -if @valid ;
:username-validate
&Form username@ url-decode
username-length?
username-all?
username-allowed?
username-not-registered? and and and !username-ok? ;
~~~
Email field decoding and validation
~~~
:email-too-long 'Email_address_is_too_long,_must_be_254_characters_or_less. '%s\n s:format ;
:email-required 'An_email_address_is_required. '%s\n s:format ;
:email-invalid 'The_supplied_email_address_is_invalid. '%s\n s:format ;
'Email_error d:create #1025 allot
:email-error-msg &Email_error swap s:append &Email_error s:copy ;
:email-length? &Form email@ s:length #254 lteq? dup [ email-too-long email-error-msg ] -if ;
:email-present? &Form email@ s:length #5 gt? dup [ email-required email-error-msg ] -if ;
:email-valid? &Form email@ $@ s:contains-char? dup [ email-invalid email-error-msg ] -if ;
:email-validate
&Form email@ url-decode
email-length?
email-present?
email-valid? and and !email-ok? ;
~~~
Interests field decoding and validation
~~~
:interests-validate
&Form interests@ url-decode ;
~~~
Public Key field decoding and validation
~~~
:pubkey-required 'An_SSH_pubkey_is_required. '%s\n s:format ;
:pubkey-invalid 'The_supplied_SSH_pubkey_is_invalid. '%s\n s:format ;
'Pubkey_error d:create #1025 allot
:pubkey-error-msg &Pubkey_error swap s:append &Pubkey_error s:copy ;
:pubkey-present? &Form pubkey@ s:length #0 gt? dup [ pubkey-required pubkey-error-msg ] -if ;
:pubkey-valid? &Form pubkey@ ASCII:SPACE s:tokenize #0 a:th fetch
[ 'ssh-rsa [ TRUE ] s:case
'ssh-ed25519 [ TRUE ] s:case
'ecdsa-sha2-nistp521 [ TRUE ] s:case
'ecdsa-sha2-nistp384 [ TRUE ] s:case
'ecdsa-sha2-nistp256 [ TRUE ] s:case
FALSE
] call ;
:pubkey-validate
&Form pubkey@ url-decode
pubkey-present?
pubkey-valid? and !pubkey-ok? ;
~~~
Ham field decoding and validation
~~~
:ham-validate ;
~~~
Callsign field decoding and validation
~~~
:callsign-validate ;
~~~
~~~
:a:href (ss-) '<a_href=" s:put s:put '"> s:put s:put
'</a> s:put ;
:p (q-) '<p_class=" s:put s:put '"> s:put call
'</p> s:put nl ;
:strong (q-) '<strong> s:put call '</strong> s:put ;
:em (q-) '<em> s:put call '</em> s:put ;
:h1 (s-) '<h1> s:put s:put '</h1> s:put ;
:div (q-) '<div> s:put call '</div> s:put nl ;
:body (q-) '<body> s:put call '</body> s:put nl ;
:br (-) '<br_/> s:put ;
:hr (-) '<hr_/> s:put ;
:table (q-) '<table> s:put nl call '</table> s:put nl ;
:tr (q-) '<tr> s:put call '</tr> s:put nl ;
:td (qs-) '<td_class=" s:put s:put
'"> s:put call '</td> s:put ;
:form (qs-) '<form_method="post"_action=" s:put s:put
'"> s:put nl call
'</form> s:put nl ;
:textinput (sss-) '<input_type="text"_name=" s:put s:put
'"_value=" s:put s:put
'"_placeholder=" s:put s:put
'"> s:put ;
:textarea (ssns-) '<textarea_name=" s:put s:put
'"_placeholder=" s:put s:put
'"_rows=" s:put n:put
'"_cols=""> s:put s:put
'</textarea> s:put ;
:radioinput (sssf-) '<input_type="radio"_id=" s:put s:put
'"_name=" s:put s:put
'"_value=" s:put s:put
'" s:put call s:put
'> s:put ;
:submit (-) '<input_type="submit"_name="submit"_value="Submit"> s:put ;
:reset (-) '<input_type="reset"_value="Nevermind"> s:put ;
:prefix:" s:keep &s:put compile:call ; immediate
~~~
~~~
:emit-form
[ 'Hello! h1 nl
[ 'Thank_you_for_your_interest_in_RadioFreqs.space._ s:put
'Please_fill_out_the_form_below_to_signup._ s:put
'We_will_send_you_an_email_once_your_account_is_ready. s:put ] s:empty p
[ [ [ 'Your_desired_username_(numbers_and_lowercase_letters_only,_no_spaces) s:put ] 'title td ] tr
@username-ok? [ [ [ &Uname_error s:put ] 'error td ] tr ] -if
[ [ 'username... &Form username@ 'username textinput ] 'form td ] tr
[ [ 'Email_account_to_contact_you_with_account_information s:put ] 'title td ] tr
@email-ok? [ [ [ &Email_error s:put ] 'error td ] tr ] -if
[ [ 'email... &Form email@ 'email textinput ] 'form td ] tr
[ [ 'What_interests_you_about_RadioFreqs.space? s:put ] 'title td ] tr
[ [ &Form interests@ #4 'interests... 'interests textarea ] 'form td ] tr
[ [ 'SSH_public_key_(Check_out_our_ s:put
'guide_to_SSH_keys 'https://wiki.radiofreqs.space/w/sshkeys a:href
'_if_you_don't_have_one.) s:put ] 'title td ] tr
@pubkey-ok? [ [ [ &Pubkey_error s:put ] 'error td ] tr ] -if
[ [ &Form pubkey@ #4 'ssh_public-key... 'pubkey textarea ] 'form td ] tr
[ [ 'Are_you_a_licensed_Amateur_Radio_Operator? s:put ] 'title td ] tr
[ [ [ [ @Form ham@ 'yes s:eq? [ 'checked ] [ s:empty ] choose ] 'yes 'ham 'option radioinput ] call '<label_for="option"><span><span></span></span>Yes</label> s:put ] 'form td ] tr
[ [ [ [ @Form ham@ 'yes s:eq? [ s:empty ] [ 'checked ] choose ] 'no 'ham 'option radioinput ] call '<label_for="option"><span><span></span></span>No</label> s:put ] 'form td ] tr
[ [ 'Amateur_radio_callsign s:put ] 'title td ] tr
[ [ 'callsign... &Form callsign@ 'callsign textinput ] 'form td ] tr
] table
[ [ submit reset ] 'center p ] div
[ 'Signing_up_implies_agreement_with_our_ s:put
'Code_of_Conduct 'https://wiki.radiofreqs.space/w/0-coc a:href
',_and_ s:put
'Terms_of_Service 'https://wiki.radiofreqs.space/w/1-tos a:href
'._Please_give_them_a_read. s:put nl ] '"" p
] '/signup form ;
:eqfilter
[ #61 -eq? ] s:filter ;
:field-store (ss-)
[ eqfilter s:keep &Form ] dip '! s:append s:evaluate ;
:display-data (-)
&Fields [ [ s:put sp &Form ] sip '@ s:append s:evaluate s:put nl ] a:for-each ;
~~~
~~~
:eol (-) ASCII:CR c:put ASCII:LF c:put ;
:get? (-f) &Method 'GET s:eq? ;
~~~
~~~
'Done var
:eot? (c-f)
dup
[ $& eq? ]
[ ASCII:CR eq? ]
[ ASCII:SPACE eq? ] tri or or
swap
ASCII:LF eq? or ;
:s:get_token (a-)
buffer:set [ c:get [ buffer:add ] [ eot? ] bi ] until
buffer:get drop ;
:read-request (-)
[ here s:get_token
here s:to-upper 'GET s:eq? [ &Requested s:get_token 'GET &Method s:copy &Done v:inc ] if
here s:to-upper 'POST s:eq? [ &Requested s:get_token 'POST &Method s:copy &Done v:inc ] if
here s:to-upper 'HOST: s:eq? [ &Host s:get_token &Done v:inc ] if
@Done #2 eq? ] until ;
:read-post (-)
#0 !Done
[ &Formdata s:get_token
&Formdata 'username s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
&Formdata 'email s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
&Formdata 'interests s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
&Formdata 'pubkey s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
&Formdata 'ham s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
&Formdata 'callsign s:begins-with? [ &Formdata $= s:split field-store &Done v:inc ] if
@Done #6 eq? ] until ;
~~~
~~~
:map-/-to-index (-)
&Requested '/ s:eq?
[ '/index.html &Requested s:copy ] if ;
:ensure-leading-/ (-)
@Requested $/ -eq?
[ '/ &Requested s:append s:keep &Requested s:copy ] if ;
:check-for-params (-)
&Requested $? s:contains-char?
[ &Requested $? s:split drop dup n:inc !GET-Query #0 swap store ] if ;
:filename (-s)
check-for-params map-/-to-index ensure-leading-/
'.html &Requested &Host WEBROOT '%s/%s%s%s s:format ;
~~~
~~~
:fileheader (-s)
HEADER &Host WEBROOT '%s/%s/%s s:format ;
:filefooter (-s)
FOOTER &Host WEBROOT '%s/%s/%s s:format ;
~~~
~~~
:404 'HTTP/1.1_404_OK s:put eol
'Content-type:_text/html s:put eol eol
'ERROR_404:_FILE_NOT_FOUND s:put eol
filename s:put eol ;
:200 'HTTP/1.1_200_OK s:put eol
'Content-type:_text/html s:put eol
'Cache-Control:_no-cache s:put eol eol ;
:send-header
fileheader [ s:put nl ] file:for-each-line ;
:send-footer
filefooter [ s:put nl ] file:for-each-line ;
:send-version
hr
[ 'Signup_Form_Version_1.0_-_Date_2019-06-05 s:put ] s:empty p ;
~~~
~~~
'mailpipe var
:getfield [ &Form ] sip '@ s:append s:evaluate ;
:send-email (-)
'nonlinear@radiofreqs.space 'RadioFreqs.space_Newuser_Signup 'mail_-s_"%s"_%s s:format file:W unix:popen !mailpipe
&Form username@ 'Username:_ '%s%s\n s:format [ @mailpipe file:write ] s:for-each
&Form email@ 'Email:_ '%s%s\n s:format [ @mailpipe file:write ] s:for-each
'Interests: '%s\n s:format [ @mailpipe file:write ] s:for-each
&Form interests@ '%s\n s:format [ @mailpipe file:write ] s:for-each
'Pubkey '%s\n s:format [ @mailpipe file:write ] s:for-each
&Form pubkey@ '%s\n s:format [ @mailpipe file:write ] s:for-each
&Form ham@ 'Ham:_ '%s%s\n s:format [ @mailpipe file:write ] s:for-each
&Form callsign@ 'Callsign:_ '%s%s\n s:format [ @mailpipe file:write ] s:for-each
@mailpipe unix:pclose ;
:send-ack
[ 'Thank_you_for_signing_up._We_notify_you_via_email_when_your_account_has_been_setup. s:put ] s:empty p
[ &Form username@ 'Username:_ '%s%s<br> s:format s:put nl
&Form email@ 'Email:_ '%s%s<br> s:format s:put nl
&Form interests@ 'Interests:_ '%s<br>%s<br> s:format s:put nl
&Form pubkey@ 'Pubkey:_ '%s<br>%s<br> s:format s:put nl
&Form ham@ 'Ham:_ '%s%s<br> s:format s:put nl
&Form callsign@ 'Callsign:_ '%s%s<br> s:format s:put nl
] s:empty p ;
~~~
~~~
:send-form (-)
200
send-header
emit-form
send-version
send-footer ;
:process-form (-)
&Fields [ '-validate s:append s:evaluate ] a:for-each ;
:form-ok? (-f) @username-ok? @email-ok? @pubkey-ok? and and ;
:send-response (-)
200
send-header
process-form
form-ok? [ send-email send-ack ] [ emit-form ] choose
send-version
send-footer ;
~~~
Test Code
```
'Testing s:put nl
'------- s:put nl nl
'URL_decode s:put nl
'------- s:put nl
'teststrings d:create #1024 allot
'testbuffer d:create #1024 allot
{ 'hello 'hello\%2C\%20world\%21 'non+linear\%21 } &teststrings a:copy
&teststrings [ s:format dup s:put s:keep '_->_ s:put
&testbuffer s:copy
&testbuffer url-decode
&testbuffer s:put nl
] a:for-each
nl
'Invalid_usernames s:put nl
'------- s:put nl
'usernames d:create #1024 allot
{ '\_uucp 'www 'www1 'mywww 'nonlinear\%21
'abcdefghijklmnopqrstuvwxyzabcdefg
'0name 'name.name 'name,name 'name:p s:empty } &usernames a:copy
&usernames [ s:format dup s:put sp s:keep
&Form username! username-validate
&Form username@ s:put sp
@username-ok? [ 'GOOD ] [ 'bad! ] choose
s:put nl ] a:for-each
nl
'Valid_usernames s:put nl
'------- s:put nl
{ 'myInformation
'abcdefghijklmnopqrstuvwxyzabcdef
'name0
'rooty } &usernames a:copy
&usernames [ s:format dup s:put sp s:keep
&Form username! username-validate
@username-ok? [ 'GOOD ] [ 'bad! ] choose
s:put nl ] a:for-each
nl
'Registered_usernames_(via_finger) s:put nl
'------- s:put nl
'heyme dup s:put sp user:exists? [ 'yes ] [ 'no ] choose s:put nl
'fakeuser dup s:put sp user:exists? [ 'yes ] [ 'no ] choose s:put nl
'root dup s:put sp user:exists? [ 'yes ] [ 'no ] choose s:put nl
'nonlinear dup s:put sp user:exists? [ 'yes ] [ 'no ] choose s:put nl
'nonlinear! dup s:put sp user:exists? [ 'yes ] [ 'no ] choose s:put nl
nl
'Email s:put nl
'------- s:put nl
{ 'example\%40example.com 'm@m.m 'hello\%20at\%20hello.com 'me@m.m s:empty 'example\%2Btest\%40example.com } &usernames a:copy
&usernames [ s:format dup s:put sp s:keep
&Form email! email-validate
&Form email@ s:put sp
@email-ok? [ 'GOOD ] [ 'bad! ] choose
s:put nl ] a:for-each
nl
'Pubkey s:put nl
'------- s:put nl
{ 'ssh-rsa+4rqjlakjlsdkfs+comment\%40comment
'ssh-dsa+4rqjlakjlsdkfsdfasdfgqert+comment\%40comment
s:empty } &usernames a:copy
&usernames [ s:format dup s:put sp s:keep
&Form pubkey! pubkey-validate
&Form pubkey@ s:put sp
@pubkey-ok? [ 'GOOD ] [ 'bad! ] choose
s:put nl ] a:for-each
bye
```
Service HTTP GET/POST from inetd
~~~
read-request
fileheader
filename
filefooter [ file:exists? ] tri@ and and
[ get? [ send-form ] [ read-post send-response ] choose ]
[ 404 ] choose
~~~
Reference in New Issue View Git Blame Copy Permalink