#!/usr/local/bin/rebol -c

REBOL [
	Title: "QuarterMaster"
	Author: "Christopher Ross-Gill"
	Version: 0.3.11
	Notes: {Warning: Work-In-Progress - no liabilities for damage, etc.}
	License: http://creativecommons.org/licenses/by-sa/3.0/
]

config: construct [
	public-key: "a key that will be visible - for cookie ids"
	private-key: "a private key - for encrypting passwords"
	session-timeout: 0:02:00
	zone: -6:00
	post-limit: 500 ;-- not active yet; can be altered per controller/action
	default-controller: "blog"
	spaces: [
		;-- QM requires entries for "system" "data" "site" "support"
		"system"  %/Path/To/app/application/
		"space"   %/Path/To/app/space/
		"site"    %/Path/To/HTTPD/root/
		"support" %/Path/To/support/

		;-- Add more for your convenience
	]
]

;--## APPLICATION BEYOND THIS POINT
;-------------------------------------------------------------------##
system/options/binary-base: 64
system/error/user/type: "QuarterMaster Error"
date: now - now/zone + config/zone
range!: :pair! ; until REBOL v3
else: #[true] ; for 'case statements

random/seed to-integer checksum/secure form now/precise ; any better?
if all [debug: find/tail/last any [system/options/cgi/query-string ""] "&debug=" debug: tail? debug] [
	print "Content-Type: text/plain; charset=utf-8^/"
]

;--## APPLICATION NAMESPACE
;-------------------------------------------------------------------##
qm: context [
	binding: 'self
	controller: metadata: action: #[none]
	models: request: response: #[none]
	alerts: []
	errors: []
	notices: []
	handler: %.rsp
	view-path: #[none]
	title: ""
	code: []
]

;--## EXTENDED CORE FUNCTIONS
;-------------------------------------------------------------------##
context [
	func: make function! [spec [block!] body [block!]][make function! spec body]
	does: func [body [block!]][make function! [] body]

	uses: func [proto [block!] spec [block!]][
		proto: context proto
		func [args [block! object!]] compose/only [
			args: make (proto) args
			do bind (spec) args
		]
	]

	try-else: func [[throw] 'try-first [any-block!] on-fail [block!] /local reason][
		either error? reason: try :try-first bind :on-fail 'reason [:reason]
	]

	assert-all: func [[throw] cases [block!] /local value][
		until [
			set [value cases] do/next cases
			unless value cases/1
			cases: next cases
			any [not value tail? cases]
		]
		any [value]
	]

	; step-through: try-each: func ['steps [block!] else [block!] /local reason][
	; 	foreach [block err-code] steps [
	; 		either error? reason: try :block [do bind else 'reason return err-code][:reason]
	; 	]
	; ]

	fortype: func [[throw] type [datatype!] block [block!] f [any-function!] /local val][
		parse block [some [to type set val type (f :val)]]
	]

	with: func [object [any-word! object! port!] block [any-block!] /only][
		block: bind block object
		either only [block] :block
	]

	envelope: func [val [any-type!]][either any-block? val [val][reduce [val]]]

	raise: func [[catch] reason][throw make error! rejoin envelope reason]

	export: func [words [word! block!] /to dest [object!] /local word][
		dest: any [dest system/words]
		fortype word! to-block words func [word] [
			set/any in dest word get/any word
			; protect in dest word
		]
	]

	true?: func [test][either test [#[true]][#[false]]]

	export [func does uses try-else assert-all fortype export envelope raise with true?]
]

;--## SERIES HELPERS
;-------------------------------------------------------------------##
context [
	push: func [stack [series! port!] value [any-type!] /only][
		head either only [insert/only stack :value][insert stack :value]
	]

	pop: take: func [series [series! port! none!] /last /part range [integer!] /local result][
		range: any [range 1]
		case [
			none? series [return none]
			last [series: skip tail series negate abs range]
		]
		either part [
			result: copy/part series range
			remove/part series range
		][
			result: pick series 1
			remove series
		]
		result
	]

	pop*: func [stack [series! port!] /local val][
		val: pick stack 1
		remove stack
		:val
	]

	flatten: func [block [any-block!] /once][
		once: either once [
			[(block: insert block pop block)]
		][
			[(insert block pop block)]
		]
		parse block [
			any [block: any-block! (insert block pop block) :block | skip]
		]
		head block
	]

	map: func [series [any-block! port!] action [any-function!] /only /copy /local new][
		if copy [series: system/words/copy/deep series]
		while [not tail? series][
			series: either only [
				change/part/only series action series/1 1
			][
				change/part series action series/1 1
			]
		]
		head series
	]

	map-each: func [[catch throw] 'word [word! block!] series [any-block!] body [block!] /copy /local new][
		case/all [
			word? word [word: envelope word]
			not parse word [some word!][
				raise "WORDS argument should be a word or block of words"
			]
			copy [series: system/words/copy/deep series]
		]
		use word compose/deep [
			while [not tail? series][
				set [(word)] series (body)
				series: change/part series reduce [(word)] (length? word)
			]
		]
		head series
	]

	get-choice: func [word [string! word!] words [any-block!]][
		all [
			word: attempt [to-word word]
			find words word
			word
		]
	]

	get-class: func [classes [block!] item /local type][
		all [
			type: type? classes/1
			classes: find classes item
			first find/reverse classes type
		]
	]

	link-to: func ['path [any-block!] /local out][
		out: copy %""
		path: compose to-block path
		foreach val path [
			either issue? val [append out mold val][repend out ["/" form val]]
		]
	]

	compose-path: func ['path [path! lit-path! word! lit-word!]][
		to-path new-line/all compose to-block envelope path none
	]

	paginate: func [series [series! port!] page [integer! none!] /window padding /size length][
		page: any [page 1]
		length: any [length 15]
		padding: any [padding 2]

		context [
			last: max 1 to-integer (length? series) - 1 / length + 1
			current: max 1 min last page
			next: either last > current [current + 1][false]
			previous: either 1 < current [current - 1][false]
			records: copy/part skip series offset: current - 1 * length length
			upper: copy [] lower: copy []
			repeat cnt padding [
				insert lower current - cnt
				append upper current + cnt
			]
			remove-each val lower [val <= 1]
			remove-each val upper [val >= last]
			start: current - 2 <= padding
			end: last - current - 1 <= padding
		]
	]

	prepare: use [rule flat nest val][
		rule: [val: paren! (do val/1 remove val) :val | get-word! (change/part val get/any val/1 1)]
		flat: [some [rule | skip]]
		nest: [some [rule | into nest | skip]]

		func [block [any-block!] /deep][
			parse block: copy/deep block either deep [nest][flat]
			block
		]
	]

	export [push take pop flatten map map-each get-choice get-class compose-path prepare link-to paginate]
]

;--## KEY-VALUE HELPERS
;-------------------------------------------------------------------##
context [
	add-to: func [ser key val][
		key: envelope key
		map key func [key][as word! key]
		if find key none! [return none]
		until [
			ser: any [
				find/tail ser key/1
				insert tail ser key/1
			]

			key: next key

			switch type?/word ser/1 [
				none! [unless tail? key [insert/only ser ser: copy []]]
				string! [change/only ser ser: envelope ser/1]
				block! [ser: ser/1]
			]

			if tail? key [append ser val]
		]
	]

	get-from: func [series 'key][
		key: copy envelope key
		while [all [not tail? key any-block? series]][
			series: select series pop key
		]
		all [tail? key series]
	]

	export [add-to get-from]
]

;--## CHARACTER SETS
;-------------------------------------------------------------------##
context [
	comment {
	Will consider the possibility of using more bnf friendly words...
	[
		snip: difference charset [#"^(20)" - #"^(7F)"] charset [{:*.<>=} #"{" #"}"]
		chars-n:  charset [#"0" - #"9"]   ; digit
		chars-la: charset [#"a" - #"z"]   ; lower-alpha
		chars-ua: charset [#"A" - #"Z"]   ; upper-alpha
		chars-a:  union chars-la chars-ua ; alpha
		chars-an: union chars-a chars-n   ; alphanumeric
		chars-hx: union chars-n charset [#"A" - #"F" #"a" - #"f"] ; hexdig
		chars-ud: union chars-an charset "*-._!~',"               ; url decode
		chars-u:  union chars-ud charset ":+%&=?"                 ; url
		chars-f:  union chars-an charset "-_"                     ; file
		chars-w1: union chars-a charset "*-._!+?&|"
		chars-w*: union chars-w1 chars-n
		chars-p:  union chars-an charset "-_!+%"   ; path
		chars-sp: charset " ^-"                    ; space
		chars-as: charset ["^/^-" #"^(20)" - #"^(7F)"] ; ascii
		chars-up: charset [#"^(80)" - #"^(FF)"]    ; above ascii
		; chars-ht: exclude union chars-as chars-up charset {&<>"}
		chars-ht: exclude chars-as charset {&<>"}
		chars: complement nochar: charset " ^-^/"
	]
	}

	chars-n:  #[bitset! 64#{AAAAAAAA/wMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
	chars-la: #[bitset! 64#{AAAAAAAAAAAAAAAA/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-ua: #[bitset! 64#{AAAAAAAAAAD+//8HAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
	chars-a:  #[bitset! 64#{AAAAAAAAAAD+//8H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-an: #[bitset! 64#{AAAAAAAA/wP+//8H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-hx: #[bitset! 64#{AAAAAAAA/wN+AAAAfgAAAAAAAAAAAAAAAAAAAAAAAAA=}]
	chars-ud: #[bitset! 64#{AAAAAIJ0/wP+//+H/v//RwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-u:  #[bitset! 64#{AAAAAKJ8/wf+//+H/v//RwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-f:  #[bitset! 64#{AAAAAAAg/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-w1: #[bitset! 64#{AAAAAEJsAID+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-w*: #[bitset! 64#{AAAAAEJs/4P+//+H/v//FwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-p:  #[bitset! 64#{AAAAAKJo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
	chars-sp: #[bitset! 64#{AAIAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
	chars-as: #[bitset! 64#{AAYAAP///////////////wAAAAAAAAAAAAAAAAAAAAA=}]
	chars-up: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP////////////////////8=}]
	; chars-ht: #[bitset! 64#{AAYAALv//6////////////////////////////////8=}]
	chars-ht: #[bitset! 64#{AAYAALv//6///////////wAAAAAAAAAAAAAAAAAAAAA=}]
	chars:    #[bitset! 64#{//n///7///////////////////////////////////8=}]
	nochar:   #[bitset! 64#{AAYAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]

	export [
		chars-n  chars-la chars-ua chars-a chars-an chars-hx
		chars-w1 chars-w* chars-f  chars-p chars-u chars-ud chars-sp
		chars-up chars-as chars-ht chars   nochar
	]
]

;--## UTF-8
;-------------------------------------------------------------------##
context [
	utf-2: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wAAAAA=}]
	utf-3: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//AAA=}]
	utf-4: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/wA=}]
	utf-5: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA8=}]
	utf-b: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP//////////AAAAAAAAAAA=}]

	utf-8: [utf-2 1 utf-b | utf-3 2 utf-b | utf-4 3 utf-b | utf-5 4 utf-b]

	utf-os: [0 192 224 240 248 252]
	utf-fc: [1 64 4096 262144 16777216]

	get-ucs-code: func [char /local int][
		int: 0
		char: change char char/1 xor pick utf-os length? char
		forskip char 1 [change char char/1 xor 128]
		char: head reverse head char
		forskip char 1 [int: (to-integer char/1) * (pick utf-fc index? char) + int]
		all [int > 127 int <= 65535 int]
	]

	export [utf-8 get-ucs-code]
]

;--## STRING HELPERS
;-------------------------------------------------------------------##
context [
	pad: func [text length [integer!] /with padding [char!]][
		padding: any [padding #"0"]
		text: form text
		skip tail insert/dup text padding length negate length
	]

	url-encode: func [text [any-string!]][
		parse/all copy text [
			copy text any [
				some chars-ud |
				#" " text: (change back text #"+") |
				skip text: (change/part back text join "%" enbase/base to-string text/-1 16 1)
			]
		]
		text
	]

	deplus: func [text][
		parse/all text [some [to #"+" text: (text: change text #" ") :text] to end]
		head text
	]

	decrlf: func [text][
		parse/all text [some [to crlf text: (text: change/part text #"^/" 2) :text] to end]
		head text
	]

	url-decode: func [text [any-string!]][decrlf dehex deplus to-string text]

	decode-query: func [query [string! none!] /local result name value][
		query: any [query ""]
		result: copy []

		if query [
			remove-each value query: parse/all query "&" [empty? value]
			map/only query func [value][parse/all value "="]
			foreach value query [change/only value parse/all value/1 "."]
		]

		parse query [
			any [
				into [
					set name block! set value opt string! (
						add-to result name any [all [value url-decode value] ""]
					)
				]
			]
		]

		result
	]

	; doesn't work right, yet
	decode-options: func [options [string! none!] type [datatype!]][
		options: any [options ""]
		options: parse lowercase options ";,"
		map options func [val [string!] /local weight][
			either parse/all val ["q=" weight: "0." integer!][
				load weight
			][
				as :type val
			]
		]
	]

	compose-tags: func [body [string!] callback [any-function!] /local out tag block][
		out: make string! length? body
		while [tag: find body "=["][
			insert/part tail out body offset? body tag
			body: either error? err: try [
				block: load/next tag: next tag
			][
				append out "**Tag Loading Error: #"
				tag
			][
				append out any [callback first block ""]
				second block
			]
		]
		append out body
	]

	interpolate: func [body [string!] escapes [any-block!] /local out][
		body: out: copy body

		parse/all body [
			any [
				to #"%" body: (
					body: change/part body reduce any [
						select/case escapes body/2 body/2
					] 2
				) :body
			]
		]

		out
	]

	replace: func [target [any-string!] search [char! any-string!] replace /all /case /local len rule][
		len: either char? search [1][length? search]
		rule: [any [to search target: (target: change/part target replace len) :target] to end]
		rule/1: pick [opt any] none? all
		do pick [parse parse/case] none? case target rule
		head target
	]

	sanitize: func [text [any-string!] /local char][
		parse/all copy text [
			copy text any [
				text: some chars-ht
				| #"&" (text: change/part text "&amp;" 1) :text
				| #"<" (text: change/part text "&lt;" 1) :text
				| #">" (text: change/part text "&gt;" 1) :text
				| #"^"" (text: change/part text "&quot;" 1) :text
				| #"^M" (remove text) :text 
				| copy char utf-8 (text: change/part text rejoin ["&#" get-ucs-code char ";"] length? char)
				| skip (text: change/part text rejoin ["#(" to-integer text/1 ")"] 1) :text
				; | skip (text: change text "#") :text
			]
		]
		any [text ""]
	]

	; sanitize: func [text][
	; 	replace/all text: copy text #"&" "&amp;"
	; 	replace/all text #"<" "&lt;"
	; 	replace/all text #">" "&gt;"
	; 	replace/all text #"^"" "&quot;"
	; ]

	load-multipart: func [
		[catch] data [binary!] boundary
		/local store name content filetype filename
		file-prototype qchars nchars dchars
	][
		store: copy []
		file-prototype: context [name: data: type: meta: #[none]]

		qchars: #[bitset! 64#{//////v///////////////////////////////////8=}]
		nchars: #[bitset! 64#{//////////f///////////////////////////////8=}]
		
		unless parse/all/case data [boundary data: to end][
			raise "Postdata not Multipart"
		]

		boundary: join crlf boundary

		unless parse/all/case data [
			some [
				"--" crlf end |
				(name: content: filemime: filetype: filename: none)
				crlf {Content-Disposition: form-data; name=}
				[{"} copy name some qchars {"} | copy name some nchars]
				(name: parse/all name ".")
				opt [
					{; filename=} [
						[{"} copy filename any qchars {"} | copy filename any nchars]
						crlf {Content-Type: } copy filetype to crlf
					]
				]
				crlf crlf copy content to boundary boundary (
					content: any [content ""]
					either all [filetype filetype: as path! filetype][
						filename: either filename [
							as file! any [
								find/last/tail filename #"/"
								find/last/tail filename #"\"
								find/last/tail filename #":"
								filename
							]
						][%file.dat]
						content: either filetype/1 = 'text [decrlf content][to-binary content]
						add-to store name make file-prototype [
							name: :filename type: :filetype data: :content
						]
					][
						add-to store name to-string decrlf content
					]
				)
			]
		][
			raise "Invalid Multipart Postdata"
		]
		
		store
	]

	export [
		pad url-encode url-decode decode-query decode-options
		load-multipart compose-tags interpolate replace sanitize
	]
]

;--## PORT HELPERS
;-------------------------------------------------------------------##
context [
	add-protocol: func ['name id handler /with block][
		unless in system/schemes name [
			system/schemes: make system/schemes compose [
				(to-set-word name) #[none]
			]
		]
		set in system/schemes name make system/standard/port compose [
			scheme: name
			port-id: (id)
			handler: (handler)
			passive: #[none]
			cache-size: 5
			proxy: make object! [host: port-id: user: pass: type: bypass: #[none]]
			(block)
		]
	]

	to-header: func [object [object!] /local header][
		header: make string! (20 * length? first object)
		foreach word next first object [
			if get word: in object word [
				insert tail header reduce [word ": " get word newline]
			]
		]
		header
	]

	codes: [read 1 write 2 append 4 new 8 binary 32 lines 64 direct 524288]
	get-port-flags: func [port words][
		remove-each word copy words [
			word: select codes word
			word <> (port/state/flags and word)
		]
	]

	chars: ; charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%"]
	#[bitset! 64#{AAAAACIo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]

	space!: context [
		root: domain: path: target: folder: file: suffix: #[none]
	]

	get-space: func [base [url!] location [url!] /local space][
		base: form base
		space: make space! [uri: :location]

		if all with/only space [
			parse/all uri [
				base
				copy domain some chars #"/"
				copy path any [some [some chars | #"."] #"/"]
				copy target opt [any chars #"." 1 10 chars]
			]
			root: select config/spaces domain
		] with/only space [
			path: all [path to-file path]
			target: all [target to-file target]
			folder: join root any [path ""]
			file: join folder any [target ""]
			suffix: suffix? file
			self
		]
	]

	export [add-protocol to-header get-port-flags get-space]
]

;--## VALUES HELPERS
;-------------------------------------------------------------------##
context [
	pad-zone: func [time /flat][
		rejoin [
			pick "-+" time/hour < 0
			pad abs time/hour 2
			either flat [""][#":"]
			pad time/minute 2
		]
	]

	get-iso-year: func [year [integer!] /local d1 d2][
		d1: to-date join "4-1-" year
		d2: to-date join "28-12-" year
		return reduce [d1 + 1 - d1/weekday d2 + 7 - d2/weekday]
	]

	to-iso-week: func [date [date!] /local out d1 d2][
		out: 0x0
		set [d1 d2] get-iso-year out/y: date/year

		case [
			date < d1 [d1: first get-iso-year out/y: date/year - 1]
			date > d2 [d1: first get-iso-year out/y: date/year + 1]
		]

		out/x: date + 8 - date/weekday - d1 / 7
		out
	]

	date-codes: [
		#"a" [copy/part pick system/locale/days date/weekday 3]
		#"A" [pick system/locale/days date/weekday]
		#"b" [copy/part pick system/locale/months date/month 3]
		#"B" [pick system/locale/months date/month]
		#"C" [to-integer date/year / 100]
		#"d" [pad date/day 2]
		#"D" [date/year #"/" pad date/month 2 #"/" pad date/day 2]
		#"e" [date/day]
		#"g" [pad (second to-iso-week date) // 100 2]
		#"G" [second to-iso-week date]
		#"h" [time/hour + 11 // 12 + 1]
		#"H" [pad time/hour 2]
		#"i" [any [get-class [st 1 21 31 nd 2 22 rd 3 23] date/day "th"]]
		#"I" [pad time/hour + 11 // 12 + 1 2]
		#"j" [pad date/julian 3]
		#"J" [date/julian]
		#"m" [pad date/month 2]
		#"M" [pad time/minute 2]
		#"p" [pick ["am" "pm"] time/hour < 12]
		#"P" [pick ["AM" "PM"] time/hour < 12]
		#"S" [pad round time/second 2]
		#"t" [#"^-"]
		#"T" [pad time/hour 2 #":" pad time/minute 2 #":" pad round time/second 2]
		#"u" [date/weekday]
		#"U" [pad to-integer date/julian + 6 - (date/weekday // 7) / 7 2]
		#"V" [pad first to-iso-week date 2]
		#"w" [date/weekday // 7]
		#"W" [pad to-integer date/julian + 7 - date/weekday / 7 2]
		#"y" [pad date/year // 100 2]
		#"Y" [date/year]
		#"z" [pad-zone/flat zone]
		#"Z" [pad-zone zone]
	]

	form-date: func [date [date!] format [any-string!] /gmt /local time zone nyd][
		all [
			date/time date/zone
			date/time: date/time - date/zone
			date/time: date/time + date/zone: either gmt [0:00][config/zone]
		]

		time: any [date/time 0:00]
		zone: any [date/zone config/zone 0:00]
		interpolate format bind date-codes 'date
	]

	color-codes: [
		#"r" [color/1] #"1" [to-char color/1]
		#"g" [color/2] #"2" [to-char color/2]
		#"b" [color/3] #"3" [to-char color/3]
		#"a" [color/4] #"4" [to-char color/4]
		#"R" [skip tail to-hex color/1 -2]
		#"G" [skip tail to-hex color/2 -2]
		#"B" [skip tail to-hex color/3 -2]
		#"A" [skip tail to-hex color/4 -2]
	]

	form-color: func [color [tuple!] format [any-string!]][
		bind color-codes 'color
		color: 0.0.0.0 + color
		interpolate format color-codes
	]

	pluralize: func [string [string!] count [number!]][
		unless any [count = 1 count = -1][string: join string "s"]
		reform [count string]
	]

	export [form-date to-local-time form-color pluralize]
]

;--## VALUES FILTER
;-------------------------------------------------------------------##
context [
	id: [chars-la 0 15 chars-f]
	word: [chars-w1 0 25 chars-w*]
	number: [integer!]
	integer: [opt #"-" number]

	masks: reduce [
		issue!    [some chars-u]
		logic!    ["true" | "on" | "yes" | "1"]
		word!     [word]
		url!      [id #":" some [chars-u | #":" | #"/"]]
		email!    [some chars-u #"@" some chars-u]
		path!     [word 1 5 [#"/" [word | integer]]]
		integer!  [integer]
		string!   [some [some chars-as | utf-8]]
		'positive [number]
		'id       [id]
		'key      [word 0 6 [#"." word]]
	]

	as: func [
		[catch] type [datatype!] value [any-type!]
		/where format [none! block! any-word!]
	][
		case/all [
			none? format [format: select masks type]
			none? format [if type = type? value [return value]]
			any-word? format [format: select masks to-word format]
			block? format [
				unless parse/all form value format [return none]
			]
			type = path! [return load value]
		]

		attempt [make type value]

	]

	export [as]
]

;--## IMPORT
;-------------------------------------------------------------------##
context [
	result: errors: #[none]

	messages: [
		not-included "is not included in the list"
		excluded "is reserved"
		invalid "is missing or invalid"
		not-confirmed "doesn't match confirmation"
		not-accepted "must be accepted"
		empty "can't be empty"
		blank "can't be blank"
		too-long "is too long (maximum is %d characters)"
		too-short "is too short (minimum is %d characters)"
		wrong-length "is the wrong length (should be %d characters)"
		not-a-number "is not a number"
		too-many "has too many arguments"
	]

	datatype: [
		'any-string! | 'binary! | 'block! | 'char! | 'date! | 'decimal! | 'email! | 'file! |
		'get-word! | 'integer! | 'issue! | 'lit-path! | 'lit-word! | 'logic! | 'money! |
		'none! | 'number! | 'pair! | 'paren! | 'path! | 'range! | 'refinement! |
		'set-path! | 'set-word! | 'string! | 'tag! | 'time! | 'tuple! | 'url! | 'word!
	]

	else: #[none]
	otherwise: [
		['else | 'or][
			set else string! | copy else any [word! string!]
		] | (else: #[none])
	]

	source: key: value: target: type: format: constraints: else: none

	constraint: use [is is-not? is-or-length-is op val val-type range group][
		op: val: val-type: none
		is: ['is | 'are]
		is-or-length-is: [
			[
				['length | 'size] (val: length? value val-type: integer!)
				| (val: :value val-type: :type)
			] is
		]
		is-not?: ['not (op: false) | (op: true)]

		[
			is [
				'accepted otherwise (
					unless true = value [report not-accepted]
				) |
				'confirmed opt 'by set val get-word! otherwise (
					val: to-word val
					unless value = as/where :type get-from source :val format [
						report not-confirmed
					]
				) |
				is-not? 'within set group any-block! otherwise (
					either found? find group value [
						unless op [report excluded]
					][
						if op [report not-included]
					]
				)
			] |
			is-or-length-is [
				is-not? 'between [set range [range! | into [2 val-type]]] otherwise (
					either op [
						case [
							val < target: range/1 [report too-short]
							val > target: range/2 [report too-long]
						]
					][
						unless any [
							val < range/1
							val > range/2
						][report excluded]
					]
				) |
				'more-than set target val-type otherwise (
					unless val > target [report too-short]
				) |
				'less-than set target val-type otherwise (
					unless val < target [report too-long]
				) |
				set target val-type otherwise (
					unless val = target [report wrong-length]
				)
			]
		]
	]

	do-constraints: does [constraints: [any constraint]]
	no-constraints: does [constraints: [to set-word! | to end]]

	humanize: func [word][uppercase/part replace/all form word "-" " " 1]

	report: func ['message [word!]][
		message: any [
			all [string? else else]
			all [block? else select else message]
			reform [humanize key any [select messages message ""]]
		]
		unless select errors :key [repend errors [:key copy []]]
		append select errors :key interpolate message [
			#"w" [form key]
			#"W" [humanize key]
			#"d" [form target]
			#"t" [form type]
		]
	]

	import: func [
		[catch] source* [block! none!] spec [block!]
		/report-to errs [block!]
		/block /again /local required present
	][
		unless source* [return none]

		errors: copy []
		result: copy []

		source: source* []

		unless parse compose/deep/only spec [
			any [
				set key [set-word! | refinement!] (key: to-word key)
				set required opt 'opt (required: required <> 'opt)
				set type datatype (type: get type)
				set format opt [block! | get-word!]
				otherwise

				(
					value: either block [
						pick source 1
					][
						get-from source :key
					]

					present: not any [
						none? value
						empty? trim/head/tail form value
					]

					either all [
						present
						value: either :type = block! [
							either block? format [
								import value format
							][value]
						][
							as/where :type value format
						]
					][
						if block [source: next source]
						do-constraints
						repend result [key value]
					][
						no-constraints
						case [
							all [present not block] [report invalid]
							required [report blank]
							not required [repend result [key none]]
						]
					]
				)

				constraints
			]
		][raise "Could not parse Import specification"]

		all [block? errs insert clear errs errors]
		unless qm/errors: all [not empty? errors errors][result]
	]

	get-one: func [data type /local res][
		parse data [some [res: type to end break | skip]]
		unless tail? res [take res]
	]

	get-some: func [data type /local pos res][
		res: make block! length? data
		parse data [some [pos: type (append/only res take pos) :pos | skip]]
		unless empty? res [res]
	]

	match: func [
		[catch] source* [block!] spec [block!]
		/report-to errs [block!]
		/local required type
	][
		source: copy :source*
		errors: copy []
		result: context append remove-each item copy spec [not set-word? item] none

		unless parse spec [
			some [
				set key set-word! (key: to-word key)
				set required ['opt | 'any | 'some | none]
				copy type [datatype any ['| datatype]]
				otherwise

				(
					switch/default required [
						any [
							value: get-some source type
							either value [do-constraints][no-constraints]
						]
						opt [
							value: get-one source type
							either value [do-constraints][no-constraints]
						]
						some [
							value: get-some source type
							either value [do-constraints][no-constraints report invalid]
						]
					][
						value: get-one source type
						either value [do-constraints][no-constraints report invalid]
					]

					result/(key): value
				)

				constraints
			]
		][raise "Could not parse Match specification"]

		all [block? errs insert clear errs errors]
		unless empty? source [key: 'match report too-many]
		unless qm/errors: all [not empty? errors errors][result]
	]

	export [import match]
]

;--## Q(uick)TAG DIALECT
;-------------------------------------------------------------------##
context [
	qtags: []
	form-val: func [val /local value][
		val: switch/default type?/word val [
			get-word! [
				if value: get/any :val [
					rejoin [{ } val {="} sanitize form value {"}]
				]
			]
			word! [
				all [val: get val sanitize form val]
			]
			none! [val]
			string! [val]
		][sanitize form val]
		any [val ""]
	]

	add-qtag: func ['name [word!] format [block!] spec [block!] prep [block!]][
		repend qtags [
			name
			func [[catch] spec [block!]] compose/deep/only [
				throw-on-error [
					either spec: match spec (spec) [
						spec: make spec (prep)
						rejoin map/copy with/only spec (format) :form-val
					][
						raise (rejoin ["!!!Invalid " uppercase form name " tag."])
					]
				]
			]
		]
	]

	add-qtag a [
		"<a" :id :href :rel :class :title :accesskey ">"
	][
		href: file! | url! | path!
		id: opt issue!
		class: any refinement!
		title: opt string!
		accesskey: opt char!
		rel: any lit-word!
	][
		all [path? href href: link-to :href]
	]

	add-qtag div ["<div" :id :class ">"][
		id: opt issue!
		class: any refinement!
	][]

	add-qtag img [
		"<img" :id :width :height :src :class :alt :title " />"
	][
		src: file! | url! | path!
		size: opt pair!
		alt: string!
		title: opt string!
		id: opt issue!
		class: any refinement!
	][
		all [path? src src: link-to :src]
		size: any [size -1x-1]
		set [width height] reduce [size/x size/y]
		all [width < 0 width: none] all [height < 0 height: none]
	]

	add-qtag form [
		"<form" :method :action :enctype :id :class ">"
	][
		method: opt word! is within [get post upload]
		action: file! | url! | path!
		id: opt issue!
		class: any refinement!
	][
		enctype: none
		case/all [
			path? action [action: link-to :action]
			none? method [method: 'post]
			method = 'upload [method: 'post enctype: 'multipart/form-data]
		]
	]

	to-key: func [key [path! word!]][replace/all form compose-path :key #"/" #"."]

	add-qtag label [
		"<label" :for :accesskey :title :class ">"
	][
		title: opt string!
		for: opt issue!
		class: any refinement!
		accesskey: opt char!
	][]

	add-qtag hidden [
		{<input type="hidden"} :name :value " />"
	][
		name: word! | path!
		value: opt any-string! | number! | none!
	][
		name: to-key name
		value: any [value ""]
	]

	field: [
		name: word! | path!
		id: opt issue!
		size: opt integer! | pair!
		value: opt any-string! | number! | none!
		class: any refinement!
	]

	add-qtag field [
		{<input type="text"} :name :value :id :size :class " />"
	] field [
		name: to-key name
		class: append any [class copy []] /field
		value: any [value ""]
	]

	add-qtag password [
		{<input type="password"} :name :value :id :size :class " />"
	] field [
		name: to-key name
		class: append any [class copy []] /field
		value: any [value ""]
	]

	add-qtag area [
		{<textarea} :name :id :cols :rows :class ">" value "</textarea>"
	] field [
		name: to-key name
		class: append any [class copy []] /field
		size: 0x0 + any [size 12x50]
		cols: abs size/x
		rows: abs size/y
		value: any [value ""]
	]

	check-options: [
		name: word! | path!
		id: opt issue!
		value: any-string! | number!
		checked: opt logic! | none! | any-string! | number!
		class: any refinement!
	]

	check-line-options: [
		name: word! | path!
		id: issue!
		accesskey: opt char!
		label: string!
		value: any-string! | number!
		checked: opt logic! | none! | any-string! | number!
		class: any refinement!
	]

	check-action: [
		for: :id
		name: to-key name
		value: any [value ""]
		checked: if any [value = checked true? checked]["checked"]
	]

	add-qtag check [
		{<input type="checkbox"} :name :value :checked :id :class " />"
	] :check-options :check-action

	add-qtag check-line [
		{<label} :for :accesskey :class {><input type="checkbox"} :name :value :checked :id " /> " label "</label>"
	] :check-line-options :check-action

	add-qtag radio [
		{<input type="radio"} :name :value :checked :id :class " />"
	] :check-options :check-action

	add-qtag radio-line [
		{<label} :for :accesskey {><input type="radio"} :name :value :checked :id :class " /> " label "</label>"
	] :check-line-options :check-action

	[
		| 'select [
			'many
			| opt 'one
		]
	]

	add-qtag get-file [
		{<input type="file"} :name :id :class " />"
	][
		name: word! | path!
		id: opt issue!
		class: any refinement!
	][
		name: to-key name
		class: append any [class copy []] /get-file
	]

	add-qtag submit [
		{<input type="submit"} :name :value :id :size :class " />"
	] field [
		name: to-key name
		value: any [value ""]
		class: append any [class copy []] /submit
	]

	build-tag: func [[catch] spec [block!] /local cmd action][
		either action: select qtags cmd: pop spec: compose spec [
			action spec
		][
			rejoin ["!!! Invalid QuickTag Type: &lt;" cmd "&gt;"]
		]
	]

	export [add-qtag build-tag]
]

;--## FILESYSTEM
;-------------------------------------------------------------------##
context [
	sw*: system/words
	rights: [
		folder [
			owner-read: group-read: world-read:
			owner-write: group-write: world-write:
			owner-execute: group-execute: world-execute: #[true]
		]
		file [
			owner-read: group-read: world-read:
			owner-write: group-write: world-write: #[true]
			owner-execute: group-execute: world-execute: #[false]
		]
	]

	set-rights: func [file access][
		unless find [1 3] system/version/4 [
			attempt [set-modes file rights/:access]
			; not perfect
		]
	]

	break-path: func [[catch] target [file!] base [file!] /local path mk][
		path: make block! []
		either parse/all target: form target [
			base some [
				thru #"/" mk: (append path to-file copy/part target mk)
			] end
		][return path][
			raise compose [access invalid-path (target)]
		]
	]

	make-dir: func [[catch] path [file!] /root base [file!] /deep /local dirs][
		all [empty? path return path]
		if exists? path [
			return either dir? path [path][false]
		]
		either deep [
			close throw-on-error [open/new path]
			any [
				find [1 3] system/version/4
				throw-on-error [set-rights path 'folder]
			]
		][
			dirs: break-path path base
			foreach path dirs [make-dir/deep path]
		]
		path
	]

	get-subfolders: func [folder /deep /local tree files][
		tree: []
		unless deep [clear tree]
		insert tree folder
		files: read folder
		foreach file files [
			if equal? last folder/:file #"/" [
				get-subfolders/deep folder/:file
			]
		]
		tree
	]

	delete: func [[catch] target [url!] /pare /local path folder err][
		either error? set/any 'err try [
			; Delete Children
			if dir? target [
				folder: get-subfolders dirize target
				foreach path folder [close clear open path]
			]

			; Delete Target
			set [path target] split-path target
			folder: open path
			remove find folder target
			close folder

			; Delete Empty Parents
			if pare [
				while [
					pare: empty? folder: open path
					close folder
					pare
				][
					set [path target] split-path path
					folder: open path
					remove find folder target
					close folder
				]
			]
		][throw err][path]
	]

	dir?: func [[catch] target [file! url!]][
		throw-on-error [
			target: make port! target
			query target
		]
		target/status = 'directory
	]

	touch: func [[catch] target [file! url!]][
		throw-on-error [
			target: make port! target
			switch target/scheme [
				qm [target: make port! target/locals/file]
			]
			query target
			switch target/status [
				file [set-modes target [modification-date: now]]
				#[none] [close open/new target]
			]
		]
		exit
	]

	export [delete make-dir touch]

	; INTERFACE
	add-protocol qm 0 context [
		port-flags: system/standard/port-flags/pass-thru

		init: func [port url /local spec][
			unless all [
				url? url
				spec: get-space qm:// url
			][
				raise ["Filesystem URL <" url "> is invalid."]
			]

			with port [
				set [url host path target] reduce bind [uri domain path target] spec

				locals: context [
					flags: []
					root: spec/root
					folder: spec/folder
					file: spec/file
					suffix: spec/suffix
					open: #[none]
				]

				sub-port: make port! spec/file
			]
		]

		open: func [port][
			with port [
				locals/flags: get-port-flags port [read write append new binary lines]

				all [
					sw*/find locals/flags 'new
					not dir? locals/folder
					make-dir/root locals/folder locals/root
				]

				either all [
					any [
						exists? locals/file
						sw*/find locals/flags 'new
					]
					sw*/open/mode sub-port locals/flags
				][
					locals/open: true
					state/tail: sub-port/state/tail
				][
					state/tail: 0
				]

				state/index: 0
				state/flags: state/flags or port-flags
			]
		]

		copy: func [port][
			if port/locals/open with/only port [
				user-data: sw*/copy skip sub-port state/index
				all [
					block? user-data block? state/custom
					remove-each file user-data [not parse file state/custom]
				]
				user-data
			]
		]

		insert: func [port data][
			if port/locals/open with/only port [
				foreach [test onfail][
					[sw*/insert sub-port data]
					["Could not write <" url ">"]
					[set-rights sub-port 'file]
					["Could not set permissions <" url ">"]
				][
					if error? try :test [raise :onfail]
				]
				self
			]
		]

		remove: func [port][
			either port/locals/open with/only port [
				sub-port: skip sub-port state/index
				system/words/remove/part sub-port state/num
				self
			][]
		]

		find: func [port value][
			if port/locals/open with/only port [
				if value: system/words/find sub-port value [
					sub-port: :value
					self
				]
			]
		]

		close: func [port][
			either port/locals/open with/only port [
				any [locals/open exit]
				system/words/close sub-port
				self
			][]
		]

		query: func [port][
			with port [
				system/words/query sub-port
				size: sub-port/size
				date: sub-port/date
				status: sub-port/status
			]
		]
	]
]

;--## EXTERNAL HELPERS
;-------------------------------------------------------------------##
context [
	root: qm://support/
	cache: []

	require: know: func [[catch] location [file!] /reset /local helper][
		if reset [remove/part find cache location 2]
		any [
			select cache location
			if all [
				helper: attempt [load/header root/:location]
				helper: context compose [header: (helper)]
			][
				repend cache [location helper]
				if block? get in helper/header 'exports [
					export bind helper/header/exports helper
				]
				helper
			]
			throw raise ["Missing support file: %" location]
		]
	]

	export [require know]
]

;--## RENDER
;-------------------------------------------------------------------##
context [
	root: qm://system/views/

	load-rsp: func [[catch] body [string!] /local code mk][
		code: make string! length? body

		append code "out*: make string! {}^/"
		parse/all body [
			any [
				end (append code "out*") break
				| "<%" [
					"=" copy mk to "%>" (repend code ["prin (" mk "^/)^/"])
					| [#":" | #"!"] copy mk to "%>" (repend code ["prin build-tag [" mk "^/]^/"])
					| copy mk to "%>" (repend code [mk newline])
					| (raise "Expected '%>'")
				] 2 skip
				| copy mk [to "<%" | to end] (repend code ["prin " mold mk "^/"])
			]
		]

		try-else [
			code: bind load code qm/binding
			bind code 'self
			uses [
				out*: "" prin: func [val][repend out* val]
				print: func [val][prin val prin newline]
			] code
		][throw reason]
	]

	depth*: 0 ;-- to break recursion
	scope: #[none]

	clean-view-path: func [
		[catch] path [file!]
		partial? [logic! none!]
	][
		path: split-path path
		change path next split-path path/1
		case/all [
			none? path/2 [raise "Not a Valid Filename to Render"]
			none? path/1 [change path any [scope qm/view-path]]
			none? path/1 [raise "No View Scope"]
			partial? [insert path/2 %_]
		]
		return rejoin path
	]

	render3p: func [[catch] format [file!] body [string!] locals [block!]][
		all [
			format: rejoin [%render/ next format %.r]
			format: know format
			function? format: get in format 'renders
			format: format body locals
			format locals
		]
	]

	render: build: func [
		[catch] body [file! string!]
		/partial /with locals [block!]
		/type format /local out
	][
		if depth* > 20 [return ""]
		depth*: depth* + 1

		locals: either locals [
			map/copy locals func [word][
				reduce [to-set-word word get/any word]
			]
		][[]]

		out: case/all [
			file? body [
				format: suffix? body: clean-view-path body partial
				body: read root/:body
			]
			string? body [
				either any [none? format format = %.rsp][
					format: load-rsp body
					format locals
				][
					throw-on-error [render3p format body locals]
				]
			]
		]

		depth*: depth* - 1
		return out
	]

	render-each: func [
		'items [word! block!]
		source [series!]
		body [file! string!]
		/whole /with locals /local out
	][
		out: copy ""
		locals: append any [locals []] items: envelope items
		foreach :items source compose/only [
			append out do either whole ['render/with]['render/partial/with] body (locals)
		]
		return out
	]

	export [clean-view-path render build]
]

;--## ROUGHCUTDB
;-------------------------------------------------------------------##
context [
	space: qm://space/
	; locate: func [port id][space/(port/locals/locate id)]

	sw*: get in system 'words

	table!: context [
		name: header: spec: index: root: path: changed: #[none]
		locate: func [id][form id]
		record: context [
			id: new?: owner: root: path: #[none] data: []
			on-load: on-save: on-create: on-change: on-delete: #[none]
			get: func [key [word!]][select data key]
			set: func [key [word!] val][unset key val repend data [key val] val]
			unset: func [key [word!]][remove-each [k v] data [k = key]]
			store: func [[catch]][
				case [
					not new? [change owner self self]
					not unique? [errors: [id ["Record ID already exists."]] none]
					else [append owner self self]
				]
			]
			destroy: does [unless new? [remove find head owner id]]
			inject: func [pending][
				unless block? :pending [return none]
				foreach [key val] pending [set key val]
			]
			unique?: does [not find owner/locals/index get 'id]
			injects: func [spec [block!] /local out][
				func [args] compose/only/deep [
					case [
						not block? :args [none]
						out: import/report-to args (spec) errors [
							inject out out
						]
						parse args [any [word! skip]][
							inject args none
						]
					]
				]
			]
			errors: []
		]
	]

	; INTERFACE
	add-protocol roughcut 0 context [
		port-flags: system/standard/port-flags/pass-thru

		shift: func [port][
			port/locals/index: skip head port/locals/index port/state/index
			port
		]

		commit: func [[catch] block /local status][
			loop 30 [
				if status: not exists? space/lock.r [break]
				wait 0.005
			]

			either status [
				touch space/lock.r
				do block
				delete space/lock.r
			][
				delete space/lock.r
				raise "Database locked"
			]
		]

		init: func [port spec [url!]][
			unless port/locals: make table! port/locals [
				raise ["Could not load model <" port/locals/name ">"]
			]
			with port/locals [
				root: path: (any [port/locals/header/home dirize space/:name])
				changed: (modified? space/:name/index.r)
			]
		]

		open: func [[catch] port [port!]][
			update port

			with port [
				with state [
					index: 0
					flags: flags or port-flags
				]
			]
		]

		select: func [port criteria /local result record][
			case [
				criteria = 'new [
					result: make port/locals/record compose [
						new?: #[true]
						owner: :port
						data: sw*/copy data
					]
					result/on-create
					result
				]
				block? criteria [
					result: sw*/copy []
					forall port [
						record: first port
						if with record criteria [
							append result record
						]
					]

					; while [port: find port criteria][
					; 	append result first port
					; 	port: next port
					; ]

					:result
				]
				criteria [
					all [
						port: find port criteria
						; index? port
						first port
					]
				]
			]
		]

		find: func [port [port!] criteria /local index][
			shift port

			case [
				block? criteria [ ; reserved for query dialect
					; none
				]
				criteria [
					all [
						index: sw*/find head port/locals/index criteria
						port: at head port index? index
					]
				]
			]
		]

		pick: func [port [port!] /local id root][
			shift port

			all [
				id: sw*/pick port/locals/index 1
				root: dirize join port/locals/root port/locals/locate id
				make port/locals/record compose [
					id: (id)
					owner: port
					root: path: (root)
					data: load/all root/index.r
					on-load
				]
			]
		]

		insert: func [port [port!] record [object!] /local id root][
			update port

			unless case/all [
				not object? record [raise "Not a RoughCut Active Record"]
				not id: record/get 'id [raise "Active Record needs an ID"]
				sw*/find head port/locals/index id [
					raise "ID already exists"
				]
				error? root: try [port/locals/locate id][:root]
			][
				record/id: :id
				record/root: record/path: port/locals/root/:root
				record/new?: false

				commit [
					record/on-save
					new-line/all/skip record/data true 2

					save/all record/root/index.r record/data
					head sw*/insert port/locals/index record/id
					update/set port
				]
			]
		]

		change: func [port [port!] record [object!]][
			unless case/all [
				not object? record [raise "Not a RoughCut Active Record"]
				not sw*/find head port/locals/index record/id [
					raise "Active Record ID not found"
				]
			][
				commit [
					record/on-change
					record/on-save

					new-line/skip/all record/data true 2
					save/all record/root/index.r record/data
				]
			]
		]

		remove: func [port [port!] /local record][
			update port

			loop port/state/num [
				record: first port

				commit [
					record/on-delete

					delete/pare record/root
					sw*/remove port/locals/index
					update/set port
				]
			]
		]

		update: func [port [port!] /set][
			with port/locals [
				either set [
					save/all root/index.r new-line/all head index true
					changed: now
				][
					unless all [
						exists? root/index.r
						index: load root/index.r
					][
						write root/index.r ""
						changed: now
						index: sw*/copy []
					]
				]

				port/state/tail: length? head index
			]

			shift port
		]

		copy: func [port [port!]][
			update port
			map sw*/copy/part port/locals/index port/state/num func [id][
				select port id
			]
		]

		close: func [port [port!]][port/locals/index: none]
	]
]

;--## MODELS
;-------------------------------------------------------------------##
context [
	root: qm://system/models/

	engage-model: has [specs type][
		specs: map read/custom root [chars-a any chars-f %.r] func [spec][
			reduce [to-word form copy/part spec find spec %.r spec]
		]

		qm/models: context map-each [name file] specs [
			name: to-set-word name
		]

		map-each [name spec] specs [
			spec: bind load/header root/:spec qm/models
			type: get in spec/1 'type
			spec: compose [
				name: (to-lit-word name)
				header: (spec)
			]
			spec: switch type?/word type [
				word! [
					spec: compose/only [scheme: (to-lit-word type) locals: (spec)]
					unless attempt [spec: open spec][
						raise ["Error opening Model: %models/" name ".r <" type "::" name ">"]
					]
					spec
				]
				none! [context bind spec qm/models]
			]
			set in qm/models name spec
		]

		qm/models
	]

	disengage-model: does [
		foreach spec next first qm/models [
			if port? spec: get in qm/models spec [close spec]
		]
	]
	export [engage-model disengage-model]
]

;--## CONSOLE SESSION STOPS HERE
;-------------------------------------------------------------------##
unless system/options/cgi/request-method [
	all [system/product = 'base know %core/help.r]
	recycle halt
]


;--## REQUEST
;-------------------------------------------------------------------##
qm/request: make system/options/cgi [
	controller: action: input: none
	remote-addr: as tuple! remote-addr

	get-header: func [name][select other-headers form name]

	clear find request-path: copy request-uri: as file! any [
		get-env "REQUEST_URI"
		get-header "HTTP_INTERNAL_REFERER"
		"/"
	] "?"

	path-info: parse/all remove copy request-path "/"

	query: decode-query query-string

	cookies: all [
		cookies: select other-headers "HTTP_COOKIE"
		parse cookies ";="
	]

	cookies: any [cookies []]

	map cookies :url-decode

	; Must fix 'decode-options
	; accept-types: decode-options select other-headers "HTTP_ACCEPT" path!
	; accept-languages: decode-options select other-headers "HTTP_ACCEPT_LANGUAGE" word!
	; accept-encodings: decode-options select other-headers "HTTP_ACCEPT_ENCODING" word!
	; accept-charsets: decode-options select other-headers "HTTP_ACCEPT_CHARSET" word!

	content-limit: config/post-limit
	content-boundary: #[none]

	content-type: as path! content-type
	type: none

	all [
	  ;--- content length ---
		content-length: any [as integer! content-length 0]
		0 < content-length

	  ;--- content type ---
		parse form content-type [
			[
				"text/" [
					  opt "x-" "rebol" (type: /rebol)
					| "xml" (type: /xml)
					| opt "x-" "json" (type: /json)
				]
				| "application/" [
					  "x-www-form-urlencoded" (type: /url-encoded)
					| "xml" (type: /xml)
				]
				| "multipart/form-data;" "boundary=" content-boundary: some chars (
					type: /multipart
					content-boundary: join "--" content-boundary
				)
			]
		]
	]

	;-- body is the raw data from the HTTP request
	body: func [/binary /local tmp][
		body: copy either binary [#{}][{}]
		set-modes system/ports/input [lines: false]
		unless binary [set-modes system/ports/input [binary: false]]
		body: copy system/ports/input
		; body: copy/part system/ports/input content-length
		; ^^^^^^^^ problem, not sure why...
	]

	if find server-software "Cheyenne" [
		input: get in system/words 'input

		body: func [/binary][
		 	body: either all [
				body: :input
				content-length = length? body
			][body][#{}]
			either binary [body][to-string body]
		]
	]

	;-- content is the body 'loaded' according to the content-type header
	content: func [[catch]][
		throw-on-error [
			content: switch type [
				/url-encoded [decode-query body]
				/rebol [attempt [load/header body]]
				/multipart [
					; know %qm/multipart.r
					load-multipart body/binary content-boundary
				]
			]
		]
		any [content []]
	]

	get-cookie: func [name][select cookies form name]
	get-param: func ['name /query /body /local result][
		result: copy [query #[none] body #[none]]
		unless body [result/query: get-from self/query :name]
		unless query [result/body: get-from self/content :name]
		any [result/query result/body]
	]

	export [get-header get-cookie get-param]
]

;--## RESPONSE
;-------------------------------------------------------------------##
qm/response: context [
	status: 200
	headers: make string! ""
	type: 'text/html
	charset: "utf-8"

	template: length: body: #[none]

	set-header: func [header value][
		repend headers [header ": " value newline]
	]

	clear-cookie: func [key /path root /domain base][
		key: join form key "=; expires=Thu, 01 Jan 1970 00:00:00 GMT"
		repend key ["; path=" any [root %/]]
		if domain [repend key ["; domain=" base]]
		set-header 'Set-Cookie key
	]

	set-cookie: func [key value /expires on [date!] /path root /domain base][
		value: rejoin [form key "=" url-encode value]
		if expires [append value form-date/gmt on "; expires=%a, %d %b %Y %T GMT"]
		repend value ["; path=" any [root %/]]
		if domain [repend value ["; domain=" base]]
		set-header 'Set-Cookie value
	]

	export [set-header set-cookie clear-cookie]
]

;--## VIEW
;-------------------------------------------------------------------##
context [
	status-codes: [
		200 "OK" 201 "Created" 204 "No Content"
		301 "Moved Permanently" 302 "Moved temporarily"
		400 "Bad Request" 401 "No Authorization" 403 "Forbidden" 404 "Not Found" 411 "Length Required"
		500 "Internal Server Error" 503 "Service Unavailable"
	]

	log: #[none]

	probe: func [data][
		log: append any [log "^/"] mold :data
		append log newline
		return :data
	]

	send-response: func [body [string! binary!]][
		system/ports/output/state/with: "^/"
		; body: join body ["<div><b>" difference now/precise st "</b></div>"]
		write-io system/ports/output body length? body
		close system/ports/output
		body
	]

	if find qm/request/server-software "Cheyenne" [
		send-response: func [body [string! binary!]][
			prin to-string body
		]
	]

	publish: has [yield][
		with qm/response [
			either yield: body: case [
				any [none? body empty? body][" "]
				string? body [render body]
				file? body [render body]
				binary? body [body]
			][
				body: any [
					all [
						any [file? template string? template]
						render/with template [yield]
					]	
					yield
				]
			][
				status: 404 body: any [render %errors/notfound.rsp "Not Found..."]
			]

			case/all [
				any [none? body empty? body][body: " "]

				log [
					either find body </body> [
						insert find body </body> rejoin [
							{^/<div id="_log"><h1>Log</h1><pre><code>}
							remove sanitize log
							{</code></pre></div>^/}
						]
					][
						repend body ["^/" log]
					]
				]

				; find request/accept-encodings 'deflate [
				; 	set-header 'Content-Encoding "deflate"
				; 	; IE and Safari need deflate header and footer removed
				; 	clear skip tail remove remove body: compress body -8
				; ]
			]

			unless find status-codes status [status: 500]
			status: reform ["Status:" status select status-codes status]

			set-header 'Content-Type either find [text application] type/1 [
				rejoin [form type "; charset=" charset]
			][form type]

			set-header 'Content-Length length? body

			insert body reduce [status newline headers newline]

			send-response body
		]
	]

	export [publish probe]
]

;--## CONTROLLER
;-------------------------------------------------------------------##
context [
	root: qm://system/controllers/

	rendered?: #[false]

	redirect-to: func [[catch] 'url [file! url! path! none!] /back /status response-code [integer!]][
		if rendered? [raise "Already Rendered!"]

		qm/response/status: any [response-code 302]
		qm/response/template: #[none]
		case [
			all [back back: as url! get-header "HTTP_REFERER"][url: :back]
			none? url [raise "Redirect requires a valid URL"]
			all [file? url not #"/" = first url][insert url #"/"]
			path? url [url: link-to :url]
		]
		qm/response/set-header 'Location url

		rendered?: #[true]
	]

	render: func [
		[catch]
		body [file! string! url! binary! none!]
		/status code [integer!]
		/as 'type [path!]
		/template master [file! string! url! binary! none!]
		/partial
		/charset encoding
		/local path
	][
		if rendered? [raise "Already Rendered!"]

		qm/response/body: :body

		case/all [
			status [qm/response/status: :code]
			as [qm/response/type: :type]
			file? body [
				qm/response/body: clean-view-path body partial
			]
		]

		qm/response/template: case [
			binary? body [none]
			all [partial not template][none]
			not template [qm/response/template]
			file? master [clean-view-path master false]
			string? master [master]
		]

		rendered?: #[true]
	]

	print: func [value][render/as/template reform value text/plain none]

	load-controller: use [actions event action filter current][
		actions: []

		action: use [name class options][
			class: context options: [spec: code: none]
			with/only class [
				(with class options)
				'action set name string! set spec opt block!
				'does set code block! (repend actions ['action name make class []])
			]
		]

		event: use [name code][
			[
				'event set name string! 'does set code block!
				(repend actions ['event name code])
			]
		]

		filter: use [names test code][
			[
				'protect copy names some string!
				set test paren! set code block!
				(repend actions ['filter names reduce [test code]])
			]
		]

		func [[catch] name /local file meta][
			actions: copy []

			unless all [
				(all [name name <> ""])
				(exists? file: join root [name %.r])
				(block? file: load/header file)
				('controller = get in meta: pop file 'type)
			][
				return none
			]

			insert actions meta
			unless parse/all file [some [action | event | filter]][
				name: rejoin ["Invalid Controller Spec: %controllers/" name ".r"]
				raise :name
			]

			actions
		]
	]

	route: func [request [object!] /local actions file default args code] with/only qm [
		controller: any [
			pop request/path-info
			config/default-controller
		]

		if all [
			controller controller/1 = #"_"
		][
			render "Invalid Controller"
			exit
		]

		unless actions: load-controller controller [
			; render "No Controller"
			render/status %errors/notfound.rsp 404
			exit
		]

		response/template: get in actions/1 'template

		use [default][
			request/action: pick request/path-info 1
			default: get in actions/1 'default

			case [
				find actions reduce ['action request/action][
					remove request/path-info
					action: request/action
				]
				find actions reduce ['action default][
					action: default
				]
				else [
					raise "No Action"
					; render/status %errors/notfound.rsp 404
					exit
				]
			]
		]

		use [startup][
			all [
				startup: load-controller "_startup"
				insert tail actions next startup
			]
		]

		foreach [type scope details] next actions with/only events: context [
			start: prepare: filter: this: none
		][
			case [
				type = 'event [
					switch scope [
						"web-start" [start: :details]
						"prepare" [prepare: any [prepare details]]
					]
				]
				all [
					type = 'filter
					find scope action
				][
					filter: append any [filter []] details
				]
				scope = action [
					this: any [this details]
				]
			]
		]

		unless events/this [
			response/template: none
			render/status %errors/notfound.rsp 404
			exit
		]

		unless args: import/block request/path-info any [events/this/spec []][
			response/template: none
			render/status %errors/badrequest.rsp 400
			; print "Bad Request" exit
			exit
		]

		view-path: dirize to-file controller

		qm: make qm context with/only qm with/only 'route compose/deep [
			(third models)
			header: (first actions)
			title: (rejoin [uppercase/part form controller 1 " :: " uppercase/part form action 1])
			(events/start)
			(events/prepare)
			(map-each [word value] args [word: to-set-word word])
			case [
				(any [events/filter []])
				else [(events/this/code)]
			]
		]

		qm/binding: in qm 'self
		either rendered? [#[true]][
			if action [
				render head insert %.rsp action
			]
		]
	]

	export [route]
]

;--## ENGAGE
;-------------------------------------------------------------------##
try-else [
	with qm [
		engage-model
		route request
		disengage-model
		publish response
	]
][
	reason: make disarm reason []

	qm/binding: 'reason
	qm/handler: %.rsp

	reason-type: sanitize system/error/(reason/type)/type
	reason-message: sanitize reform bind envelope system/error/(reason/type)/(reason/id) reason
	reason-where: sanitize mold reason/where

	with qm/response [
		status: 500
		type: 'text/html
		template: #[none]
		body: trim/head trim/with {
			<html><head>
			<title>Error: <%= reason-type %></title>
			<link href="/styles/anywhere.css" rel="stylesheet" type="text/css" /></head>
			<body>
			<h1>QuarterMaster</h1>
			<h2>Error Message</h2>
			<pre><code>** <%= reason-type %>: <%= reason-message %>
			** Where: <%= reason-where %>
			** Near: <%= sanitize mold reason/near %></code></pre>
			</body>
			</html>
		} #"^-"
	]

	publish
]