#!reb278 -cs
REBOL [
title: "RebelBB"
purpose: "REBOL CGI to make a Bulletin Board."
license: "GNU GPL http://www.gnu.org/licenses/gpl.txt"
author: "Gregory Pecheret"
credits: {
Didier Cadieu, parser lecture-forum
Viktor Pavlu, cookies
RBBS http://www.rebol.com/docs/cgi-bbs.html, nice-date
}
;http://www.rebol.com/docs/cgi1.html
;http://www.rebol.com/docs/cgi2.html
;http://www.rebol.net/cookbook/recipes/0045.html
;http://www.codeconscious.com/rebol/rebol-net.html
]
do %rebelBB.config
; example of rebelBB.config file:
;config: context [
; key: "scramble"
; path-forum: %foo1
; path-backup: %foo2
;]
thread: context [
id:
title:
replies:
start:
end:
msgs: none
]
headers: copy []
threads: do read config/path-forum
set-thread-at: func [seq] [
thread/id: none
threads: head threads
all [
seq > 0
seq <= length? threads
thread/msgs: copy pick threads seq
thread/id: last thread/msgs
remove back tail thread/msgs
thread/title: last thread/msgs
remove back tail thread/msgs
thread/replies: length? thread/msgs
thread/start: copy last thread/msgs
remove back tail thread/start
thread/end: copy first thread/msgs
remove back tail thread/end
true
]
]
find-thread-id: func [id] [
while [not any [tail? threads equal? id last first threads]][threads threads: next threads]
]
set-thread-id: func [id] [
find-thread-id id
set-thread-at index? threads
]
lock: does [
while [exists? join config/path-forum %.lock][wait divide random 10 10]
write join config/path-forum %.lock ""
threads: do read config/path-forum
write/binary join config/path-backup rejoin parse to-string now/precise "-/:.+-" compress mold threads
]
unlock: does [
delete join config/path-forum %.lock
]
reply-thread: func [id usr msg /local _idx][
lock
find-thread-id id
set-thread-at _idx: index? threads
remove at threads _idx
insert/only thread/msgs reduce [now usr msg]
insert/only threads compose/deep [(thread/msgs) (thread/title) (thread/id)]
write config/path-forum mold threads
unlock
]
new-thread: func [usr title msg][
lock
insert/only threads compose/deep [[(now) (usr) (msg)] (title) (rejoin parse to-string now/precise "-/:.+-")]
write config/path-forum mold threads
unlock
]
set-headers: func [idx len] [
clear headers
loop len [
if set-thread-at idx [
append/only headers reduce [thread/id thread/title thread/replies thread/start thread/end]
]
idx: idx + 1
]
]
search-threads: func [pattern][
clear headers
while [not tail? threads][
thread/msgs: first threads
thread/id: last thread/msgs
remove back tail thread/msgs
thread/title: last thread/msgs
remove back tail thread/msgs
while [not any [tail? thread/msgs find third first thread/msgs pattern]][thread/msgs: next thread/msgs]
if not tail? thread/msgs [
append/only headers reduce [thread/id thread/title]
]
threads: next threads
]
]
set-cookie: func ["Sets a cookie" key [string!] value /expires "set expiration date" exp-date [date!]][
print rejoin [
"Set-Cookie: " key "=" trim value ";" ; why is there a space sometimes?
either expires [join " expires=" to-idate exp-date][""]
]
print ""
]
get-cookie: func ["Returns value of a cookie" name [string!]][
select parse to-string select system/options/cgi/other-headers "HTTP_COOKIE" ";=" name
]
session: context [
user: none
pass: none
ip: none
ip-cgi: none
set: func[][
people: load-people
sha1-pass: select people input/user
either all [sha1-pass equal? sha1-pass checksum/secure input/pass] [
user: input/user
set-cookie "session" enbase/base encloak mold compose [user: (input/user) pass: (input/pass) ip: (ip-cgi)] config/key 16
]
[reset/cookie]
]
reset: func/cookie][
user: pass: ip: none
if cookie [set-cookie "session" ""]
]
get: func[][
ip-cgi: system/options/cgi/remote-addr
if error? try [
do bind do decloak to-string debase/base get-cookie "session" 16 config/key 'user
if not equal? ip ip-cgi [user: pass: none]
]
[reset]
]
]
session/get
system/locale/days: ["Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"]
load-people: does [either exists? %people.dat [do load %people.dat][copy []]]
input: make object! [
user: "guest" ; user posting
pass: none ; user's password
subject: none ; thread subject
bla: none ; what the user says
submit: none ; value of user's command
tid: none ; thread ID to reply to
thread: none ; thread index to read
page: 1 ; page index
search: none ; search criteria
code: none ; display code if set
attempt [
switch system/options/cgi/request-method [
"POST" [
data: make string! 1020
buffer: make string! 16380
while [positive? read-io system/ports/input buffer 16380][
append data buffer
clear buffer
]
do bind decode-cgi data 'bla
]
"GET" [do bind decode-cgi system/options/cgi/query-string 'thread]
]
]
; added the following lines to make it works with xitami
; because xitami adds "^/"
attempt [replace tid "^/" ""]
attempt [replace submit "^/" ""]
]
input/page: to-integer input/page
; in order to handle everything within "switch"
if input/code [input/submit: "Code"]
if input/thread [
input/submit: "Pick"
; compatible with prior forum
if find input/thread #"<" [remove input/thread remove back tail input/thread]
]
print either find ["Logout" "SignIn"] input/submit ["Content-type: text/html"]["Content-type: text/html^/"]
html: context [
cgi: to-string last split-path system/options/script
title: "Forum REBOL"
cmd: "Refresh"
thread: none
colortype: none
id: none
subject: none
replies: none
user-first: none
user-last: none
date-first: none
date-last: none
who: none
when: none
what: none
qty: none
pages: none
user1: user2: user3: none
commands:
{<form method="POST" action=<%html/cgi%>>
<input type="SUBMIT" name="submit" value="<%html/cmd%>">
<%either session/user [{<input type="SUBMIT" name="submit" value="Post">}][{}]%>
<input type="text" name="search">
<input type="SUBMIT" name="submit" value="Search">
<input type="SUBMIT" name="submit" value="Help">
<input type="SUBMIT" name="submit" value="Members">
<input type="SUBMIT" name="submit" value=<%either session/user ["Logout"]["Login"]%>>
<b><%any [session/user ""]%></b>
</form>}
body:
{<html>
<head>
<title><%html/title%></title>
<style type="text/css">
body, p, td {font-family: arial, sans-serif, helvetica; font-size: 10pt; background-color:#E8E8E8;}
h1 {font-size: 14pt;}
h2 {font-size: 12pt; color: #2030a0; width: 100%; border-bottom: 1px solid #c09060;}
h3 {font-size: 10pt; color: #2030a0;}
tt {font-family: "courier new", monospace, courier; font-size: 9pt; color: darkgreen;}
pre {font: bold 10pt "courier new", monospace, console; background-color: #e0e0e0; padding: 16px; border: solid #a0a0a0 1px;}
.ligne0 {padding-left: 10px; padding-right: 7px; margin-left: 15px; background-color: black; color: white; font-weight: bold;}
.ligne1 {nowrap="nowrap" padding-left: 10px; padding-right: 7px; margin-left: 15px; background-color:#C8C8C8; color: black;}
.ligne2 {nowrap="nowrap" padding-left: 10px; padding-right: 7px; margin-left: 15px; background-color:#FAFAFA; color: black;}
.post_sujet {text-decoration: none; color:#000000; font-size:90%; font-weight: bold;}
</style>
</head>
<body>
<center>
<table>
<tr>
<td><img src="http://www.digicamsoft.com/rebelBB.jpg" border="0"></td>
<td>
<ul>
<li><a href="http://www.rebol.com" target="_blank">REBOL</a></li>
<li><a href="https://www.red-lang.org" target="_blank">Red Language</a></li>
<li><a href="https://github.com/rebol/rebol" target="_blank">Carl's Rebol3</a></li>
</ul>
</td>
<td>
<ul>
<li><a href="https://github.com/Oldes/Rebol3" target="_blank">Oldes' Rebol3</a></li>
<li><a href="https://www.atronixengineering.com/downloads" target="_blank">Atronix's Rebol3</a></li>
</ul>
</td>
</tr>
</table>}
pick:
{<tr><td class="ligne1" align="left"><b><%html/who%></b></td><td class="ligne1" align="right"><i><%html/when%></i></td></tr>
<tr><td class="ligne2" colspan="2"><%html/what%></td></tr>}
threads-hdr-page:
{<table border="0" cellspacing="0" cellpadding="0"><tr><td class="ligne0">TOPICS ( total: <%html/qty%> page: <%input/page%>/<%html/pages%> )</td><td class="ligne0">REPLIES</td><td class="ligne0" colspan="2">FIRST</td><td class="ligne0" colspan="2">LAST</td></tr>}
thread-line:
{<tr><td class="<%html/colortype%>"><a class="post_sujet" href="<%html/cgi%>?thread=<%html/id%>"><%html/subject%></a></td><td class="<%html/colortype%>"><%html/replies%></td><td class="<%html/colortype%>"><%html/user-first%></td><td class="<%html/colortype%>"><i><%html/date-first%></i></td><td class="<%html/colortype%>"><%html/user-last%></td><td class="<%html/colortype%>"><i><%html/date-last%></i></td></tr>}
threads-hdr-search:
{<table border="0" cellspacing="0" cellpadding="0"><tr><td class="ligne0">SEARCH FOR <%input/search%> (<%html/qty%> Results)</td></tr>}
thread-line-search:
{<tr><td class="<%html/colortype%>"><a class="post_sujet" href="<%html/cgi%>?thread=<%html/id%>"><%html/subject%></a></td></tr>}
reply:
{<br>
<form method="POST" action=<%html/cgi%>>
Reply: <br>
<textarea name="bla" rows="10" cols="60"></textarea>
<p>
<input type="SUBMIT" name="submit" value="Submit">
<input type="HIDDEN" name="tid" value="<%input/thread%>">
</form>}
post:
{<table width="80%"><tr><td>
<form method="POST" action=<%html/cgi%>>
Subject:<br>
<input type="TEXT" name="subject" size="40">
<p>
Message: <br>
<textarea name="bla" rows="10" cols="60"></textarea>
<p>
<input type="SUBMIT" name="submit" value="Submit">
</form>
</td></tr></table>}
login:
{<form method="POST" action=<%html/cgi%>>
Enter your name or nickname:<br>
<input type="TEXT" name="user" size="40">
<p>
Enter your password:<br>
<input type="PASSWORD" name="pass" size="40">
<p>
<input type="SUBMIT" name="submit" value="SignIn">
</form>
<br>
<br>
<hr>
Not a member? Click Members to register.}
people:
{<h2>Register</h2>
<form method="POST" action=<%html/cgi%>>
Enter your name or nickname:<br>
<input type="TEXT" name="user" size="40">
<p>
Enter your password:<br>
<input type="PASSWORD" name="pass" size="40">
<p>
<input type="SUBMIT" name="submit" value="Register">
</form>
<br>
<br>
<br>
<h2><%html/qty%> Members</h2>}
show-member:
{<tr><td><b><%html/user1%></b></td><td><b><%html/user2%></b></td><td><b><%html/user3%></b></td></tr>}
help:
{<h1>Help</h1>
<center><table cellspacing="4">
<tr><td>example</td><td>example</td></tr>
<tr><td>[b]example[/b]</td><td><b>example</b></td></tr>
<tr><td>[i]example[/i]</td><td><i>example</i></td></tr>
<tr><td>[code]print "Hello!"[/code]</td><td><pre>print "Hello!"</pre></td></tr>
<tr><td>:-)</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/003.gif" border="0"></td></tr>
<tr><td>:)</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/003.gif" border="0"></td></tr>
<tr><td>:-))</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/018.gif" border="0"></td></tr>
<tr><td>:))</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/018.gif" border="0"></td></tr>
<tr><td>:-(</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/016.gif" border="0"></td></tr>
<tr><td>;-)</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/dft012.gif" border="0"></td></tr>
<tr><td>;)</td><td><img src="http://www.digicamsoft.com/emoticons/Msn/dft012.gif" border="0"></td></tr>
<tr><td>http://www.rebol.com</td><td><a href="http://www.rebol.com">http://www.rebol.com</a></td></tr>
<tr><td>http://www.rebol.com/graphics/pwr-rebol100.gif</td><td><img src="http://www.rebol.com/graphics/pwr-rebol100.gif" border="0"></td></tr>
</table></center>}
sent:
{<h1>Message Posted!</h1>
<center><table width="80%" border="1"><tr><td><%html/what%></td></tr></table></center>}
auth-error:
{<b>
Wrong User/Password combination!<br>
Click on Members to register.
</b>}
end:
{<br><br>
<center><font color="#808080" size=1>Powered by <a href="<%html/cgi%>?code=1">RebelBB</a> and REBOL <%system/version%></font></center>
</body></html>}
]
render-msg: context [
msg-block: copy ""
process-url: func [txt /image /local t] [
t: copy txt
parse txt [["ftp." (insert t "ftp://") | "www." (insert t "http://")] to end]
either find [".jpeg" ".jpg" ".gif" ".png" ".bmp"] find/last txt "."
[rejoin [{<img src="} t {" border="0">}]]
[rejoin [{<a href="} t {" target="_blank">} txt {</a>}]]
]
;all-chars: exclude charset [#" " - #"^(FF)"] charset "[<"
all-chars: charset [#" " - #"^(FF)"]
non-white-space: complement charset " ^/^-^M<>"
to-space: [some non-white-space | end]
is-url: complement charset " ^/^-^M<>()"
end-url: [some is-url | end]
deb: fin: url: none
rules: [
"[code]" copy url to "[/code]" 7 skip (if error? try [replace/all url "<" "<" replace/all url ">" ">" append msg-block rejoin ["<pre>" url "</pre>"]][append msg-block "[code][/code]"])
| "[code]" copy url to "[code]" 6 skip (if error? try [replace/all url "<" "<" replace/all url ">" ">" append msg-block rejoin ["<pre>" url "</pre>"]][append msg-block "[code][/code]"])
;"[code]" copy url to "[/code]" 7 skip (if error? try [append msg-block color-code url] [append msg-block "[code][/code]"])
;| "[code]" copy url to "[code]" 6 skip (if error? try [append msg-block color-code url] [append msg-block "[code][code]"])
;| "[makedoc]" copy url to "[/makedoc]" 10 skip (append msg-block makedoc url)
| deb: ["http" opt "s" "://" | "www." | "ftp://" | "ftp." ] end-url fin: (append msg-block process-url copy/part deb fin)
| [":-))" | ":))"] (append msg-block {<img src="http://www.digicamsoft.com/emoticons/Msn/018.gif" border="0">})
| [":-)" | ":)"] (append msg-block {<img src="http://www.digicamsoft.com/emoticons/Msn/003.gif" border="0">})
| ":-(" (append msg-block {<img src="http://www.digicamsoft.com/emoticons/Msn/016.gif" border="0">})
| [";-)" | ";)"] (append msg-block {<img src="http://www.digicamsoft.com/emoticons/Msn/dft012.gif" border="0">})
| [crlf | cr | lf] (append msg-block "<br>")
| tab (append msg-block " ")
| "[i]" (append msg-block "<i>")
| "[/i]" (append msg-block "</i>")
| "[b]" (append msg-block "<b>")
| "[/b]" (append msg-block "</b>")
| "<" (append msg-block "<")
| ">" (append msg-block ">")
| "é" (append msg-block "é")
| "è" (append msg-block "è")
| "à" (append msg-block "à")
| deb: all-chars fin: (append msg-block copy/part deb fin)
]
process: func [data /local msg] [
clear msg-block
parse/all trim/head/tail data [some rules]
copy msg-block
]
]
nice-date: func [
"Convert date/time to a friendly format."
date [date!]
/local n day time diff
][
n: now
time: date/time
diff: n/date - date/date
if not day: any [
if diff < 2 [
time: difference n date
time/3: 0
return reform [time "hrs ago"]
]
if diff < 7 [pick system/locale/days date/weekday]
][
day: form date/date
if n/date/year = date/date/year [clear find/last day #"-"]
]
join day [" " time]
]
show-threads: func[] [
html/qty: length? threads
chunk: 30
html/pages: round/ceiling divide html/qty chunk
set-headers (chunk * (input/page - 1) + 1) chunk
print build-markup html/threads-hdr-page
color: 0
foreach hdr headers [
color: + 1 color
html/colortype: either even? color ["ligne1"]["ligne2"]
html/id: first hdr
html/subject: second hdr
html/replies: third hdr
html/date-first: nice-date first fourth hdr
html/user-first: second fourth hdr
html/date-last: nice-date first fifth hdr
html/user-last: second fifth hdr
print build-markup html/thread-line
]
print "</table>"
page: 1
loop html/pages [
print build-markup either = page input/page
[{<b><%page%></b>}]
[{<a href="<%html/cgi%>?page=<%page%>"><%page%></a>}]
page: + 1 page
]
]
switch/default input/submit [
"Pick" [
html/cmd: "Topics"
set-thread-id input/thread
html/title: thread/title
print build-markup html/body
print build-markup html/commands
print build-markup {<table width="80%" cellspacing="0" cellpadding="0"><tr><td class="ligne0" colspan="2" align="center"><b><%html/title%></b></td></tr>}
if thread/id [
foreach reply reverse thread/msgs [
html/when: first reply
html/who: second reply
html/what: render-msg/process third reply
print build-markup html/pick
]
]
print {<tr><td colspan="2">}
print either all [session/user thread/id] [build-markup html/reply]["<br><i>Login required to Post.</i>"]
print "</td></tr></table>"
]
"Post" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
print build-markup html/post
]
"Submit" [
html/cmd: "Topics"
either input/tid
[reply-thread input/tid session/user input/bla]
[new-thread session/user input/subject input/bla]
print build-markup html/body
print build-markup html/commands
html/what: render-msg/process input/bla
print build-markup html/sent
]
"Code" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
cgi-info: info? to-file html/cgi
print build-markup {<b>Script size:</b> <%to-integer divide cgi-info/size 1024%>Kb <b>Script date:</b> <%cgi-info/date%>}
print {<table><tr><td>}
do %color-code.r
print color-code read to-file html/cgi
print {</td></tr></table>}
]
"Help" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
print build-markup html/help
]
"Search" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
either empty? trim input/search [
show-threads
][
search-threads input/search
html/qty: length? headers
print build-markup html/threads-hdr-search
color: 0
while [not tail? headers] [
color: + 1 color
html/colortype: either even? color ["ligne1"]["ligne2"]
html/id: first first headers
html/subject: second first headers
print build-markup html/thread-line-search
headers: next headers
]
print "</table>"
]
]
"Members" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
people: sort/skip load-people 2
html/qty: divide length? people 2
print build-markup html/people
print "<table>"
foreach [name1 pass1 name2 pass2 name3 pass3] people [
html/user1: name1
html/user2: name2
html/user3: name3
print build-markup html/show-member
]
print "</table>"
]
"Login" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
print build-markup html/login
]
"Logout" [
session/reset/cookie
html/cmd: "Refresh"
print build-markup html/body
print build-markup html/commands
show-threads
]
;"SignIn" [
; session/set
; html/cmd: "Refresh"
; print build-markup html/body
; print build-markup html/commands
; either session/user [show-threads][print build-markup html/auth-error]
;]
"Register" [
html/cmd: "Topics"
print build-markup html/body
print build-markup html/commands
either equal? "" trim input/user [print "User name not valid..."]
[
people: sort/skip load-people 2
either find people input/user [
print "This user already exists!<br>"
][
print "You're now regitered!<br>"
append people input/user
append people checksum/secure input/pass
]
foreach [name pass] people [print name]
save %people.dat mold people
]
]
][ ; default behavior: shows messages
print build-markup html/body
print build-markup html/commands
show-threads
]
print build-markup html/end
|
