RunForum

=RunForum=

RunForum is a forum package written in RunBASIC. It is heavily influenced by the design of the forums at [|Joel On Software] as outlined in [|this article].

NOTE: This program requires RunBASIC V1.0.1 or greater.

user:NealCollins

Installation
The first time RunForum is run, it will create the required database and prompt you for some initial settings:


 * The Site Name
 * A short description of the site which will appear on the front page
 * The SMTP server used to send registration emails
 * The SMTP password if required
 * The email address used as the from address for emails generated by the forum software
 * The administrator's full name
 * The administrators email address
 * The administrators password

User Types
RunForum has 4 types of users:


 * PENDING - user has registered, but never logged on.
 * REGISTERED - a registered user
 * MODERATOR - this user can delete messages and topic
 * ADMINISTRATOR - this user can delete messages, topics, groups and users.

Source
code format="lb" ' RunForum ' By Neal Collins ' ' This code is public domain. '

Version$ = "1.4.2"

global Version$

Delim$ = chr$(4) ' Use EOT as delimiter as it should never appear in the data.

global Delim$

if Platform$ = "unix" then PathSeperator$ = "/" else PathSeperator$ = "\" end if

DatabaseDir$ = DefaultDir$ ' Directory where the database will be created

global DatabaseDir$, PathSeperator$, #db

' User Types AnonymousUser = 0 PendingUser = 1 RegisteredUser = 2 ModeratorUser = 3 AdminUser = 99

global AnonymousUser, PendingUser, RegisteredUser, AdminUser

' Site Globals SiteName$ = "" SiteDescription$ = "" SMTPHost$ = "" SMTPPassword$ = "" SiteEmail$ = "" SiteSalt$ = ""

global SiteName$, SiteDescription$, SMTPHost$, SMTPPassword$, SiteEmail$, SiteSalt$

' Other Globals CurrentPage$ = "" CurrentGroup$ = "" CurrentTopic$ = "" CurrentUser$ = "" CurrentEmail$ = "" CurrentWebsite$ = "" UserType = 0 LastLogin = 0 SearchText$ = ""

global CurrentPage$, CurrentGroup$, CurrentTopic$, CurrentUser$, CurrentEmail$, CurrentWebsite$, UserType, LastLogin, SearchText$

call setCSS on error goto [handleError] call createDatabase call loadSite

if SiteName$ = "" then [setup]

' ====================== ' USER INTERFACE ' ======================

[main]

errorMessage$ = ""

cls call heading

div body select case CurrentPage$ case "topics" gosub [topics] case "messages" gosub [messages] case "users" gosub [users] case else gosub [groups] end select end div

call footer

wait

end

' -- ' LOGIN PAGE ' --

[login] cls div dialog html " Login " if errorMessage$ = "" then email$ = "" else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Email Address: " textbox #email, email$ #email setfocus print div info print "Enter your email address or full name." end div print html " Password: " passwordbox #password, "" print : print link #lostPassword, "Forgot your password?", [lostPassword] print : print button #login, "Login", [checkPassword] print " "; button #cancel, "Cancel", [main] end div wait

[checkPassword] email$ = #email contents$ password$ = #password contents$

if email$ = "" then errorMessage$ = "Email Address is required." goto [login] end if

if password$ = "" then errorMessage$ = "Password is required." goto [login] end if

call connect #db execute("SELECT NAME, EMAIL, WEBSITE, USER_TYPE, LAST_LOGIN_DATE * 86400 + LAST_LOGIN_TIME FROM USERS WHERE (UPPER(EMAIL) = UPPER('" + escape$(email$) + "') OR UPPER(NAME) = UPPER('" + escape$(email$) + "')) AND PASSWORD = '" + escape$(encrypt$(password$)) + "'") if #db hasAnswer then result$ = #db nextRow$(Delim$) CurrentUser$ = myWord$(result$, 1, Delim$) CurrentEmail$ = myWord$(result$, 2, Delim$) CurrentWebsite$ = myWord$(result$, 3, Delim$) UserType = val(myWord$(result$, 4, Delim$)) LastLogin = val(myWord$(result$, 5, Delim$))

if UserType = PendingUser then #db execute("UPDATE USERS SET USER_TYPE = " + str$(RegisteredUser) + ", LAST_LOGIN_DATE = " + str$(date$("days")) + ", LAST_LOGIN_TIME = " + str$(myTime) + " WHERE UPPER(EMAIL) = UPPER('" + escape$(email$) + "')") UserType = RegisteredUser else #db execute("UPDATE USERS SET LAST_LOGIN_DATE = " + str$(date$("days")) + ", LAST_LOGIN_TIME = " + str$(myTime) + " WHERE UPPER(EMAIL) = UPPER('" + escape$(email$) + "')") end if   call disconnect else call disconnect errorMessage$ = "Login failed. Invalid email or password." goto [login] end if

goto [main]

' -- ' USERS PAGES ' --

[users] print "> "; link #groups, "Groups", [gotoGroups]

if UserType <> AdminUser then print : print div alert print "Access denied." end div return end if

html " Users: "

call connect #db execute("SELECT NAME, EMAIL, USER_TYPE, DATE_REGISTERED, TIME_REGISTERED, LAST_LOGIN_DATE, LAST_LOGIN_TIME FROM USERS ORDER BY NAME") if #db hasAnswer then html " " end if call disconnect

return

[userType] name$ = myWord$(EventKey$, 1, Delim$) userType = val(myWord$(EventKey$, 2, Delim$))

select case userType case PendingUser userType$ = "Pending" case RegisteredUser userType$ = "Registered" case ModeratorUser userType$ = "Moderator" case AdminUser userType$ = "Administrator" case else userType$ = "" end select

cls div dialog html " Change User Type " html " User Type: " radiogroup #type, "Pending, Registered, Moderator, Administrator", userType$ #type horizontal(1) print : print button #ok, "Ok", [okUserType] print " "; button #cancel, "Cancel", [main] end div wait

[okUserType] select case #type selection$ case "Pending" userType = PendingUser case "Registered" userType = RegisteredUser case "Moderator" userType = ModeratorUser case "Administrator" userType = AdminUser end select

call execute "UPDATE USERS SET USER_TYPE = " + str$(userType) + " WHERE NAME = '" + escape$(name$) + "'" goto [main]

[deleteUser] name$ = EventKey$ cls div warning html " Delete User " print "Are you sure you want to delete the user """; name$; """?" print button #ok, "Ok", [okDeleteUser] print " "; button #cancel, "Cancel", [main] end div

wait

[okDeleteUser] call execute "DELETE FROM USERS WHERE NAME = '" + escape$(name$) + "'" goto [main]

' -- ' USER SETTINGS PAGE ' --

[editUser] cls div dialog html " User Settings " if errorMessage$ = "" then email$ = CurrentEmail$ website$ = CurrentWebsite$ password$ = "" newPassword$ = "" repeatPassword$ = "" else div alert print errorMessage$ end div end if   html " Full Name: " print CurrentUser$ html " Email Address: " textbox #email, email$ #email setfocus print html " Website: " textbox #website, website$ print : print html " Current Password: " passwordbox #password, password$ print html " New Password: " passwordbox #newPassword, "" print html " Repeat Password: " passwordbox #repeatPassword, "" print : print button #login, "Ok", [okEditUser] print " "; button #cancel, "Cancel", [main] end div wait

[okEditUser] email$ = #email contents$ website$ = #website contents$ password$ = #password contents$ newPassword$ = #newPassword contents$ repeatPassword$ = #repeatPassword contents$

if email$ = "" then errorMessage$ = "Email Address is required." goto [editUser] end if

if newPassword$ <> repeatPassword$ then errorMessage$ = "New Password and Repeat Password do not match." goto [changePassword] end if

call connect if newPassword$ = "" then #db execute("UPDATE USERS SET EMAIL = '" + escape$(email$) + "', WEBSITE = '" + escape$(website$) + "' WHERE UPPER(EMAIL) = UPPER('" + escape$(CurrentEmail$) + "')") else #db execute("SELECT 'X' FROM USERS WHERE UPPER(EMAIL) = UPPER('" + escape$(CurrentEmail$) + "') AND PASSWORD = '" + escape$(encrypt$(password$)) + "'") if not(#db hasAnswer) then call disconnect errorMessage$ = "Current password is incorrect." goto [changePassword] end if

#db execute("UPDATE USERS SET EMAIL = '" + escape$(email$) + "', WEBSITE = '" + escape$(website$) + "', PASSWORD = '" + escape$(encrypt$(newPassword$)) + "' WHERE UPPER(EMAIL) = UPPER('" + escape$(CurrentEmail$) + "')") end if call disconnect

CurrentEmail$ = email$ CurrentWebsite$ = website$

cls div dialog html " User Settings Saved " print "Your changes have been saved." print link #continue, "Return to Forum", [main] end div wait

' -- ' LOST PASSWORD PAGE ' --

[lostPassword] cls div dialog html " Lost Password " print "Enter your email address. Your password will be reset and emailed to your email address." print if errorMessage$ = "" then email$ = "" else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Email Address: " textbox #email, email$ #email setfocus print div info print "Enter your email address or full name." end div print : print button #login, "Ok", [okLostPassword] print " "; button #cancel, "Cancel", [main] end div wait

[okLostPassword] email$ = #email contents$

if email$ = "" then errorMessage$ = "Email Address is required." goto [lostPassword] end if

call connect #db execute("SELECT EMAIL FROM USERS WHERE UPPER(NAME) = UPPER('" + escape$(email$) + "') OR UPPER(EMAIL) = UPPER('" + escape$(email$) + "')")

if not(#db hasAnswer) then call disconnect errorMessage$ = "Email Address not found." goto [lostPassword] end if

email$ = #db nextRow$("")

password$ = randomPassword$

#db execute("UPDATE USERS SET PASSWORD = '" + escape$(encrypt$(password$)) + "' WHERE UPPER(EMAIL) = UPPER('" + escape$(email$) + "')") call disconnect

smtpsender #smtp, SMTPHost$ #smtp password(SMTPPassword$) #smtp send(SiteEmail$, email$, SiteName$ + " Password Reset", "Your forum password has been reset to """ + password$ + """.")

cls div dialog html " Password Reset " print "Your password has been successfully reset. The new password has been emailed to you." print link #continue, "Return to Forum", [main] end div wait

[logout] CurrentUser$ = "" CurrentEmail$ = "" CurrentWebsite$ = "" UserType = AnonymousUser LastLogin = 0 goto [main]

' -- ' REGISTRATION PAGE ' --

[register] cls div dialog html " Register " if errorMessage$ = "" then name$ = "" email$ = "" else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Full Name: " textbox #name, name$ #name setfocus print html " Email Address: " textbox #email, email$ print : print button #login, "Ok", [newUser] print " "; button #cancel, "Cancel", [main] end div wait

[newUser] name$ = #name contents$ email$ = #email contents$

if name$ = "" then errorMessage$ = "Full Name is required." goto [register] end if

if email$ = "" then errorMessage$ = "Email is required." goto [register] end if

call connect #db execute("SELECT 'X' FROM USERS WHERE UPPER(EMAIL) = UPPER('" + escape$(email$) + "')") if #db hasAnswer then call disconnect errorMessage$ = "This email address has already been used!" goto [register] end if

password$ = randomPassword$

#db execute("INSERT INTO USERS (NAME, PASSWORD, EMAIL, WEBSITE, USER_TYPE, DATE_REGISTERED, TIME_REGISTERED) VALUES ('" + escape$(name$) + "','" + escape$(encrypt$(password$)) + "','" + escape$(email$) + "','" + escape$(website$) + "'," + str$(PendingUser) + "," + str$(date$("days")) + "," + str$(myTime) + ")")

call disconnect

smtpsender #smtp, SMTPHost$ #smtp password(SMTPPassword$) #smtp send(SiteEmail$, email$, SiteName$ + " Registration", "Your forum account has been created. Please login using the email address: """ + email$ + """ and password: """ + password$ + """.")

cls div dialog html " Registration Complete " print "Your forum password has been emailed to "; email$; "." print link #login, "Login", [login] print " "; link #continue, "Return to Forum", [main] end div

wait

' -- ' GROUPS PAGE ' --

[groups] call renderMessage SiteDescription$ print html " Groups: "

call connect #db execute("SELECT NAME, DESCRIPTION FROM GROUPS ORDER BY NAME") if #db hasAnswer then html " " end if call disconnect

print if UserType = AdminUser then button #create, "New Group", [newGroup] print " "; button #site, "Site Settings", [site] print " "; button #users, "Manage Users", [gotoUsers] print end if

return

[selectGroup] CurrentGroup$ = EventKey$ CurrentPage$ = "topics" SearchText$ = "" goto [main]

' -- ' NEW GROUP PAGE ' --

[newGroup] cls div dialog html " Create a new group " if errorMessage$ = "" then name$ = "" desc$ = "" else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Group Name: " textbox #name, name$, 40 #name setfocus print html " Description: " textbox #desc, desc$, 80 print : print button #accept, "Ok", [okNewGroup] print " "; button #cancel, "Cancel", [main] end div wait

[okNewGroup] name$ = #name contents$ desc$ = #desc contents$

if name$ = "" then errorMessage$ = "Group Name is required." goto [newGroup] end if

call connect #db execute("SELECT 'X' FROM GROUPS WHERE UPPER(NAME) = UPPER('" + escape$(name$) + "')") if #db hasAnswer then call disconnect errorMessage$ = "A group with this name already exists! Please try another name." goto [newGroup] end if

#db execute("INSERT INTO GROUPS (NAME, DESCRIPTION) VALUES ('" + escape$(name$) + "','" + escape$(desc$) + "')") call disconnect

goto [main]

' -- ' EDIT GROUP PAGE ' --

[editGroup] name$ = myWord$(EventKey$, 1, Delim$) desc$ = myWord$(EventKey$, 2, Delim$) cls div dialog html " Edit Group " html " Group Name: " print name$ html " Description: " textbox #desc, desc$, 80 #desc setfocus print : print button #accept, "Ok", [okEditGroup] print " "; button #cancel, "Cancel", [main] end div wait

[okEditGroup] desc$ = #desc contents$

call execute "UPDATE GROUPS SET DESCRIPTION = '" + escape$(desc$) + "' WHERE NAME = '" + escape$(name$) + "'" goto [main]

' -- ' DELETE GROUP PAGE ' --

[deleteGroup] name$ = EventKey$ cls div warning html " Delete Group " print "Are you sure you want to delete the group """; name$; """ and all its messages?" print button #delete, "Ok", [okDeleteGroup] print " "; button #cancel, "Cancel", [main] end div wait

[okDeleteGroup] call connect #db execute("DELETE FROM MESSAGES WHERE GROUP_NAME = '" + escape$(name$) + "'") #db execute("DELETE FROM TOPICS WHERE GROUP_NAME = '" + escape$(name$) + "'") #db execute("DELETE FROM GROUPS WHERE NAME = '" + escape$(name$) + "'") call disconnect

goto [main]

' -- ' TOPICS PAGES ' --

[topics] print "> "; link #groups, "Groups", [gotoGroups] print " > "; CurrentGroup$;

div searchbox print "Search this group:" textbox #searchText, SearchText$ print " "; button #search, "Ok", [search] end div

html " " print CurrentGroup$; html " "

call connect #db execute("SELECT T.TOPIC, T.STARTED_BY, COUNT(*) - 1, MAX(M.DATE_POSTED * 86400 + M.TIME_POSTED) FROM TOPICS T, MESSAGES M WHERE T.GROUP_NAME = '" + escape$(CurrentGroup$) + "' AND M.TOPIC = T.TOPIC AND M.MESSAGE LIKE '%" + escape$(SearchText$) + "%' GROUP BY T.TOPIC, T.STARTED_BY ORDER BY 4 DESC") if #db hasAnswer then for i = 1 to #db rowcount result$ = #db nextrow$(Delim$) topic$ = myWord$(result$, 1, Delim$) startedBy$ = myWord$(result$, 2, Delim$) count$ = myWord$(result$, 3, Delim$) lastPost = val(myWord$(result$, 4, Delim$)) link #topic, topic$, [selectTopic] #topic setkey(topic$) html " " : print startedBy$; : html "" print " ("; count$; " comment";     if count$ <> "1" then print "s";      print ")"; if LastLogin <> 0 and lastPost > LastLogin then html " Updated " end if     ' print " Last updated "; date$(lastPostDate); if UserType = AdminUser or UserType = ModeratorUser then print" "; button #delete, "Delete Topic", [deleteTopic] #delete setkey(topic$) end if     print next i   print

end if call disconnect

button #create, "New Topic", [newTopic] print " "; button #groups, "Other Groups", [gotoGroups]

return

[search] SearchText$ = #searchText contents$ goto [main]

[selectTopic] CurrentTopic$ = EventKey$ CurrentPage$ = "messages" goto [main]

' -- ' NEW TOPIC PAGE ' --

[newTopic] cls div dialog html " New Topic " if errorMessage$ = "" then topic$ = "" message$ = "" name$ = CurrentUser$ email$ = CurrentEmail$ website$ = CurrentWebsite$ else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Subject: " textbox #topic, topic$, 40 #topic setfocus print html " Message: " textarea #message, message$, 80, 10 print div info print "Do not use any HTML formatting. URL's are recognised if surrounded by white space." end div print html " Full Name: " textbox #name, name$ print html " Email: " textbox #email, email$ print html " Website: " textbox #website, website$ print : print button #accept, "Ok", [okNewTopic] print " "; button #cancel, "Cancel", [main] end div wait

[okNewTopic] topic$ = #topic contents$ message$ = #message contents$ name$ = #name contents$ email$ = #email contents$ website$ = #website contents$

if topic$ = "" then errorMessage$ = "Subject is required." goto [newTopic] end if

if message$ = "" then errorMessage$ = "Message is required." goto [newTopic] end if

call connect #db execute("SELECT * FROM TOPICS WHERE UPPER(TOPIC) = UPPER('" + escape$(topic$) + "') AND GROUP_NAME = '" + escape$(CurrentGroup$) + "'") if #db hasAnswer then call disconnect errorMessage$ = "A topic on this subject already exists! Please enter different subject." goto [newTopic] end if #db execute("INSERT INTO TOPICS (TOPIC, GROUP_NAME, STARTED_BY) VALUES ('" + escape$(topic$) + "','" + escape$(CurrentGroup$) + "','" + escape$(name$) + "')") #db execute("INSERT INTO MESSAGES (GROUP_NAME, TOPIC, MESSAGE, POSTED_BY, EMAIL, WEBSITE, DATE_POSTED, TIME_POSTED) VALUES ('" + escape$(CurrentGroup$) + "','" + escape$(topic$) + "','" + escape$(message$) + "','" + escape$(name$) + "','" + escape$(email$) + "','" + escape$(website$) + "'," + str$(date$("days")) + "," + str$(myTime) + ")") call disconnect

CurrentTopic$ = topic$ CurrentPage$ = "messages"

goto [main]

' -- ' DELETE TOPIC PAGE ' --

[deleteTopic] topic$ = EventKey$ cls div warning html " Delete Topic " print "Are you sure you want to delete the topic """; topic$; """ and all its messages?" print button #delete, "Ok", [okDeleteTopic] print " "; button #cancel, "Cancel", [main] end div wait

[okDeleteTopic] call connect #db execute("DELETE FROM MESSAGES WHERE GROUP_NAME = '" + escape$(CurrentGroup$) + "' AND TOPIC = '" + escape$(topic$) + "'") #db execute("DELETE FROM TOPICS WHERE GROUP_NAME = '" + escape$(CurrentGroup$) + "' AND TOPIC = '" + escape$(topic$) + "'") call disconnect

goto [main]

' -- ' MESSAGES PAGES ' --

[messages] print "> "; link #groups, "Groups", [gotoGroups] print " > "; link #topics, CurrentGroup$, [gotoTopics] print " > "; CurrentTopic$;

html " " print CurrentTopic$; html " "

call connect #db execute("SELECT MESSAGE_ID, MESSAGE, POSTED_BY, EMAIL, WEBSITE, DATE_POSTED, TIME_POSTED FROM MESSAGES WHERE GROUP_NAME = '" + escape$(CurrentGroup$) + "' AND TOPIC = '" + escape$(CurrentTopic$) + "' ORDER BY DATE_POSTED, TIME_POSTED") if #db hasAnswer then for i = 1 to #db rowcount result$ = #db nextrow$(Delim$) messageId$ = myWord$(result$, 1, Delim$) message$ = myWord$(result$, 2, Delim$) postedBy$ = myWord$(result$, 3, Delim$) if postedBy$ = "" then postedBy$ = "Anonymous" email$ = myWord$(result$, 4, Delim$) website$ = myWord$(result$, 5, Delim$) datePosted = val(myWord$(result$, 6, Delim$)) timePosted = val(myWord$(result$, 7, Delim$)) div message call renderMessage message$ print div signature if website$ = "" then print postedBy$; else call renderLink website$, postedBy$ end if         print print date$(datePosted); " "; formatTime$(timePosted) end div print if UserType = AdminUser or UserType = ModeratorUser then button #delete, "Delete Message", [deleteMessage] #delete setkey(messageId$) print : print end if     end div next i   print end if call disconnect

button #create, "New Reply", [newReply] print " "; button #topics, "Other Topics", [gotoTopics]

return

' -- ' NEW REPLY PAGE ' --

[newReply] cls div dialog html " New Reply " if errorMessage$ = "" then message$ = "" name$ = CurrentUser$ email$ = CurrentEmail$ website$ = CurrentWebsite$ else div alert print errorMessage$ end div errorMessage$ = "" end if   html " Message: " textarea #message, message$, 80, 10 #message setfocus print div info print "Do not use any HTML formatting. URL's are recognised if surrounded by white space." end div print html " Full Name: " textbox #name, name$ print html " Email: " textbox #email, email$ print html " Website: " textbox #website, website$

print : print button #accept, "Ok", [okNewReply] print " "; button #cancel, "Cancel", [main] end div wait

[okNewReply] message$ = #message contents$ name$ = #name contents$ email$ = #email contents$ website$ = #website contents$

if message$ = "" then errorMessage$ = "Message is required." goto [newReply] end if

call execute "INSERT INTO MESSAGES (GROUP_NAME, TOPIC, MESSAGE, POSTED_BY, EMAIL, WEBSITE, DATE_POSTED, TIME_POSTED) VALUES ('" + escape$(CurrentGroup$) + "','" + escape$(CurrentTopic$) + "','" + escape$(message$) + "','" + escape$(name$) + "','" + escape$(email$) + "','" + escape$(website$) + "'," + str$(date$("days")) + "," + str$(myTime) + ")"

goto [main]

' -- ' DELETE MESSAGE PAGE ' --

[deleteMessage] messageId$ = EventKey$ call connect #db execute("SELECT MESSAGE FROM MESSAGES WHERE MESSAGE_ID = " + messageId$) if #db hasAnswer then message$ = #db nextRow$("") end if deleteTopic = 0 #db execute("SELECT COUNT(*) FROM MESSAGES WHERE GROUP_NAME = '" + escape$(CurrentGroup$) + "' AND TOPIC = '" + escape$(CurrentTopic$) + "'") if #db hasAnswer then if #db nextRow$("") = "1" then deleteTopic = 1 end if call disconnect

cls div warning html " Delete Message " print "Are you sure you want to delete the following message?" print div message call renderMessage message$ end div print button #delete, "Ok", [okDeleteMessage] print " "; button #cancel, "Cancel", [main] end div wait

[okDeleteMessage] if deleteTopic then topic$ = CurrentTopic$ CurrentPage$ = "topics" goto [okDeleteTopic] end if call execute "DELETE FROM MESSAGES WHERE MESSAGE_ID = " + messageId$ goto [main]

' -- ' SITE PAGE ' --

[site] cls div dialog html " Site Settings " if errorMessage$ = "" then name$ = SiteName$ desc$ = SiteDescription$ host$ = SMTPHost$ password$ = SMTPPassword$ email$ = SiteEmail$ else div alert print errorMessage$; end div errorMessage$ = "" end if   html " Site Name: " textbox #name, name$ print html " Description: " textarea #desc, desc$, 80, 10 print html " SMTP Host: " textbox #host, host$ print html " SMTP Password: " textbox #password, password$ print html " Site Email Address: " textbox #email, email$ print : print button #updateSite, "Ok", [updateSite] print " "; button #cancel, "Cancel", [main] end div wait

[updateSite] name$ = #name contents$ desc$ = #desc contents$ host$ = #host contents$ password$ = #password contents$ email$ = #email contents$

if name$ = "" then errorMessage$ = "Site Name is required." goto [site] end if

if host$ = "" then errorMessage$ = "SMTP Host is required." goto [site] end if

if email$ = "" then errorMessage$ = "Site Email Address is required." goto [site] end if

call execute "UPDATE SITE SET NAME='" + escape$(name$) + "',DESCRIPTION='" + escape$(desc$) + "',SMTP_HOST='" + escape$(host$) + "',SMTP_PASSWORD='" + escape$(password$) + "',EMAIL='" + escape$(email$) + "'"

SiteName$ = name$ SiteDescription$ = desc$ SMTPHost$ = host$ SMTPPassword$ = password$ SiteEmail$ = email$

goto [main]

[gotoGroups] CurrentPage$ = "groups" goto [main]

[gotoTopics] CurrentPage$ = "topics" goto [main]

[gotoUsers] CurrentPage$ = "users" goto [main]

[handleError] cls div warning html " Unexpected Error " print "An unexpected error has occured." print "Error: ("; Err; ") "; Err$ end div call disconnect end

' -- ' SETUP PAGE ' --

[setup] cls div dialog html " Site Setup " if errorMessage$ = "" then print "Welcome to the RunForum setup program. Please complete the following fields to setup your forum." print else div alert print errorMessage$; end div errorMessage$ = "" end if   html " Site Name: " textbox #siteName, siteName$ print html " Description: " textarea #siteDesc, siteDesc$, 80, 10 print html " SMTP Host: " textbox #smtpHost, smtpHost$ print html " SMTP Password: " textbox #smtpPassword, smtpPassword$ print html " Site Email Address: " textbox #siteEmail, siteEmail$ print : print html " Admin Full Name: " textbox #adminName, adminName$ print html " Admin Email Address: " textbox #adminEmail, adminEmail$ print html " Admin Password: " passwordbox #adminPassword, adminPassword$ print html " Repeat Password: " passwordbox #adminPassword2, adminPassword2$ print : print button #okUpdateSite, "Save Settings", [okSetup] end div wait

[okSetup] siteName$ = #siteName contents$ siteDesc$ = #siteDesc contents$ smtpHost$ = #smtpHost contents$ smtpPassword$ = #smtpPassword contents$ siteEmail$ = #siteEmail contents$ adminName$ = #adminName contents$ adminEmail$ = #adminEmail contents$ adminPassword$ = #adminPassword contents$ adminPassword2$ = #adminPassword2 contents$

if siteName$ = "" then errorMessage$ = "Site Name is required." goto [setupSite] end if

if smtpHost$ = "" then errorMessage$ = "SMTP Host is required." goto [setupSite] end if

if siteEmail$ = "" then errorMessage$ = "Site Email Address is required." goto [setupSite] end if

if adminName$ = "" then errorMessage$ = "Admin Full Name is required." goto [setupSite] end if

if adminPassword$ = "" then errorMessage$ = "Admin Password is required." goto [setupSite] end if

if adminPassword <> adminPassword2 then errorMessage$ = "Repeat Password is not the same as Admin Password." goto [setupSite] end if

SiteName$ = siteName$ SiteDescription$ = siteDesc$ SMTPHost$ = smtpHost$ SMTPPassword$ = smtpPassword$ SiteEmail$ = siteEmail$

SiteSalt$ = "" for i = 1 to 32 SiteSalt$ = SiteSalt$ + chr$(32 + rnd(1) * 94) next i

call connect

#db execute("INSERT INTO SITE (NAME, DESCRIPTION, SMTP_HOST, SMTP_PASSWORD, EMAIL, SALT) VALUES ('" + escape$(SiteName$) + "','" + escape$(SiteDescription$) + "','" + escape$(SMTPHost$) + "','" + escape$(SMTPPassword$) + "','" + escape$(SiteEmail$) + "','" + escape$(SiteSalt$) + "')")

#db execute("INSERT INTO USERS (NAME,PASSWORD,EMAIL,USER_TYPE,DATE_REGISTERED,TIME_REGISTERED) VALUES ('" + escape$(adminName$) + "','" + escape$(encrypt$(adminPassword$)) + "','" + escape$(adminEmail$) + "'," + str$(AdminUser) + "," + str$(date$("days")) + "," + str$(time$("seconds")) + ")")

call disconnect

goto [main]

' ====================== ' SUBROUTINES ' ======================

sub createDatabase ' Make sure database directory exists files #dir, DatabaseDir$ if not(#dir hasanswer) then a = mkdir(DatabaseDir$) end if

' Create site table if required if not(tableExists("SITE")) then call execute "CREATE TABLE SITE (NAME TEXT NOT NULL, DESCRIPTION TEXT, SMTP_HOST TEXT, SMTP_PASSWORD TEXT, EMAIL TEXT, SALT TEXT)" end if

' Create the users table if required if not(tableExists("USERS")) then call execute "CREATE TABLE USERS (NAME TEXT NOT NULL, PASSWORD TEXT, EMAIL TEXT NOT NULL UNIQUE, WEBSITE TEXT, USER_TYPE INTEGER, DATE_REGISTERED INTEGER, TIME_REGISTERED INTEGER, LAST_LOGIN_DATE INTEGER, LAST_LOGIN_TIME INTEGER)" end if

' Create the groups table if required if not(tableExists("GROUPS")) then call execute "CREATE TABLE GROUPS (NAME TEXT NOT NULL UNIQUE, DESCRIPTION TEXT)" end if

' Create the topics table if required if not(tableExists("TOPICS")) then call execute "CREATE TABLE TOPICS (TOPIC TEXT NOT NULL, GROUP_NAME TEXT NOT NULL, STARTED_BY TEXT)" end if

' Create the messages table if required if not(tableExists("MESSAGES")) then call execute "CREATE TABLE MESSAGES (GROUP_NAME TEXT NOT NULL, TOPIC TEXT NOT NULL, MESSAGE TEXT NOT NULL, POSTED_BY TEXT, EMAIL TEXT, WEBSITE TEXT, DATE_POSTED INTEGER, TIME_POSTED INTEGER, MESSAGE_ID INTEGER PRIMARY KEY AUTOINCREMENT)" end if end sub

sub renderMessage message$ inLink = 0 linkText$ = "" inMatch = 0

for i = 1 to len(message$) select case mid$(message$, i, 1) case chr$(13), chr$(10), " "

if inLink then html """>" x = instr(upper$(linkText$), upper$(SearchText$)) if x <> 0 then print left$(linkText$, x - 1); html " " print mid$(linkText$, x, len(SearchText$)); html " " print mid$(linkText$, x + len(SearchText$)); else print linkText$; end if       html "" inLink = 0

linkText$ = "" end if

if mid$(message$, i, 1) = chr$(13) then html " " if mid$(message$, i ,1) = " " then print " "; if lower$(mid$(message$, i + 1, 7)) = "http://" or lower$(mid$(message$, i + 1, 8)) = "https://" then inLink = 1 html " "" and upper$(mid$(message$, i, len(SearchText$))) = upper$(SearchText$) then inMatch = len(SearchText$) html " " end if     print mid$(message$, i, 1); end select next i if inMatch then html " " if inLink then html """>" x = instr(upper$(linkText$), upper$(SearchText$)) if x <> 0 then print left$(linkText$, x - 1); html " " print mid$(linkText$, x, len(SearchText$)); html " " print mid$(linkText$, x + len(SearchText$)); else print linkText$; end if   html "" end if end sub

sub heading

titlebar SiteName$

div heading html " " end div end sub

sub footer div footer print "Powered by RunForum "; Version$; " and "; call renderLink "www.runbasic.com", "RunBASIC" end div end sub

sub renderLink url$, tag$ if lower$(left$(url$, 7)) <> "http://" and lower$(left$(url$, 8)) <> "https://" then url$ = "http://" + url$ html "" print tag$; html "" end sub

sub loadSite call connect #db execute("SELECT NAME, DESCRIPTION, SMTP_HOST, SMTP_PASSWORD, EMAIL, SALT FROM SITE") if #db hasAnswer then result$ = #db nextRow$(Delim$) SiteName$ = myWord$(result$, 1, Delim$) SiteDescription$ = myWord$(result$, 2, Delim$) SMTPHost$ = myWord$(result$, 3, Delim$) SMTPPassword$ = myWord$(result$, 4, Delim$) SiteEmail$ = myWord$(result$, 5, Delim$) SiteSalt$ = myWord$(result$, 6, Delim$) end if call disconnect end sub

sub setCSS cssid #heading, "{ font-family: Arial, sans-serif; font-size: small; background: #CFC; border-bottom: 1px solid #898; padding: 8px 8px 2px 8px; margin-bottom: 4px; }" cssid #body, "{ font-family: Arial, sans-serif; font-size: small; white-space: normal; }" cssid #message, "{ padding-left: 2em; }" cssid #footer, "{ font-family: Arial, sans-serif; font-size: small; color: gray; border-top: 1px solid #898; text-align: center; margin-top: 4px; }" cssid #dialog, "{ font-family: Arial, sans-serif; font-size: small; background: #CFC; border-bottom: 1px solid #898; padding: 8px; float: left; display: block; width: 98%; }" cssid #warning, "{ font-family: Arial, sans-serif; font-size: small; background: #FF9999; border-bottom: 1px solid #CC3333; padding: 8px; white-space: normal; }" cssid #searchbox, "{ font-family: Arial, sans-serif; font-size: small; background: white; border: 1px solid #898; padding: 8px; float: right; }" cssid #alert, "{ color: red; font-weight: bold; padding-bottom: 8px; }" cssid #signature, "{ color: gray; font-style: italic; }" cssid #info, "{ padding-left: 144px; color: gray; font-size: 80%; }"

cssclass "span.updated", "{ color: green; font-style: italic; font-size: 80%; }" cssclass "span.match", "{ color: red; }" cssclass "label", "{ width: 140px; text-align: right; padding-right: 4px; display: block; float: left; }" cssclass "label.required:before", "{ content: ""* ""; color: red; font-weight: bold; }" cssclass "br", "{ clear: left; }" end sub

sub connect sqliteconnect #db, DatabaseDir$ + PathSeperator$ + "forum.db" end sub

sub disconnect #db disconnect end sub

sub execute sql$ call connect #db execute(sql$) call disconnect end sub

' ====================== ' FUNCTIONS ' ======================

function tableExists(tableName$) call connect #db execute("SELECT * FROM SQLITE_MASTER WHERE NAME = '" + escape$(tableName$) + "'") tableExists = #db hasanswer call disconnect end function

function escape$(string$) if instr(string$, "'") then for i = 1 to len(string$) if mid$(string$, i, 1) = "'" then escape$ = escape$ + "'" escape$ = escape$ + mid$(string$, i, 1) next i else escape$ = string$ end if end function

function formatTime$(t) hh = int(t / 3600) mm = int((t - hh * 3600) / 60) ss = t - (hh * 3600) - (mm * 60)

formatTime$ = str$(hh) + ":" + right$("0" + str$(mm), 2) + ":" + right$("0" + str$(ss), 2) end function

function randomPassword$ l = rnd(1) * 4 + 6 for i = 1 to l   randomPassword$ = randomPassword$ + chr$(rnd(1) * 26 + 65) next i end function

function myWord$(string$, n, delimiter$) myWord$ = word$(string$, n, delimiter$) if myWord$ = delimiter$ then myWord$ = "" end function

function myTime t$ = time$ myTime = val(word$(t$, 1, ":")) * 3600 + val(word$(t$, 2, ":")) * 60 + val(word$(t$, 3, ":")) end function

function encrypt$(password$)

M$ = SiteSalt$ + password$

N = len(M$)

r = 16 - (N mod 16) if r = 0 then r = 16

for i = 0 to r - 1 M$ = M$ + chr$(r) next i

N = N + r

dim S(255)

restore for i = 0 to 255 read S(i) next i

dim C(15)

L = 0

for i = 0 to N / 16 - 1 for j = 0 to 15 c = asc(mid$(M$, i * 16 + j + 1, 1)) C(j) = C(j) xor S(c xor L)     L = C(j) next j next i

for i = 0 to 15 M$ = M$ + chr$(C(i)) next i

N = N + 16

dim X(47)

for i = 0 to N / 16 - 1

for j = 0 to 15 X(16 + j) = asc(mid$(M$, i * 16 + j + 1, 1)) X(32 + j) = X(16 + j) xor X(j) next j

t = 0

for j = 0 to 17

for k = 0 to 47 t = X(k) xor S(t) X(k) = t     next k

t = (t + j) mod 256 next j next i

X$ = ""

for i = 0 to 15 X$ = X$ + right$("0" + dechex$(X(i)), 2) next i

encrypt$ = X$

data 41, 46, 67, 201, 162, 216, 124, 1, 61, 54, 84, 161, 236, 240, 6 data 19, 98, 167, 5, 243, 192, 199, 115, 140, 152, 147, 43, 217, 188 data 76, 130, 202, 30, 155, 87, 60, 253, 212, 224, 22, 103, 66, 111, 24 data 138, 23, 229, 18, 190, 78, 196, 214, 218, 158, 222, 73, 160, 251 data 245, 142, 187, 47, 238, 122, 169, 104, 121, 145, 21, 178, 7, 63 data 148, 194, 16, 137, 11, 34, 95, 33, 128, 127, 93, 154, 90, 144, 50 data 39, 53, 62, 204, 231, 191, 247, 151, 3, 255, 25, 48, 179, 72, 165 data 181, 209, 215, 94, 146, 42, 172, 86, 170, 198, 79, 184, 56, 210 data 150, 164, 125, 182, 118, 252, 107, 226, 156, 116, 4, 241, 69, 157 data 112, 89, 100, 113, 135, 32, 134, 91, 207, 101, 230, 45, 168, 2, 27 data 96, 37, 173, 174, 176, 185, 246, 28, 70, 97, 105, 52, 64, 126, 15 data 85, 71, 163, 35, 221, 81, 175, 58, 195, 92, 249, 206, 186, 197 data 234, 38, 44, 83, 13, 110, 133, 40, 132, 9, 211, 223, 205, 244, 65 data 129, 77, 82, 106, 220, 55, 200, 108, 193, 171, 250, 36, 225, 123 data 8, 12, 189, 177, 74, 120, 136, 149, 139, 227, 99, 232, 109, 233 data 203, 213, 254, 59, 0, 29, 57, 242, 239, 183, 14, 102, 88, 208, 228 data 166, 119, 114, 248, 235, 117, 75, 10, 49, 68, 80, 180, 143, 237 data 31, 26, 219, 153, 141, 51, 159, 17, 131, 20 end function code