Permalink
Browse files

Server version 2 - first sources

  • Loading branch information...
1 parent bd8111e commit d27003ab03aaba9a419c1fe72d97c4aa7ac3defd @SteeveGit SteeveGit committed with SteeveGit Mar 23, 2012
Showing with 603 additions and 0 deletions.
  1. +174 −0 server2/chat-profile-server.r
  2. +192 −0 server2/libs/db-mem.r
  3. +86 −0 server2/libs/misc.r
  4. +151 −0 server2/mem-messages.r
View
174 server2/chat-profile-server.r
@@ -0,0 +1,174 @@
+REBOL [
+ Description: "Implements the application protocol for PubTalk (aha the profiles)"
+
+]
+
+;;
+;; The 'L will echo back text to all initiators channels in the chatrom-peers structure
+;; An 'I PUBTALK-ETIQUETTE channel is added the chatroom-peer at chanel creation
+
+
+register context [
+
+profile: 'CHAT
+version: 1.0.0
+init: func [
+ {Initialize channel specific data and dynamic handlers - called by any new connection}
+ channel [object!] ; the channel to be initialized
+][
+
+ ; create the private profile data
+ channel/prof-data: context [
+ username: channel/port/user-data/username
+ ;user-id: get-user-id username
+ counter: false ; current syncing message counter
+ state: #unknown-counter ; #unknown-counter | #ok | #syncing | #failure
+ count-error: 0 ; number of errors sent back
+ count-synced-msg: 0 ; number of messages sent back
+ request: [] ; last request received
+ response: [] ; last response emitted
+ ]
+
+ ; set the read-msg handler
+ channel/read-msg: func [
+ {handle incoming MSGs}
+ channel frame
+ /local my msg request response state author group
+ ] [
+ my: channel/prof-data
+ state: my/state
+
+ if error? try [request: to block! frame/payload][request: [wat!]]
+
+ ;-- state machine
+ ; First, the current state is inserted in the request block,
+ ; so that one can parse the server's state and client request together.
+ ; Then, the response of the server is parsed again to take actions.
+ insert request state
+ response: [no-response]
+
+ parse request [
+ [#ok | #syncing] 'sync end (
+ response: case [
+ my/counter = last-message-counter [
+ ; up-to-date
+ [#ok ok]
+ ]
+ not msg: get-message-user my/counter + 1 my/user-id [
+ ; finished syncing, up-to-date
+ my/counter: last-message-counter
+ [#ok your-counter last-message-counter]
+ ]
+ true [
+ ; send back new message to client
+ my/counter: msg/counter
+ [#syncing new-message msg/format]
+ ]
+ )
+ | #ok 'chat [
+ ['group | 'private] string! into [string! to end] end (
+ ;-- New message
+ response: case [
+ not author: get-author request/5/1 [[client-error "Author not found:" request/5/1]]
+ not group: get-group request/4 [[client-error "Group not found:" request/4]]
+ ; try to create
+ not store-message author/id group/id next command
+ [[#failure server-error "Message not added."]]
+ true [[#syncing Ok "New message added:" last-message-counter]]
+ ]
+ )
+ | (response: [client-error "Poorly formed chat request: " mold next request])
+ ]
+ | #syncing 'chat (
+ response: [wait "You can't chat until you're synced."]
+ )
+ | #unknown-counter 'my-counter integer! end (
+ response: case [
+ request/3 < (first-message-counter - 1) [
+ ; out of range: the server does not have this first message anymore
+ ; client must send a valid counter again
+ ; state not modified
+ [out-of-range first-message-counter last-message-counter]
+ ]
+ request/3 >= last-message-counter [
+ ; client database up-to-date
+ my/counter: last-message-counter
+ [#ok ok]
+ ]
+ true [
+ my/counter: command/3
+ [#syncing ok] ; syncing requested
+ ]
+ ]
+ )
+ | issue! 'infos end ; send infos on my state (whatever is my state)
+ (response: [infos mold my])
+
+ | issue! 'wat! end ; unloadable rebol value
+ (response: [client-error "Can't load this:" lf msg/payload])
+
+ | [#ok | #syncing | #unknown-counter] ; don't know what to do with this request
+ (response: [client-error "Protocol violation: " lf mold request])
+
+ | (response: [server-error "Sorry, I'm in bad state: " request/1])
+ ]
+
+ ;-- send back answer to the client
+ parse copy response [
+ opt [set state issue!] ; modify server state
+ response:
+ word! opt [skip (clear change next response reduce next response)] ; reduce some opional parameters
+ :response
+ [
+ ['ok | 'new-message | 'wait | 'infos | 'out-of-range | 'your-counter]
+ (post-reply channel response)
+ | ['server-error | 'client-error]
+ (post-error channel response)
+ ]
+ | ( ; Know your own protocol stupid server!
+ state: #failure
+ post-error channel compose [server-error "I'm stupid!" (mold head response)]]
+ )
+ ]
+
+ ;-- save back state
+ my/state: state
+ my/request: request
+ my/response: head response
+ ]
+
+ ; set the read-rpy handler
+ channel/read-rpy: func [
+ {handle incoming replies}
+ channel frame
+ ][
+
+ ]
+
+ ; set the close handler
+ channel/close: func [
+ {to let the profile know, that the channel is being closed}
+ channel
+ ][
+
+ ]
+] ;-- end init function
+] ;-- end register
+
+;------------------------
+;- helper functions
+;------------------------
+
+post-error: func [channel msg][post- channel 'err msg]
+
+post-reply: func [channel msg][post- channel 'rpy msg]
+
+post-: func [channel type msg][
+ if block? msg [msg: mold/only msg]
+ send-frame channel make frame-object [
+ msgtype: type
+ more: '.
+ payload: msg
+]
+
+
View
192 server2/libs/db-mem.r
@@ -0,0 +1,192 @@
+db-mem Module.
+Memory cached database handler.
+
+rebol []
+db-mem.r: true
+
+db-mem: context [ ; module
+
+proto: [
+ table-name: none ; string!
+ index: none ; object! of hashs (one per key)
+ data: copy [] ; data container (block of blocks)
+ schema: none ; object! describing the data schema
+ syntax: none ; parsing rule used to check syntax
+ fields: none ; object! with current field values
+ position: false ; current position (integer! or false)
+
+ ;-- Automatically reconstructed to handle associated indexes
+ append-fields: func[][
+ insert/only tail data get fields
+ ]
+
+ append-record: func [
+ {Append a block}
+ record [block!]
+ ][
+ set-fields record
+ check-syntax
+ append-fields
+ ]
+
+ set-fields: func [rec [block!]][set fields rec]
+
+ update-fields: func [
+ {update current position with fields object!}
+ /local hash
+ ][
+ assert [integer? position position <= length? data]
+ check-syntax
+ foreach key next first index [;-- update indexes
+ poke index/:key position fields/:key
+ ]
+ poke data position get fields
+ fields
+ ]
+
+ where: func [
+ {Get position based on an indexed key}
+ key [word!] value
+ /local pos
+ ][
+ all [
+ integer? position
+ position > 0
+ position <= length? data
+ all [pos: find at index/:key position :value index? pos]
+ ]
+ ]
+
+ fetch: func [
+ {Fetch a position. returns fields or false}
+ with [integer! block! none!]
+ ][
+ ;-- A block contains several WHERE clauses.
+ ; the clause which returns the minimal position is taken.
+ with: either block? with [any sort reduce with][with]
+ all [
+ integer? with
+ with > 0
+ with <= length? data
+ set fields pick data with
+ fields
+ ]
+ ]
+
+ check-syntax: func [[catch]][
+ unless parse get fields syntax [
+ print-syntax schema fields
+ throw make error! reform ["Invalid syntax in table" table-name]
+ ]
+ true
+ ]
+
+ bound: func [body [block!]][bind bind body fields self]
+
+ indexed-by: func [
+ keys [object!]
+ /local code
+ ][
+ unprotect [index]
+ index: keys
+ protect [index]
+ code: rebuild-index self
+ ;-- reconstruct append-fields (makes the code faster)
+ append-fields: func[] append code [
+ insert/only tail data get fields
+ ]
+ ]
+]
+
+rebuild-index: func [
+ proto [object!]
+ /local code key-list
+][
+ key-list: bind copy next first proto/index proto/index
+
+ ;-- construct code to insert data in indexes
+ code: make block! 31
+ foreach key key-list [
+ set key make block! length? proto/data ;-- currently block! not hash! (append is faster)
+ append code compose [
+ insert tail (key) (in proto/fields key)
+ ]
+ ]
+ ;-- populate indexes with data
+ foreach rec proto/data proto/bound [
+ set-fields rec
+ ;-- no syntax checking: Makes the code faster, but one does not detect corrupted database, worth it ?
+ ;check-syntax ;WARNING
+ do code
+ ]
+ ;-- convert blocks to hashs
+ foreach key key-list [
+ set key make hash! get key
+ ]
+ recycle ; trying to free temp blocks, worth it ?
+ code ; return code block (used to modify the function append-fields)
+]
+
+new: func [
+ table-name [string!] schema [block!]
+ /local ctx
+][
+ ctx: context proto
+ schema: context bind schema ctx
+ ctx/table-name: table-name
+ ctx/schema: schema
+ ctx/syntax: get/any schema
+ ctx/fields: make ctx/schema []
+ set ctx/fields none
+ ctx/index: none
+ protect bind [schema syntax fields index] ctx
+ ctx
+]
+
+print-syntax: func [schema fields /local raw rule rules value][
+ raw: get fields
+ rules: bind copy next first schema schema
+ foreach word rules [
+ rule: get/any word
+ either parse raw [set value rule raw: to end][
+ print ["** (ok)" form word "[" mold rule "] :" mold/flat :value]
+ ][
+ print ["** (KO)" form word "is not [" mold rule "] :" mold/flat raw]
+ exit
+ ]
+ ]
+]
+] ;end module
+
+;--------------
+;- test
+;--------------
+'do [
+ test: db-mem/new "test" [
+ nom: string!
+ age: integer!
+ ]
+ do test/bound [
+
+ indexed-by construct [nom: age:]
+
+ foreach rec [
+ ["toto" 15]
+ ["tata" 30]
+ ][
+ append-record rec
+ ]
+
+ attempt [append-record ["wrong age-->" Fuuuuuuu]]
+
+ probe fetch 1
+ probe fetch 2
+
+ position: 1
+ probe fetch where 'nom "toto"
+
+ position: 1
+ probe fetch where 'age 30
+ ]
+ halt
+]
View
86 server2/libs/misc.r
@@ -0,0 +1,86 @@
+REBOL []
+misc.r: true ;-- already loaded
+
+*func*: :func
+
+dump-word: func [
+ word [word!]
+ /local type value
+][
+ value: switch/default type: type?/word value: get/any word [
+ unset! ['unset!]
+ object! [third :value]
+ function! [third :value]
+ ][:value]
+ if block? :value [new-line/all :value off] ;-- this, because mold/flat does not remove LF
+ ajoin [
+ mold to-set-word word
+ tab type tab
+ copy/part mold/flat :value 50
+ ]
+]
+
+dump-params: func [
+ ctx [object!]
+ /with-locals ; dump also locals
+ /local type out fields value
+][
+ out: make string! 50
+ if 'self = pick fields: bind first ctx ctx 1 [remove ctx] ;-- remove 'self if any
+ unless with-locals [clear find fields [/local]] ;-- remove locals
+ foreach word fields [
+ append out reduce ["--" tab dump-word to-word word lf]
+ ]
+ head remove back tail out ;-- remove last lf
+]
+
+;-- create a tracable function
+fun: func [
+ param body
+][
+ unless find param /local [param: append copy param /local]
+ use [*name*][
+ *name*: none
+ *func* param compose/deep [
+ *name*: any [*name* form get in disarm try [1 / 0] 'where] ;-- trick to get the function name
+ use [res ctx err name][
+ ctx: bind? 'local
+ print [*name* "->" lf dump-params ctx]
+ if error? set/any 'res try [do make function! [] bind/copy [(body)] ctx][
+ error? err: :res
+ res: error!
+ ]
+ print [*name* "<-" find/tail dump-word 'res tab]
+ either :res = error! [:err][get/any 'res]
+ ]
+ ]
+ ]
+]
+
+trace-func: func [body /local save][
+ save: :func
+ func: :fun
+ do body
+ func: :save
+]
+
+resolve: func [ ;-- optimized for objects
+ {modify target using source (if fields intersect)}
+ target [object!] source [object!]
+][
+ set/any
+ bind
+ bind
+ copy next first source
+ source
+ target
+ get/any source
+ target
+]
+
+;- set words to false if not already defined.
+defined?: func [words [block!]][
+ foreach word words [
+ unless value? word [set word false]
+ ]
+]
View
151 server2/mem-messages.r
@@ -0,0 +1,151 @@
+Interface to cache messages in memory (uses db-mem handler)
+
+REBOL []
+
+unless value? 'misc.r [do %libs/misc.r]
+unless value? 'db-mem.r [do %libs/db-mem.r]
+
+;---------------------
+;- callback functions
+; These functions are used to save/load messages in database (files).
+; This is optional. No database means messages are only memory cached and lost when app quit.
+;----------------------
+defined? [ ; (set to false if not already defined)
+ save-message ; save a message in database
+ load-messages ; load some messages from database (initialize the cache)
+]
+
+;----------------------
+;- messages schema
+;----------------------
+mem-msg: db-mem/new "Message-table" [
+ counter: integer! ; unique, auto increment
+ author-id: integer!
+ group-id: integer! ; also called channel, thread
+ type: ['G | 'P] ; G=Public, P=Private
+ date: date! ; GMT date
+ time: time! ; GMT time
+ format: string! ; actually the message
+]
+
+do mem-msg/bound [
+;--------------------------
+;- load data from database/file
+;--------------------------
+data: any [load-messages copy []]
+
+;--------------------------
+;- (re)build indexes
+; must be done after database is loaded
+;--------------------------
+indexed-by construct [counter: type: author-id: group-id:] ;-- order does not matter
+
+;--------------------------
+;- public interface (free use anywhere in the app)
+;
+;-- FUNCTIONS:
+;-- store-message : store a new message in cache
+;-- get-first-message : get first message in cache
+;-- get-last-message : get last message in cache
+;-- get-message : get any message (with a global counter)
+;-- get-message-user : get a message belonging to a user
+;-- GLOBAL VARIABLES (READ ONLY):
+;-- first-message-counter : message counter of the first message stored in cache
+;-- last-message-counter : message counter of the last message stored in cache
+;--------------------------
+
+;--------------------------
+;- store a message in cache
+;--------------------------
+store-message: func [
+ author [integer!]
+ group [integer!]
+ msg [block!]
+ /local gmt
+][
+ set-fields none
+
+ counter: last-message-counter + 1
+ author-id: author
+ group-id: group
+ type: select [Public G Private P] msg/1
+ gmt: now
+
+ gmt: gmt - gmt/zone ;-- transform timestamp to gmt
+ date: gmt/date
+ time: gmt/time
+
+ insert insert tail msg counter gmt ;-- append [counter timestamp] to msg
+
+ format: mold/flat/all/only new-line/all msg off
+
+ all [
+ check-syntax
+ (save-message fields) ;-- update database (optional)
+ append-fields
+ last-message-counter: last-message-counter + 1 ;-- increment message counter only if storing ok
+ ]
+]
+
+;--------------------------
+;- get first message in cache
+;
+; Returns a field-object or false
+;--------------------------
+get-first-message: func [][fetch 1]
+
+;--------------------------
+;- get last message in cache (most recent)
+;
+; Returns a field-object or false
+;--------------------------
+get-last-message: func [][fetch length? data]
+
+;--------------------------
+;- get message in cache from a global message counter
+;
+; Returns a fields-object or false
+;--------------------------
+get-message: func [
+ counter [integer!]
+][
+ fetch where 'counter counter
+]
+
+;--------------------------
+;- get next message for a user.
+;
+; Returns a field-object or false
+;--------------------------
+get-message-user: func [
+ counter [integer!] {starting from a counter}
+ user-id [integer!]
+][
+ all [
+ position: where 'counter counter ; get the position based on a message counter
+ fetch [
+ where 'type 'G ; from a public group
+ where 'author-id user-id ; or a private message the user authored
+ where 'group-id user-id ; or a private message someone else sent to user
+ ]
+ ]
+]
+
+;--------------------------
+;- global message counters (never change them anywhere but in this script)
+;--------------------------
+
+LAST-MESSAGE-COUNTER: any [
+ all [(fetch length? data) counter]
+ 0
+]
+
+FIRST-MESSAGE-COUNTER: any [
+ all [(fetch 1) counter]
+ 1
+]
+protect [first-message-counter] ;-- not modifiable
+
+] ;-- mem-msg bounded
+
+

0 comments on commit d27003a

Please sign in to comment.