REBOL [
    Title: "Rugby"
    Date: 8-Aug-2001/14:12:55+2:00
    Version: 3.4.0
    File: %rugby3.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.
Fixed rugby protocol.
^-^-}
    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!
[
    port-q: copy []
    object-q: copy []
    server-port: none
    my-handler: none
    restricted-server: make block! 20
    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
            ]
        ]
        [
            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
        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
        ]
    ]
]
rugby-server: make hipe-serv
[
    exec-env: none
    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] 
        either 16000 > length? msg 
        [
            length: write-io dest msg length? msg 
            either length = length? msg 
            [
                return true
            ] 
            [
                return length
            ]
        ] 
        [
            length: write-io dest msg 16000
        ] 
        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 res n stm err
    ] 
    [
        if found? (find env first statement) 
        [
            n: nargs get to-get-word first statement 
            res: none 
            stm: copy/part statement (n + 1) 
            res: do stm 
            return res
        ] 
        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 res size-read
    ] 
    [
        f-msg: decompose-msg msg 
        either check-msg f-msg 
        [
            res: safe-exec pick f-msg 2 exec-env 
            return res
        ] 
        [
            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
    ] 
    [
        if (none? o/user-data) 
        [
            o/user-data: copy ""
        ] 
        if (not object? o/user-data) 
        [
            error? try 
            [
                size: copy "" 
                msg: copy/part o/port (8 - (length? o/user-data)) 
                size-read: length? msg 
                either (size-read = (8 - (length? o/user-data))) 
                [
                    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] 
                    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"
                    ]
                ] 
                [
                    o/user-data: append o/user-data msg
                ] 
                unset 'size
            ] 
            return
        ] 
        if (not o/user-data/msg-read) 
        [
            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
        ] 
        if not o/user-data/task-completed 
        [
            ret: copy [] 
            if error? result: try [do-message o/user-data/task] 
            [
                result: disarm 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
        ] 
        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
            ] 
            return
        ] 
        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
            ] 
            return
        ]
    ] 
    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 
        init-server-port port-spec :do-handler
    ] 
    go: func 
    [
        "Start serving."
    ] 
    [
        serve
    ]
] 
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!] "Other port" 
    /restrict "Restrict access to a block of ip numbers" r [block!] "ip numbers"
] 
[
    if restrict 
    [
        rugby-server/restrict-to r
    ] 
    either with 
    [
        rugby-server/init-rugby p commands
    ] 
    [
        rugby-server/init-rugby make port! tcp://:8001 commands
    ] 
    rugby-server/serve
] 
rugby-client: make object! 
[
    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 
        write-io dest length 1
    ] 
    rexec: func 
    [
        "Does a high-level rexec." 
        msg [any-block!] 
        /with p [port!] 
        /oneway 
        /deferred 
        /local res dest holder err
    ] 
    [
        dest: either with [p] [make port! tcp://127.0.0.1:8001] 
        open/no-wait/direct dest 
        write-msg msg dest 
        holder: make object! 
        [
            port: dest 
            data: copy "" 
            length: none
        ] 
        deferred-index: 1 + deferred-index 
        append deferred-ports deferred-index 
        append deferred-ports holder 
        if not any [oneway deferred] 
        [
            return wait-for-result deferred-index
        ] 
        if deferred [return deferred-index] 
        return true
    ] 
    poll-for-result: func 
    [
        index [integer!] 
        /local o msg size-read
    ] 
    [
        o: select deferred-ports index 
        if not object? o 
        [
            make error! {Rugby client error: poll-for-result: Failed to locate deferred port object}
        ] 
        set-modes o/port [no-wait: true] 
        msg: make string! 512 
        size-read: read-io o/port msg 512 
        either 0 >= size-read 
        [
            return false
        ] 
        [
            append o/data msg
        ] 
        if all [none? o/length 8 <= length? o/data] 
        [
            o/length: 8 + to-integer copy/part o/data 8
        ] 
        either all [o/length o/length <= length? o/data] 
        [
            close o/port 
            msg: decompose-msg skip o/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]
            ]
        ] 
        [
            return false
        ]
    ] 
    wait-for-result: func 
    [
        index [integer!]
    ] 
    [
        until [poll-for-result index]
    ]
] 
set 'rexec get in rugby-client 'rexec 
wait-for-result: func 
[
    "Wait for the result to arrive" 
    index [integer!] "index of the result to wait for."
] 
[
    rugby-client/wait-for-result index
] 
poll-for-result: func 
[
    {Poll if the result has arrived. Return false or the value (or none in
   case of an error).} 
    index [integer!] "the index to poll for."
] 
[
    rugby-client/poll-for-result index
] 
touchdown-server: make object! 
[
    key: none 
    init-key: has [exists-key] 
    [
        if not key 
        [
            either error? try [exists-key: exists? %tdserv.key] 
            [
                key: rsa-make-key key 
                rsa-generate-key key 512 3
            ] 
            [
                either exists-key 
                [
                    if error? try [key: do read %tdserv.key] 
                    [
                        key: rsa-make-key key 
                        rsa-generate-key key 512 3
                    ]
                ] 
                [
                    key: rsa-make-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 [r enc-key [binary!] /local blok msg] 
    [
        blok: copy [] 
        append blok r 
        msg: encrypt mold blok enc-key 
        return msg
    ] 
    sexec-srv: func [stm [block!] /local str-stm stm-blk] 
    [
        stm-blk: do get-message do pick stm 2 get-session-key do pick stm 1 
        return get-return-message rugby-server/safe-exec stm-blk rugby-server/exec-env get-session-key do pick stm 1
    ]
] 
negotiate: does 
[
    return append append copy [] crypt-strength? touchdown-server/get-public-key
] 
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!] 
    /restrict "Limit access to specific IP addresses" rs "Block of allowed IP addresses" [block!] 
    /local s-stm
] 
[
    touchdown-server/init-key 
    s-stm: append copy statements [negotiate sexec-srv] 
    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: make object! 
[
    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
    ] 
    key-cache: copy [] 
    negotiate: func [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 [crypt-str [integer!]] 
    [
        return copy/part checksum/secure mold now/date 16
    ] 
    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] 
    [
        ret: do decrypt stm s-key 
        return ret
    ] 
    sexec: func [{A secure exec facility a la rexec for /Pro and /COmmand users} 
        stm [any-block!] /with dest [port!] 
        /local port sst crypt-str r-key ps-key g-stm ret s-key
    ] 
    [
        either with 
        [
            port: 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
        ] 
        s-key: generate-session-key crypt-str 
        ps-key: second sst 
        r-key: rsa-make-key 
        r-key/n: ps-key 
        r-key/e: 3 
        g-stm: generate-message stm s-key r-key 
        ret: rexec/with g-stm port 
        either none? ret 
        [
            return ret
        ] 
        [
            return do get-return-message ret s-key
        ]
    ]
] 
set 'sexec get in touchdown-client 'sexec 
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
] 
echo: func [e [string!]] [return e] 
client-test: does [rexec [echo "Rugby is great!"]]