Script size: 19Kb Script date: 8-Jun-2023/20:17:38
#!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 "<" "&lt;" replace/all url ">" "&gt;" 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 "<" "&lt;" replace/all url ">" "&gt;" 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 "&nbsp;&nbsp;&nbsp;")
        | "[i]" (append msg-block "<i>")
        | "[/i]" (append msg-block "</i>")
        | "[b]" (append msg-block "<b>")
        | "[/b]" (append msg-block "</b>")
        | "<" (append msg-block "&lt;")
        | ">" (append msg-block "&gt;")
        | "é" (append msg-block "&eacute;")
        | "è" (append msg-block "&egrave;")
        | "à" (append msg-block "&agrave;")
        | 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



Powered by RebelBB and REBOL 2.7.8.4.2