REBOL [ Title: "Rugby" Date: 15-Aug-2001/15:34:57+2:00 Version: 4.0.2 File: %rugby4.r Author: "Maarten Koopmans" Needs: "Command 2.0+ , Core 2.5+ , View 1.1+" Purpose: {A high-performance, handler based, server framework and a rebol request broker...} Comment: {Many thanx to Ernie van der Meer for code scrubbing. Added touchdown and view integration. ^-^-^-^-^-^-Fixed non-blocking I/O bug in serve and poll-for-result. ^-^-^-^-^-^-Added trim/all to handle large binaries in decompose-msg. -Added deferred and oneway refinements to sexec -Added automated stub generation and rugbys ervice import (thanks Ernie!) -Added /no-stubs refinement to serve and secure-serve -Added get-rugby-service function -Removed poll-for-result -Added get-result function -Added result-ready? function -Added get-secure-result function -Added secure-result-ready? function } Email: %m--koopmans2--chello--nl library: [ level: 'advanced platform: none type: none domain: [GUI tcp other-net ldc] tested-under: none support: none license: none see-also: none ] ] hipe-serv: make object! [ ; The list of ports we wait/all for in our main loop port-q: copy [] ; Mapping of ports to objects containg additional info object-q: copy [] ; Our main server port server-port: none ; The handler for server [ currently only rugby, you can imagine http etc...] my-handler: none ; Restricted server list restricted-server: make block! 20 ; Server restrictions? restrict: no restrict-to: func [ {Sets server restrictions. The server will only serve to machines with the IP-addresses found in the list.} r [any-block!] {List of IP-addresses to serve.} ] [ restrict: yes append restricted-server r ] allow?: func [ {Checks if a connection to the specified IP-address is allowed.} ip [tuple!] {IP-address to check.} ] [ return found? find restricted-server ip ] port-q-delete: func [ {Removes a port from our port list.} target [port!] ] [ remove find port-q target ] port-q-insert: func [ {Inserts a port into our port list.} target [port!] ] [ append port-q target ] object-q-insert: func [ {Inserts a port and its corresponding object into the object queue.} target [port!] /local o ] [ append object-q target o: make object! [port: target handler: :my-handler user-data: none] append object-q o ] object-q-delete: func [ {Removes a port and its corresponding object from the object queue.} target [port!] ] [ remove remove find object-q target ] start: func [ {Initializes everything for a client connection on application level.} conn [port!] ] [ set-modes conn [ no-wait: true ] port-q-insert conn object-q-insert conn ] stop: func [ {cleans up after a client connection.} conn [port!] /local conn-object ] [ port-q-delete conn error? try [ conn-object: select object-q conn close conn-object/port object-q-delete conn ] ] init-conn-port: func [ {Initializes everything on network level.} conn [port!] ] [ either restrict [ either allow? conn/remote-ip [ start conn return ] [ close conn return ] ] ; No restrictions [ start conn return ] ] init-server-port: func [ {Initializes our main server port.} p [port!] conn-handler [any-function!] ] [ server-port: p append port-q server-port ; Increase the backlog for this server. 15 should be possible (default ; is 5) server-port/backlog: 15 my-handler: :conn-handler open/direct/no-wait server-port ] process-ports: func [ {Processes all ports that have events.} portz [block!] {The port list} /local temp-obj ] [ foreach item portz [ either (item = server-port) [ init-conn-port first server-port ] [ if item/scheme = 'tcp [ temp-obj: select object-q item temp-obj/handler temp-obj ] ] ] ] serve: func [ {Starts serving. Does a blocking wait until there are events.} /local portz ] [ forever [ portz: wait/all port-q process-ports portz ] ] ] ; This object implements the server side of a request broker. rugby-server: make hipe-serv [ ; Block containg words that are allowed to be executed. exec-env: none ; Block containing generated stub code. stubs: none build-stubs: func [ {Builds stub code that allows remote invocation of exposed functions asif they were local to the client.} expose-list [block!] {List of functions to expose.} /insecure {Use rexec instead of sexec for remote execution.} /with port [port!] {Port the server is listening on.} /local stub code args header elem ] [ ; Generate code to open the correct port. stub: copy [__rugby-server-address: make port! rejoin ] append/only stub reduce [ tcp:// system/network/host-address ":" either with [port/port-id ][8001]] ; Generate a local function that calls sexec/rexec. append stub [__local-rexec: func [statement [block!]]] append/only stub either insecure [ [ return rexec/with statement __rugby-server-address ] ] [ [ return sexec/with statement __rugby-server-address ] ] ; Generate the server stub. foreach elem expose-list [ ; Get the function header, with documentation, but strip the ; refinements, since we don't support those (yet?). parse third get/any elem [ copy header to refinement! | copy header to end ] ; Get the function header, without documentation, and with ; refinements stripped. parse first get/any elem [ copy args to refinement! | copy args to end ] ; Make sure we don't have headers and/or arguments that are none. if none? header [ header: copy []] if none? args [ args: copy []] ; Compose the stub function with documentation. code: reduce [ to-set-word elem 'func header] append/only code compose/deep [return __local-rexec reduce [ (to-lit-word elem) (args) ]] ; Add this function to the rest of the stubs. Remove stray ; newlines that may have come from the original header. append stub do trim/lines mold code ] return stub ] get-stubs: func [] [ return stubs ] nargs: func [ {Gets the number of function arguments.} f [any-function!] ] [ -1 + index? any [find first :f refinement! tail first :f] ] fill-0: func [ {Zero-extends a string number.} filly [string!] how-many [integer!] /local fills ] [ loop how-many - length? filly [ insert filly "0" ] return filly ] compose-msg: func [ {Creates a message for on the wire transmission.} msg [any-block!] ] [ f-msg: reduce [checksum/secure mold do mold msg msg] return mold compress mold f-msg ] clear-buffer: func [ cleary [port!] /local msg size-read] [ msg: copy {} until [ size-read: read-io cleary msg 1 1 = size-read ] ] decompose-msg: func [ {Extracts a message that has been transmitted on the wire.} msg [any-string!] ] [ return do decompress do trim/all msg ] check-msg: func [ {Check message integrity.} msg [any-block!] ] [ return (checksum/secure mold second msg) = first msg ] write-msg: func [ {Does a low-level write of a message.} msg dest [port!] /local length ] [ set-modes dest [ no-delay: true] ; We try to write at least 16000 bytes at a time either 16000 > length? msg [ length: write-io dest msg length? msg ; Message written, we're done either length = length? msg [ return true ] ; We're not done. Return what we have written [ return length ] ]; either 16000 > first clause [ length: write-io dest msg 16000 ] ; We're done, port is closed if 0 > length [ return true] return length ] safe-exec: func [ {Safely executes a message. Checks the exec-env variable for a list of valid commands to execute.} statement [any-block!] env [any-block!] /local n stm err ] [ if found? (find env first statement) [ n: nargs get to-get-word first statement stm: copy/part statement (n + 1) return do stm ] make error! rejoin [ "Rugby server error: Unsupported function: " mold statement ] ] do-message: func [ {High-level 'do' of a message.} msg [any-string!] /local f-msg size-read ] [ f-msg: decompose-msg msg either check-msg f-msg [ return safe-exec pick f-msg 2 exec-env ] [ make error! rejoin [ "Rugby server error: Message integrity check" " failed: " pick f-msg 2 ] ] ] do-handler: func [ {The rugby server-handler (my-handler in hipe-serv).} o /local msg ret size size-read result ] [ ; This handler does its work in 3 parts ; 1) Read the message size ; 2) Read the message ; 3) do the message ; 4) Return the result ; 1) and 2) and 4) may be done inmultiple steps because of the saync I/O ; First, we expect 8 bytes and use user-data initially to store that if (none? o/user-data) [ o/user-data: copy {} ]; if ; If we are not an object we are initialized to a string if (not object? o/user-data ) [ error? try [ ; Read the first 8 bytes that contain the total message size ; message size =< 99.999.999 size: copy {} ; size-read: length? msg: copy o/port msg: copy/part o/port (8 - (length? o/user-data)) size-read: length? msg either (size-read = ( 8 - (length? o/user-data))) [ ; What's the total size size: copy o/user-data append size copy/part msg (8 - (length? o/user-data)) remove/part msg (8 - (length? o/user-data)) if (0 < (length? msg)) [ size: (to-integer size) - length? msg ] ; And make an object of our user-data o/user-data: context [ task: copy msg rest: to-integer size ret-val: copy {} msg-read: false ret-val-written: false task-completed: false header-written: false header-length: copy "0" ]; context ] [ o/user-data: append o/user-data msg ]; either unset 'size ]; try return ]; if not object? ; Read the actual message if (not o/user-data/msg-read) [ ; Now try to read the rest of the message if (error? try [ msg: copy {} size-read: length? msg: copy/part o/port o/user-data/rest ]) [ return] if 0 = size-read [return] o/user-data/task: append o/user-data/task msg o/user-data/rest: (o/user-data/rest - size-read) if (o/user-data/rest = 0) [ o/user-data/msg-read: true ] return ] ; Do our task and compose our return message if not o/user-data/task-completed [ ret: copy [] if error? set/any 'result try [ do-message o/user-data/task ] [ result: disarm result ] ;Do we have a return value at all? if not unset? get/any 'result [ append/only ret result ] o/user-data/ret-val: compose-msg ret o/user-data/header-length: fill-0 to-string length? o/user-data/ret-val 8 o/user-data/task-completed: true ] ; Write out the header (length of what follows) if not o/user-data/header-written [ wr-res: write-msg o/user-data/header-length o/port either logic? wr-res [ o/user-data/header-written: true ] [ remove/part o/user-data/header-length wr-res ]; either return ] ; Write out our return message in batches if not o/user-data/ret-val-written [ wr-res: write-msg o/user-data/ret-val o/port o/user-data/ret-val either logic? wr-res [ o/user-data/ret-val-written: true clear-buffer o/port stop o/port ] [ remove/part o/user-data/ret-val wr-res ]; either return ] ]; do-handler init-rugby: func [ {Inits our server according to our server port-spec and with rugby's do-handler} port-spec [port!] x-env [any-block!] ] [ exec-env: copy x-env ; Build the stubs and store them in our object variable. stubs: build-stubs/insecure/with x-env port-spec init-server-port port-spec :do-handler ] go: func [ {Start serving.} ] [ serve ] ] set 'get-stubs get in rugby-server 'get-stubs serve: func [ {Exposes a set of commands as a remote service} commands [block!] {The commands to expose} /with {Expose on a different port than tcp://:8001} p [port! url!] {Other port} /restrict {Restrict access to a block of ip numbers} r [block!] {ip numbers} /nostubs {Don't provide access to stubs with get-stubs function.} /local local-commands dest ] [ local-commands: copy commands ; We only add a function to get at the stubs if we are asked to. if not nostubs [ append local-commands [ get-stubs ] ] if restrict [ rugby-server/restrict-to r ] either with [ either url? p [ dest: make port! p ] [ dest: p ] rugby-server/init-rugby dest local-commands ] [ rugby-server/init-rugby make port! tcp://:8001 local-commands ] rugby-server/serve ] ;*** RUGBY CLIENT *** ; Rugby's client side rugby-client: make object! [ ; List of ports for deferred requests deferred-ports: copy [] deferred-index: 0 fill-0: func [ {Zero-extends a string number.} filly [string!] how-many [integer!] /local fills ] [ loop how-many - length? filly [ insert filly "0" ] return filly ] compose-msg: func [ {Creates a message for on the wire transmission.} msg [any-block!] ] [ f-msg: reduce [checksum/secure mold do mold msg msg] return mold compress mold f-msg ] decompose-msg: func [ {Extracts a message that has been transmitted on the wire.} msg [any-string!] ] [ return do decompress do trim/all msg ] check-msg: func [ {Check message integrity.} msg [any-block!] ] [ return (checksum/secure mold second msg) = first msg ] write-msg: func [ {Writes a message on the port.} msg [any-block!] dest [port!] /local length f-msg ] [ f-msg: compose-msg msg length: fill-0 to-string length? f-msg 8 write-io dest length 8 write-io dest f-msg length? f-msg ;the xtra byte to keep the server i/o engine running write-io dest length 1 ] rexec: func [ {Does a high-level rexec.} msg [any-block!] /with p [port! url!] /oneway /deferred /local res dest holder err ] [ ;Is there a port specified? Otherwise defaultto localhost:8001 dest: either with [ ;Do we have a url or port? either url? p [ make port! p ] [ p ] ] [ make port! tcp://127.0.0.1:8001 ] ; Open the destination port. open/no-wait/direct dest ; Write the command to the port. write-msg msg dest ; Create a holder object for the pending request and append it to ; the deffered ports list. holder: make object! [ port: dest data: copy {} length: none ] deferred-index: 1 + deferred-index append deferred-ports deferred-index append deferred-ports holder deferred-ports ; Are we required to wait for the result? if not any [oneway deferred] [ return wait-for-result deferred-index ] ; Deferred requests must return the index of the holder object. if deferred [ return deferred-index ] return true; ] result-available?: func [ {Determines whether a deferred port has results available.} index [integer!] {Deferred port to check.} /local dport msg size-read ] [ dport: select deferred-ports index if not object? dport [ make error! rejoin [ "Rugby client error: result-available:" " Failed to locate deferred port object" ] ] ; Bluntly try to read some more data from the port, even though we ; may already have everything. msg: make string! 512 size-read: read-io dport/port msg 512 if size-read >= 0 [ append dport/data msg ] either 8 <= length? dport/data [ dport/length: 8 + to-integer copy/part dport/data 8 length? dport/data ; Check if we have all the return data available. either all [dport/length dport/length <= length? dport/data] [ return true ] [ return false ] ] [ return false ] ] get-result: func [ {Closes the deferred port and returns any results that are present in the port. Be careful not to call this function unless you are sure that the port has data available, or you may end up with partial results! Use result-available? to make sure that data is present} index [integer!] /local msg dport ] [ if not result-available? index [ make error! "Rugby error: No result available yet." ] dport: select deferred-ports index if not object? dport [ make error! rejoin [ "Rugby client error: get-result:" " Failed to locate deferred port object" ] ] close dport/port msg: decompose-msg skip dport/data 8 remove/part find deferred-ports index 2 either check-msg msg [ return do pick msg 2 ] [ make error! rejoin [ "Rugby client error: Return message" " integrity check failed on" mold pick msg 2] ] ] wait-for-result: func [ index [integer!] ] [ until [ result-available? index ] return get-result index ] get-rugby-service: func [ target [url! port!] /secure-code /local dest] [ either url? target [ dest: make port! target ] [ dest: target ] either secure-code [ return rexec/with [ get-secure-stubs ] dest ] [ return rexec/with [ get-stubs ] dest ] ] ];context ; Some wrappers in the global environment ; Feature suggestion by Allen Kamp set 'rexec get in rugby-client 'rexec set 'wait-for-result get in rugby-client 'wait-for-result set 'result-available? get in rugby-client 'result-available? set 'get-result get in rugby-client 'get-result set 'get-rugby-service get in rugby-client 'get-rugby-service ;*** TOUCHDOWN SERVER *** touchdown-server: make object! [ key: none init-key: does [ if not key [ if any [ not exists? %tdserv.key error? try [ key: do read %tdserv.key ] ] [ ; We either don't have the key file, or there was an error ; reading it. Let's generate a new one. key: rsa-make-key key rsa-generate-key key 512 3 error? try [write %tdserv.key mold key ] ] ] ] get-public-key: does [ return key/n] get-session-key: func [ s-key [binary!] /local k] [ k: rsa-encrypt/decrypt/private key s-key return k ] decrypt: func [ msg [binary!] k [binary!] /local res dec-port crypt-str] [ crypt-str: 8 * length? k dec-port: open make port! [ scheme: 'crypt algorithm: 'blowfish direction: 'decrypt strength: crypt-str key: k padding: true ] insert dec-port msg update dec-port res: copy dec-port close dec-port return to-string res ] encrypt: func [ msg [binary! string!] k [binary!] /local res enc-port crypt-str] [ crypt-str: 8 * length? k enc-port: open make port! [ scheme: 'crypt algorithm: 'blowfish direction: 'encrypt strength: crypt-str key: k padding: true ] insert enc-port msg update enc-port res: copy enc-port close enc-port return res ] get-message: func [ msg [binary!] dec-key [binary!] /local crypto-port crypto-strength answ] [ answ: decrypt msg dec-key return answ ] get-return-message: func [ enc-key [binary!] /with r /local blok msg] [ blok: copy [] ;Insert only if we have a value if with [ append/only blok r ] msg: encrypt mold blok enc-key return msg ] sexec-srv: func [ stm [block!] /local str-stm stm-blk ret ] [ stm-blk: do get-message do pick stm 2 get-session-key do pick stm 1 set/any 'ret rugby-server/safe-exec stm-blk rugby-server/exec-env either value? 'ret [ return get-return-message/with get-session-key do pick stm 1 ret] [ return get-return-message get-session-key do pick stm 1 ] ] ];touchdown-server negotiate: does [ return append append copy [] crypt-strength? touchdown-server/get-public-key ] get-secure-stubs: does [ return secure-stubs ] set 'sexec-srv get in touchdown-server 'sexec-srv secure-serve: func [ {Start a secure server.} statements [block!] /with {On a specific port} p {The port spec.}[port! url!] /restrict {Limit access to specific IP addresses} rs {Block of allowed IP addresses} [block!] /nostubs {Don't provide access to stubs with get-secure-stubs function.} /local s-stm ] [ touchdown-server/init-key ; Block containing generated secure stub code secure-stubs: none s-stm: append copy statements [ negotiate sexec-srv ] ;Build our function call if not nostubs [ ; Build the secure version of the stubs. either with [ dest: either url? p [ make port! p ] [ p ] secure-stubs: rugby-server/build-stubs/with s-stm dest ] [ secure-stubs: rugby-server/build-stubs s-stm ] ; And add a function to access them. append s-stm [ get-secure-stubs ] ] ; Call serve with the right refinements. either nostubs [ if all [with restrict] [ serve/nostubs/with/restrict s-stm p rs ] if with [ serve/nostubs/with s-stm p ] if restrict [ serve/nostubs/restrict s-stm rs ] serve/nostubs s-stm ] [ if all [with restrict] [ serve/with/restrict s-stm p rs ] if with [ serve/with s-stm p ] if restrict [ serve/restrict s-stm rs ] serve s-stm ] ] ;*** TOUCHDOWN CLIENT *** touchdown-client: make object! [ key-cache: copy [] deferred-keys: copy [] decrypt: func [ {Generic decryption function} msg [binary!] k [binary!] /local res dec-port crypt-str ] [ crypt-str: 8 * length? k dec-port: open make port! [ scheme: 'crypt algorithm: 'blowfish direction: 'decrypt strength: crypt-str key: k padding: true ] insert dec-port msg update dec-port res: copy dec-port close dec-port return to-string res ] encrypt: func [ msg [binary! string!] k [binary!] /local res enc-port crypt-st ] [ crypt-str: 8 * length? k enc-port: open make port! [ scheme: 'crypt algorithm: 'blowfish direction: 'encrypt strength: crypt-str key: k padding: true ] insert enc-port msg update enc-port res: copy enc-port close enc-port return res ] negotiate: func [ {Negotiates a session strengh and public rsa keyi with a touchdown server.} dest [port!] /local serv-strength ] [ if not found? find key-cache mold dest [ serv-strength: rexec/with [negotiate] dest serv-strength if not none? serv-strength [ append key-cache mold dest append key-cache serv-strength ] return serv-strength ] return select key-cache mold serv-strength ] generate-session-key: func [ {Idem.} crypt-str [integer!]] [ return copy/part checksum/secure mold now 16 ] secure-result-available?: func [ {Checks if a deferred result is available} index [integer!] ] [ result-available? index ] get-secure-result: func [ {Returns a secured result} index [integer!] /local s-key ret ] [ if not secure-result-available? index [ make error! "Touchdown error: secure result not available"] s-key: select deferred-keys index if none? s-key [ make error! "Touchdown error: no such index for sexec"] ret: get-result index either object? ret [ remove remove find deferred-keys index return ret ] [ set/any 'ret do get-return-message ret s-key remove remove find deferred-keys index return get/any 'ret ] ] wait-for-secure-result: func [ {Waits for a secured result} index [integer!]] [ until [secure-result-available? index] get-secure-result index ] generate-message: func [ stm [block!] s-key [binary!] r-key [object!] /local str-stm blk-stm crypt-port p-blk ] [ blk-stm: copy [ sexec-srv ] p-blk: copy [] append p-blk rsa-encrypt r-key s-key append p-blk encrypt mold stm s-key append/only blk-stm p-blk return blk-stm ] get-return-message: func [ stm s-key [binary!] /local ret ] [ set/any 'ret do decrypt stm s-key return get/any 'ret ] sexec: func [ {A secure exec facility a la rexec for /Pro and /COmmand users} stm [any-block!] /with dest [port! url!] /oneway /deferred /local port sst crypt-str r-key ps-key g-stm ret s-key def-index ] [ ;determine existing info either with [ port: either url? dest [ make port! dest] [ dest ] ] [ port: make port! tcp://localhost:8001 ] sst: negotiate port if none? sst [return none] either (crypt-strength? = 'full) [ either (first sst) = 'full [ crypt-str: 128 ] [ crypt-str: 56 ] ] [ crypt-str: 56 ] ;generate our session-key s-key: generate-session-key crypt-str ;get and initialize an rsa-key from the server's public key (second sst) ps-key: second sst r-key: rsa-make-key r-key/n: ps-key r-key/e: 3 ;generate our sexec message g-stm: generate-message stm s-key r-key ;rexec our sexec message if oneway [ return rexec/with/oneway g-stm port ] def-index: rexec/with/deferred g-stm port append deferred-keys def-index append deferred-keys s-key either deferred [ return def-index ] [ return wait-for-secure-result def-index ] ];sexec ];touchdown-client set 'sexec get in touchdown-client 'sexec set 'secure-result-available? get in touchdown-client 'secure-result-available? set 'wait-for-secure-result get in touchdown-client 'wait-for-secure-result set 'get-secure-result get in touchdown-client 'get-secure-result ;A function that can be used in conjunction with rugby and view. ;View any layout be4 starting to serve rugby-view: func [ "Displays a window face. Does not start the event loop." view-face [object!] /new "Creates a new window and returns immediately" /offset xy [pair!] "Offset of window on screen" /options opts [block! word!] "Window options [no-title no-border resize]" /title text [string!] "Window bar title" /local scr-face ][ scr-face: system/view/screen-face if find scr-face/pane view-face [return view-face] either any [new empty? scr-face/pane] [ view-face/text: any [ view-face/text all [system/script/header system/script/title] copy "" ] new: all [not new empty? scr-face/pane] append scr-face/pane view-face ] [change scr-face/pane view-face] if offset [view-face/offset: xy] if options [view-face/options: opts] if title [view-face/text: text] show scr-face view-face ] ;A sample server test function ;Start serving with "serve [echo]" echo: func [ e [string!]] [return e] ; Client test function. Shows how easy it is to do a remote exec client-test: does [ rexec [echo "Rugby is great!"] ]