rebol [
	Title: "Rebol Friendly Sites"
	File: %rebol-friendly-sites.r
	Date: 30-Aug-2006
	Version: 1.0.7
	Needs: [view]
	Author: "Anton Rolls"
	Language: 'English
	Purpose: {Show sites that are rebol friendly. ie. they allow rebol cgi's etc. With feedback comment mechanism.}
	Usage: {}
	History: [
		1.0.0 [13-Nov-2002 {First version} "Anton"]
		1.0.1 [14-Nov-2002 {added create-html, so we have only one source to change,
			copied standard-guis.r into the freezer} "Anton"]
		1.0.2 [7-Mar-2003 {added Hosting Viruale and upload buttons} "Anton"]
		1.0.3 [11-Apr-2003 {updated cniweb comment, new way of determining site and site-base,
			added fields for credentials at bottom} "Anton"]
		1.0.4 [11-Jul-2003 {added xpeers.net, neusteps.com} "Anton"]
		1.0.5 [21-Jul-2003 {added nebularis} "Anton"]
		1.0.6 [3-Oct-2005 {added 1and1.com, added ftp-site-base for uploading, updated feedback-email} "Anton"]
		1.0.7 [30-Aug-2006 {added lunarpages.com, replaced scrollpanel from standard-guis.r with my scroll-panel} "Anton"]
	]
	ToDo: {
	- remove or update feedback email address
	- remove or update the upload code
	- check free.prohosting	(see Carlos Lorenz email) not using BSDi anymore, but what?
	- status bar tells when file is being uploaded, success or not etc..
	  - errors should not be printed to console
	- pass field 'hide actually turns the string into asterisks (use face/data instead, I think)
	- resizeable window
	}
	Notes: {}
]

site: select load-thru http://www.rebol.net/reb/index.r [folder "Anton"]
clear find site %index.r
site-base: copy/part find/tail site http:// find site "rebol/"
ftp-site-base: to-url "www.lexicon.net/public_html/"

feedback-email: join to-email head reverse "@rnotna" "lexicon.net" ; <-- not included in the HTML

;do load-thru site/freezer/standard-guis.r
;do load-thru http://www.codeconscious.com/rebsite/rebol-library/standard-guis.r
do-thru site/library/include.r
include [site/gui/scroll-panel.r [scroll-panel-style]]
do load-thru site/freezer/form-error.r

html-file: %RebolFriendlySites.html
local-html-file: join %/D/Anton/Site/ html-file
public-html-url: join http:// [site-base html-file]

site-data: [

	"Lunarpages.com" http://lunarpages.com 30-Aug-2006
	{mentioned by Nick Antonaccio: "I've hosted a number of short CGI scripts on their servers. I'm not sure if there are any limitations, but everything I've tried there has worked without problems."}

	"" http://1and1.com 3-Oct-2005
	{mentioned by Graham "I uploaded it, chmoded it and it worked. that's how rebol.org gets it's mail feed ... from a rebol cgi script running on 1and1.com"}

	"Nebularis" http://www.nebularis.com/hosting.php 21-Jul-2003
	""

	;www.inflow.com
	; Ted Serpa's server equipment is there (He's open to the idea of IOS hosting)

	"neusteps" http://neusteps.com/ 12-Jul-2003
	"IOS Hosting"

	"xpeers.net" http://www.xpeers.net/ 11-Jul-2003 
	"Robert M. Muench - IOS hosting"
	
	"Hosting Virtuale" http://www.hostingvirtuale.com/english/rebol.php 7-Mar-2003
	"Gabriele Santilli (a big reboller) - IOS hosting"

	"DreamHost" http://www.dreamhost.com 12-Nov-2002 
	"I have a site served by dreamhost.com They are an excellent ISP who use suExec to make installation and CGI work very friendly. They start at $9.95/month. - Jason Cunliffe"

	"Xitami" http://www.xitami.com/ 12-Nov-2002
	"The Xitami web server is free and does Rebol CGI exactly like the examples in the Rebol documentation. - Andrew Martin"

	"Pacific.Net" http://www.pacific.net 20-Jul-2001
	"No direct support, but they have it installed and users"

	"Audiopia" http://www.audiopia.net/webcd "before May-2001" ""

	"HappySite" http://www.happysite.net "before May-2001"
	"Host to Allen Kamp's www.rebolforces.com They seem very rebolious."

	"" http://www.mersinet.co.uk "before May-2001"
	"Require local dial-in"

	"" http://www.cniweb.net "11-Apr-2003" {"...high praise ... They host rebol .... on Sun, Linux, NT." - Tim Johnson}

	"" http://www.e-domainsolutions.com "before May-2001" ""

	"" http://www.netisnet.co.uk  "before May-2001"
	"Allow rebol.exe in cgi-bin/ and telnet access"

	"" http://free.prohosting.com  "11-Apr-2003"
	{With popup banner window. "I have my site hosted at Prohosting. You upload rebol and use it (the BSDi version)." - Maarten Koopmans}

	"PowerWebs AB in Sweden" http://www.powerwebs.se/powerwebsab.asp "before May-2001" ""

	"ActiveHost Corporation (NY)" http://www.ntwebhosting.com/ "before May-2001" ""
]

create-html: func [
	"Formats site-data into a html document"
	data {pass site data here, in a block like this (one entry shown):
	[name [string!] url [url!] date [date! string!] note [string!]]}
	/local output
][
	output: make string! 1000

	; header part
	append output rejoin [
{
<html>
<head><title>Rebol friendly Sites</title></head>

<body>
<h1>Rebol Friendly Sites</h1>
version: } system/script/header/version { date: } now/date {
<hr>
...that people have mentioned on the rebol mail list.<br>
These sites allow running rebol on the server (as a cgi)<br>
If they do Rebol/IOS hosting (more powerful than cgi) it is mentioned specifically.<br> 
This document instanciated 29-Nov-2000, last update } now/date {
<p>
<table>
<tr><td>Site<td>Date<td>Notes

}
	]

	; the site-data
	foreach [name url date note] site-data [

		append output rejoin [
			{<tr><td><a href="} url {">} either empty? name [""][join name {<br>}] url "</a>^/"
			"<td>" date "^/"
			"<td>" note "^/^/"
		]
	]

	; tail part
	append output rejoin [
{</table>

<hr>

Disclaimer:
If you read this information and subsequently fall out
of a tree, it is not my fault.
<hr>

This document was generated by rebol. The rebol/view version which generates this html can probably be found at:<br>
<a href="} this-url: join site/doc ["/" system/script/header/file] {">} this-url {<a/>
</body>
</html>
}
	]
]

stylize/master [backdrop: backdrop 170.164.130]

feedback: func [
	"Pops up a window allowing you to edit and send a feedback email"
	url "site the feedback is about"
	/local message email-lay
][
	message: rejoin [
		{Feedback on Rebol Friendly Sites: } url newline ; <- email subject line
		{^/<Write your comment / feedback here.>} 
	]

	view/new center-face email-lay: layout [
		backdrop
		title "Feedback message"
		across 
		label 60 "To:" field form feedback-email return
		label 60 "Subject:" field 430 first parse/all message "^/" return
		area 500 message para [wrap?: yes] return
		pad 300 button 200x40 "Send to feedback" font-size 20 [
			view/new center-face layout either error? set/any 'err try [
				send feedback-email message
			][
				[backdrop title "Error sending email" area 400x200 form-error disarm err]
			][
				[backdrop title "Message sent"]
			]
		]
	]
]

; build the scrollable area
scroll-lay: [
	backdrop
	origin 0
	across
]

foreach [name url date note] site-data [
	if empty? name [append name " "]
	append scroll-lay compose [
		; see the style definitions in the layout below (site, date, note)
		site (join name [" " newline url]) user-data (url)
		date (form date)
		note (note) user-data (form url)
		return
	]
]

; modified init of the site style installs a modified feel (of which the over function
; is modified to update the info bar at the bottom of the window).
use [feel blk-pos blk][

	feel: make svvf/hot [
		over: func [face action event][
			if all [face/font face/font/colors] [
				face/font/color: pick face/font/colors not action
				show face
				face/font/color: first face/font/colors
			]

			; these two lines are my addition
			info/text: either action [copy face/user-data][""]
			show info
		]
	]

	; get the default init from text style
	my-init: copy/deep get in get-style 'text 'init

	; find the bit of code we want to modify, it's in a block, so copy it
	blk: copy first blk-pos: skip find my-init [if :action] 2

	; install the feel we defined above
	change at blk 2 feel
	change first blk-pos blk

	; also do it for the title style
	title-init: copy/deep get in get-style 'title 'init
	blk: copy first	blk-pos: skip find title-init [if :action] 2
	change at blk 2 feel
	change first blk-pos blk
]

view/new center-face layout [
	backdrop [unfocus]
	;styles utility-styles ; for the scroll-panel
	styles scroll-panel-style
	style text text font-color reduce [0.0.0 red / 2] effect [merge luma 5] 
	style site text 200 [browse face/user-data] with [init: copy my-init]
	style date text 100
	style note text 300 [feedback face/user-data]
	my-title: title 600 "Rebol Friendly Sites" [browse public-html-url] user-data public-html-url with [init: copy title-init]
	text 600 center join "Version: " [system/script/header/version "    Date:" system/script/header/date]
	pad 0x10
	across
	h3 200 "site" 
	h3 100 "updated"
	h3 300 "notes"
	return
	;scrollpanel 634x300 edge [size: 1x1] subface scroll-lay
	scroll-panel 634x300 edge [size: 1x1] subface scroll-lay
	return
	info: txt 634
	return
	button "write-html" [write local-html-file create-html site-data]
	button "browse local html" 130 [browse local-html-file]
	button "upload html" [upload-html]
	button "upload script" [upload-script]
	button "browse remote html" 130 [browse public-html-url]
	return
	label "user:" user-fld: field
	label "pass:" pass-fld: field ;hide
]

;cred: does [user: ask "user: " pass: ask "pass: "]
cred: does [user: user-fld/text pass: pass-fld/text]

upload-html: does [
	cred
	if error? set/any 'err try [
		write join ftp:// [user ":" pass "@" ftp-site-base html-file] read local-html-file
	][print mold disarm err]
]

upload-script: does [
	cred
	if error? set/any 'err try [
		write join ftp:// [user ":" pass "@" ftp-site-base "rebol/doc/rebol-friendly-sites.r"] read %rebol-friendly-sites.r
	][print mold disarm err]
]

wait none