<%@LANGUAGE="VBSCRIPT" CODEPAGE="1252"%> Sign Up <% ' URL Utility functions. ' Test Function sub testUrlFunctions RESPONSE.WRITE("
testUrlFunctions:") RESPONSE.WRITE("
curPageURL = " & curPageURL()) RESPONSE.WRITE("
curPageURLWithVariables = " & curPageURLWithVariables()) RESPONSE.WRITE("
curPageName = " & curPageName()) RESPONSE.WRITE("
curPageNameWithVariables = " & curPageNameWithVariables()) end sub ' Example: "http://www.coolbubble.com/test.asp" function curPageURL() dim s, protocol, port if Request.ServerVariables("HTTPS") = "on" then s = "s" else s = "" end if protocol = strleft(LCase(Request.ServerVariables("SERVER_PROTOCOL")), "/") & s if Request.ServerVariables("SERVER_PORT") = "80" then port = "" else port = ":" & Request.ServerVariables("SERVER_PORT") end if curPageURL = protocol & "://" & Request.ServerVariables("SERVER_NAME") &_ port & Request.ServerVariables("SCRIPT_NAME") end function ' Example: "http://www.coolbubble.com/test.asp?nick=10" function curPageURLWithVariables() dim url url = curPageURL() if Request.ServerVariables("QUERY_STRING") <> "" then url = url & "?" & Request.ServerVariables("QUERY_STRING") end if curPageURLWithVariables = url end function ' Example: "test.asp" function curPageName() dim pagename pagename = Request.ServerVariables("SCRIPT_NAME") if inStr(pagename, "/") > 0 then pagename = Right(pagename, Len(pagename) - instrRev(pagename, "/")) end if curPageName = pagename end function ' Example: "test.asp?nick=10" function curPageNameWithVariables() dim url url = curPageName() if Request.ServerVariables("QUERY_STRING") <> "" then url = url & "?" & Request.ServerVariables("QUERY_STRING") end if curPageNameWithVariables = url end function function strLeft(str1,str2) strLeft = Left(str1,InStr(str1,str2)-1) end function %> <% ' *** FUNCTIONS *** dim databasePassword databasePassword = "dbconnectpw1384" dim conn ' Some Site wide config variables. ' dim g_showComments const g_enableComments = true const g_sendMailNotificationOnNewComment = true const g_enableUrlInComments = true ' All connections to the database should be made through this function. function databaseConnect(s) set conn=s.CREATEOBJECT("ADODB.Connection") conn.Provider="Microsoft.Jet.OLEDB.4.0" conn.Open(s.Mappath("..\private\maindb_001.mdb")) 'conn.Open(s.Mappath("iis642\domains\c\coolbubble.com\user\private\maindb_001.mdb")) end function function databaseConnectFrom2Deep(s) set conn=s.CREATEOBJECT("ADODB.Connection") conn.Provider="Microsoft.Jet.OLEDB.4.0" conn.Open(s.Mappath("..\..\..\private\maindb_001.mdb")) 'conn.Open(s.Mappath("iis642\domains\c\coolbubble.com\user\private\maindb_001.mdb")) end function ' Returns a date string in the following format "Sun Nov 1, 21:17" function createDateString( in_date ) month_part = MONTHNAME(MONTH(in_date), True) day_part = WEEKDAYNAME(WEEKDAY(in_date), True) day_number_part = DAY(in_date) time_part = FORMATDATETIME(in_date,vbshorttime) createDateString = day_part & " " & month_part & " " & day_number_part & ", " & time_part end function ' Returns user name when passed the user id. function getNameFromID(user_id) rsname.Open "Select * FROM USERS where user_id = " & user_id , conn getNameFromID = rsname.Fields("user_name").value rsname.close end function ' Query if the currently logged in user can edit a post by the supplied user. function canEditPost(user_id) IF Session("logged_in")<>1 then ' Not logged in so can't edit post. canEditPost = 0 ELSE 'if Session("user_level=2") ' Logged in, is this the users post? IF Session("user_level") = 2 OR Session("user_id") = user_id then canEditPost = 1 end IF end IF end function ' Query if the currently logged in user can create a new post of any type (must be a moderator) function canCreateModPost() IF Session("logged_in")<>1 then ' Not logged in so can't edit post. canCreateModPost = 0 ELSE ' Logged in, is this the users post? IF Session("user_level") = 2 then canCreateModPost = 1 end IF end IF end function ' Sanatise text - make special characters safe for display. function convertSpecialCharacters(input_text) IF input_text <> empty then input_text = REPLACE(input_text, "<", "<") input_text = REPLACE(input_text, ">", ">") 'input_text = REPLACE(input_text, """, """") input_text = REPLACE(input_text, "&", "&") input_text = REPLACE(input_text, vbCrLf, "
") 'input_text = Replace(input_text, "java", "") 'input_text = Replace(input_text, "table", "") 'input_text = Replace(input_text, "form", "") 'input_text = Replace(input_text, "alert", "") 'input_text = Replace(input_text, "onclick", "") 'input_text = Replace(input_text, "style", "") 'input_text = Replace(input_text, "html", "") 'input_text = Replace(input_text, "body", "") end IF convertSpecialCharacters = input_text end function ' Convert dangerous characters to codes. function validateInput(input_text) input_text = REPLACE(input_text, "'", "'") ' Apostrophe input_text = REPLACE(input_text, vbCrLf, "
") validateInput = input_text end function ' Strip out angled brackets - used in post headers. ' also limits input to 255 chars function stripAngledBrackets(input_text) input_text = REPLACE(input_text, "<", "") input_text = REPLACE(input_text, ">", "") IF LEN(input_text) > 255 then input_text = LEFT(input_text,255) end IF stripAngledBrackets = input_text end function sub drawHeader %> <% call insertGoogleAnalyticsCode end sub ' Called only from drawHeader sub insertGoogleAnalyticsCode %> <% end sub ' Checks for hit count on an entity. ' If update_log is 1, the hit count is increased by calling this function. function getEntityHitCount(entity_name, update_log) 'set rs = Server.CreateObject("ADODB.recordset") rs.Open "Select * FROM ENTITY_LOG WHERE entity_name = '" & entity_name & "'", conn hits = 0 IF not rs.EOF then hits = rs.Fields("hit_count").value rs.close ELSE hits = 0 rs.close ' Get new row id dim next_entity_id rs.Open "Select max(entity_id) FROM ENTITY_LOG", conn 'RESPONSE.WRITE("next_entity_id: " & rs.Fields(0).value & "
") next_entity_id = rs.Fields(0).value + 1 rs.close ' Need to create an entity row. sql = "INSERT INTO ENTITY_LOG " sql = sql & "VALUES (" & next_entity_id & ", '" & entity_name & "', 0, '" & DATE() & "', '0')" 'RESPONSE.WRITE("SQL: " & sql & "
") on error resume next conn.Execute sql IF err<>0 then 'RESPONSE.WRITE("
ERROR" & err.description) 'RESPONSE.WRITE("Error - couldn't create entity log.") ELSE 'RESPONSE.WRITE("Created new entity log.") end IF end IF ' Increase counter. IF update_log = 1 then sql = "UPDATE ENTITY_LOG SET hit_count = " & hits+1 & " where entity_name = '" & entity_name & "'" on error resume next conn.Execute sql IF err<>0 then 'Response.Write("
ERROR" & err.description) 'response.write("Error - couldn't create entity log.") ELSE 'response.write("Created new entity log.") end IF end IF ' Log referring URLS sPreviousURL = Request.ServerVariables("HTTP_REFERER") if sPreviousURL <> "" then call logReferringURL(sPreviousURL) end if getEntityHitCount = hits end function ' log a referring url. ' REFERRING_URL sub logReferringURL(referring_url) ' First detect any existing rows with the same URL. sql = "select * from REFERRING_URL" sql = sql & " where ru_url = '" & referring_url &"'" rsp.Open sql, conn if rsp.EOF then ' No row was found, insert a new row. rsp.close sql = "INSERT INTO REFERRING_URL (ru_url, ru_date, ru_count) " sql = sql & " values('" & referring_url & "', '" & now() & "', 1)" conn.Execute sql else dim ru_count ru_count = rsp.Fields("ru_count").value rsp.close sql = "UPDATE REFERRING_URL" sql = sql & " set ru_date = '" & now() & "', ru_count = " & ru_count+1 sql = sql & " where ru_url = '" & referring_url & "'" conn.Execute sql end if end sub ' Used for drawing posts on the main page etc. sub drawPost(post_id) dim editUrl dim permLinkUrl dim bodyFixed dim userName dim commentCount dim commentPlural dim sql ' Get count of comments linked to this post. sql = "Select count(*) as _count FROM COMMENTS where post_id = " & post_id sql = sql + " AND deleted = '0'" rsp.Open sql, conn commentCount = 0 commentCount = rsp.Fields("_count").value rsp.close ' Do mail sql select. rsp.Open "Select * FROM POSTS where post_id = " & post_id , conn 'rsname.Open "Select * FROM USERS where user_id = " & rsp.Fields("user_id").value , conn userName = getNameFromID(rsp.Fields("user_id").value) editUrl = "editpost.asp?post_id=" & post_id permLinkUrl = "index.asp?post_id=" & post_id bodyFixed = convertSpecialCharacters(rsp.Fields("body").value) ' Draw permlink icon and create the link. %> <% 'RESPONSE.WRITE(" ") RESPONSE.WRITE(rsp.Fields("heading").value & "" ) RESPONSE.WRITE("

" & bodyFixed & "

") %>
<% RESPONSE.WRITE(" posted by " & userName ) RESPONSE.WRITE(" on " & rsp.Fields("date_created").value) ' Display comment count and create the link. commentPlural = "" if commentCount <> 1 then commentPlural = "s" end if %>  <%RESPONSE.WRITE(commentCount & " comment" & commentPlural & " ") if canEditPost(rsp.Fields("user_id").value) = 1 then %> [edit] <% end if %>
<% rsp.close 'rsname.close end sub ' Draw an individual bookmark from a supplied post id. ' if shorten is 1 then don't draw description. sub drawBookmark(post_id, shorten) rsp.Open "Select * FROM POSTS where post_id = " & post_id , conn dim editUrl dim shortLinkUrl dim linkText editUrl = "editpost.asp?post_id=" & rs.Fields("post_id").value rsname.Open "Select * FROM USERS where user_id = " & rs.Fields("user_id").value , conn ' Shorten the display url if required. linkUrl = rs.Fields("heading").value shortLinkUrl = linkUrl if LEN(shortLinkUrl) > 20 then shortLinkUrl = LEFT(linkUrl,18) + "..." end if %>

<% RESPONSE.WRITE(shortLinkUrl) %><% if shorten <> 1 then RESPONSE.WRITE(" ?" & rs.Fields("body").value) %> ?<% RESPONSE.WRITE(" posted by " & rsname.Fields("user_name").value) RESPONSE.WRITE(" on " & rs.Fields("date_created").value) %> ? <% end if if canEditPost(rs.Fields("user_id").value) = 1 then %> ?[edit]<% end if %>

<% rsname.close rsp.close end sub ' Draw All comments for a given object id and object type sub drawComments(object_id, object_type) RESPONSE.WRITE("

Comments:") ' Create the recordset dim sql dim show_deleted ' Detect any null values that might cause the SQL to fail if object_id = "" then exit sub end if if canCreateModPost() = 1 then 'show_deleted = 1 show_deleted = 0 ' let's hide deleted ones for now end if ' construct the sql for non-deleted and all posts. if show_deleted = 0 then sql = "Select * FROM COMMENTS where post_id = " & object_id sql = sql & " AND parent_type='" & object_type & "'" sql = sql & " AND deleted='0'" sql = sql & " ORDER BY comment_id" else sql = "Select * FROM COMMENTS where post_id = " & object_id sql = sql & " AND parent_type='" & object_type & "'" sql = sql & " ORDER BY comment_id" end if rs.Open sql, conn ' Display message and exit if post does not exist. if rs.eof then RESPONSE.WRITE(" - No comments yet, why not post one!
") rs.close RESPONSE.WRITE("View all site comments
") exit sub end if dim count do until rs.EOF if count mod 2 = 0 then RESPONSE.WRITE("
") else RESPONSE.WRITE("
") end if call drawComment(rs.Fields("comment_id").value) RESPONSE.WRITE("
") count = count + 1 rs.MoveNext loop RESPONSE.WRITE("View all site comments
") rs.close end sub ' 2007.01.07 draw a comment given a comment id. sub drawComment(comment_id) rsp.Open "Select * FROM COMMENTS where comment_id = " & comment_id , conn RESPONSE.WRITE("

On " & createDateString(rsp.Fields("date_created").value)) RESPONSE.WRITE(" " & rsp.Fields("user_name").value & " wrote:") RESPONSE.WRITE("

" & rsp.Fields("body").value) if rsp.Fields("deleted").value = "1" then RESPONSE.WRITE("

COMMENT DELETED BY ADMIN") end if ' Draw button to allow admin user to delete this post. if canCreateModPost() = 1 then dim back_url back_url = curPageURLWithVariables() %>

<% end if if canCreateModPost() = 1 then dim delPostUrl delPostUrl = "action.asp?action=delete_comment&object_id=" & comment_id RESPONSE.WRITE("

DELETE POST") end if 'RESPONSE.WRITE("
?" & rsp.Fields("comment_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("post_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("user_id").value) 'RESPONSE.WRITE("
?" & rsp.Fields("user_name").value) 'RESPONSE.WRITE("
?" & rsp.Fields("body").value) 'RESPONSE.WRITE("
?" & createDateString(rsp.Fields("date_created").value)) 'RESPONSE.WRITE("
?" & rsp.Fields("deleted").value) rsp.close end sub ' 2007.01.07 Draw form used for submitting comments. ' if the global variable g_enableComments is false then it displays ' a message instead. sub drawCommentPostingForm(post_id, parent_type) dim back_url back_url = curPageURLWithVariables() if g_enableComments <> true then RESPONSE.WRITE("

Comment posting is currently disabled.") else RESPONSE.WRITE("

Post a comment:") %>

Name
Comment
<% end if end sub sub updateTagCountForAllTags dim sql sql = "Select distinct tag_string FROM TAGS" sql = sql & " where deleted <> '1' and object_type='IMAGE'" rs.Open sql, conn if rs.EOF then RESPONSE.WRITE("
updateTagCountForAllTags: No tags found.") rs.close exit sub end if do until rs.EOF call updateTagCount(rs.Fields("tag_string").value, "IMAGE") rs.MoveNext loop rs.close end sub sub updateTagCount(tag_string, object_type) dim sql sql = "SELECT count(tag_string) as tag_count FROM TAGS where tag_string='" & tag_string & "'" sql = sql & " and object_type='" & object_type & "'" 'RESPONSE.WRITE("
sql: " & sql) rsp.Open sql, conn if rsp.eof then 'RESPONSE.WRITE("
no Tags found for string:" & tag_string) rsp.close exit sub end if dim num_rows num_rows = rsp.Fields("tag_count").value 'RESPONSE.WRITE("
tag_count = " & rsp.Fields("tag_count").value & " for: " & tag_string) rsp.close ' Now determine if a row exists in TAG_COUNT for the tag. sql = "select 1 from TAG_COUNT where tag_string='" & tag_string & "'" sql = sql & " and object_type='" & object_type & "'" rsp.Open sql, conn dim row_exists if rsp.eof then RESPONSE.WRITE("
No TAG_COUNT row found for string:" & tag_string) row_exists = 0 else RESPONSE.WRITE("
TAG_COUNT row found for string:" & tag_string) row_exists = 1 end if rsp.close ' Update or insert tag count row. if row_exists = 0 then sql = "insert into TAG_COUNT (tag_string, object_type, tag_count)" sql = sql & " values ('" & tag_string & "','" & object_type & "'," & num_rows & ")" RESPONSE.WRITE("
SQL: " & sql) conn.Execute sql end if if row_exists = 1 then sql = "update TAG_COUNT set tag_count=" & num_rows sql = sql & " where tag_string='" & tag_string & "' and object_type='" & object_type & "'" RESPONSE.WRITE("
SQL: " & sql) conn.Execute sql end if 'insert into TAG_COUNT (tag_string, object_type, count) values ( 'imogen','IMAGE', 22) end sub %> <% ' Connect to database. 'set conn=Server.CreateObject("ADODB.Connection") 'conn.Provider="Microsoft.Jet.OLEDB.4.0" 'conn.Open(Server.Mappath("..\private\maindb.mdb")) ' Connect to database. call databaseConnect(SERVER) set rs = Server.CreateObject("ADODB.recordset") rs.Open "Select max(user_id)+1 FROM USERS", conn dim next_user_id next_user_id = rs.Fields(0).value dim apply rs.Close apply = int(Request.QueryString("apply")) 'Response.Write("apply is " & apply) ' Added 02.09.2006 dim ipAddress ipAddress = Request.ServerVariables("REMOTE_ADDR") 'Response.Write("

Address:

" & ipAddress) dim bannedIdDetected if ipAddress = "24.51.237.200" then bannedIdDetected = 1 ' Hotbox spammer if ipAddress = "172.149.18.213" then bannedIdDetected = 1 ' Hotbox spammer if ipAddress = "195.225.177.137" then bannedIdDetected = 1 ' Yahoo spammer if ipAddress = "95.141.35.231" then bannedIdDetected = 1 ' ' NJD - 2010.02.19 if ipAddress = "91.201.66.76" then bannedIdDetected = 1 ' ' NJD - 2010.02.19 %> <% if apply <> 1 then if bannedIdDetected <> 1 then %>

Sign Up
User name:
Email address:

<% else ' banned IP address detected Response.Write("

Adr

" ) end if else dim bannedStringFound dim emptyStringRecieved dim password dim email dim username dim user_level dim userAvailable randomize ' randomize the generator. ' Generate random initial password. password = Int(1234 + (Rnd(1) * 7000) ) user_id = next_user_id username = Request.Form("username_b") email = Request.Form("email_b") ' Check for banned strings in email ' Added 31.08.2006 - NJD if InStr(email,"hotbox") <> 0 then bannedStringFound = 1 if InStr(email,"email@gmail.com") <> 0 then bannedStringFound = 1 ' Check for a field being blank, in which case we display nothing - ' to prevent annoying spam emails. if email = "" or username = "" then emptyStringRecieved = 1 ' Set default initial user data. user_level = 1 date_created = date() notes = "no description" ' Detect if a user with the same name exists in the DB rs.Open "Select * FROM USERS WHERE user_name = '" & username & "'", conn if rs.EOF then userAvailable = 1 if emptyStringRecieved = 1 then ' do nothing elseif userAvailable and bannedStringFound = 0 then ' No records found - username is unique ' Create the user sql = "INSERT INTO USERS " sql = sql & "VALUES (" & user_id & ",'" & username & "','" & password & "'," & user_level & "," sql = sql & "'" & date_created & "', 'no details', '0','" & email & "' )" ' Debug output - security risk, dont display if 1=2 then Response.Write ("sql statement: " & sql) end if %>
<% on error resume next conn.Execute sql,recaffected dim send_mail send_mail=1 ' Debug output - security risk, dont display if 1=2 then ' used to switch on debug output ' Debug version if err<>0 then Response.Write("
ERROR" & err.description) send_mail = 0 else Response.Write("

" & recaffected & " record edited

") end if else if err<>0 then Response.Write("

DATABASE ERROR

") send_mail = 0 else Response.Write("

user added...

") end if end if conn.close if send_mail = 1 then ' Send the mail Set myMail=CreateObject("CDO.Message") myMail.Subject="Coolbubble - sign up info." myMail.From="signup@coolbubble.com" myMail.To=email myMail.TextBody ="Thank you for signing up to coolbubble.com" & vbCrLf myMail.TextBody = myMail.TextBody + "Username: " & username & vbCrLf myMail.TextBody = myMail.TextBody + "Password: " & password & vbCrLf & vbCrLf myMail.TextBody = myMail.TextBody + "Please sign in to change your password." & vbCrLf myMail.TextBody = myMail.TextBody + "~ Nick" & vbCrLf myMail.Send set myMail=nothing ' Send the mail to admin Set myMail=CreateObject("CDO.Message") myMail.Subject="Coolbubble - sign up info." myMail.From="signup@coolbubble.com" myMail.To="nick@coolbubble.com" myMail.TextBody ="Someone has signed up to coolbubble.com" & vbCrLf myMail.TextBody = myMail.TextBody + "Username: " & username & vbCrLf myMail.TextBody = myMail.TextBody + "email: " & email & vbCrLf myMail.TextBody = myMail.TextBody + "ip address: " & ipAddress & vbCrLf myMail.TextBody = myMail.TextBody + "~ Nick" & vbCrLf myMail.Send set myMail=nothing ' Display message Response.Write("An email has been sent to " & email & " thanks!" ) end if else ' Username is not unique - display an error message. Response.Write("

This user name already exists, please try another name.

") ' Send the mail to admin on fail Set myMail=CreateObject("CDO.Message") myMail.Subject="Coolbubble - REJECTED sign up info." myMail.From="signup@coolbubble.com" myMail.To="nick@coolbubble.com" myMail.TextBody ="Someone TRIED to signed up to coolbubble.com" & vbCrLf myMail.TextBody = myMail.TextBody + "Username: " & username & vbCrLf myMail.TextBody = myMail.TextBody + "email: " & email & vbCrLf myMail.TextBody = myMail.TextBody + "ip address: " & ipAddress & vbCrLf myMail.TextBody = myMail.TextBody + "~ Nick .. HAH!" & vbCrLf ' NJD 2011.03.11 - stopped sending these mails to me as it was annoying ' myMail.Send set myMail=nothing end if rs.close end if %>