#!/usr/local/bin/rebol -c
Rebol [
Title: "QuarterMaster"
Author: "Christopher Ross-Gill"
Version: 0.3.12
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 [_dbg: find/tail/last any [system/options/cgi/query-string ""] "&debug=" _dbg: tail? _dbg] [
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
]
envelop: envelope: func [val [any-type!]][either any-block? val [val][reduce [val]]]
raise: func [[catch] reason][throw make error! rejoin envelop 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 envelop 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: envelop 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 envelop 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: envelop 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: envelop ser/1]
block! [ser: ser/1]
]
if tail? key [append ser val]
]
]
get-from: func [series 'key][
key: copy envelop 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
]
sanitize: func [text [any-string!] /local char][
parse/all copy text [
copy text any [
text: some chars-ht
| #"&" (text: change/part text "&" 1) :text
| #"<" (text: change/part text "<" 1) :text
| #">" (text: change/part text ">" 1) :text
| #"^"" (text: change/part text """ 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 #"&" "&"
; replace/all text #"<" "<"
; replace/all text #">" ">"
; replace/all text #"^"" """
; ]
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 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: <" cmd ">"]
]
]
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: envelop 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 envelop 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
]