Start of message protocol

alice-test.fs

@@ -18,38 +18,6 @@ init-client
 ?nextarg [IF] net2o-host $! [THEN]
 ?nextarg [IF] s>number drop to net2o-port [THEN]
 
-: c:lookup ( addr u -- id u )
-  $2000 $10000 "test" ins-ip c:connect
-    2dup c:addme-fetch-host
-    nick-key >o ke-pk $@
-    BEGIN  >d#id >o 0 dht-host $[]@ o> over c@ '!' =  WHILE
-	    replace-key o> >o ke-pk $@ ." replace key: " 2dup 85type cr
-	    o o> >r 2dup c:fetch-id r> >o
-    REPEAT  o> 2drop do-disconnect ;
-: c:insert-host ( addr u -- )
-    ." check host: " 2dup .host cr
-    host>$ IF
-	[: check-addr1 0= IF  2drop  EXIT  THEN
-	  insert-address temp-addr ins-dest
-	  ." insert host: " temp-addr $10 xtype cr
-	  return-addr $10 0 skip nip 0= IF
-	      temp-addr return-addr $10 move
-\	      temp-addr return-address $10 move
-	  THEN ;] $>sock
-    ELSE  2drop  THEN ;
-
-: n2o:lookup ( addr u -- )
-    2dup c:lookup
-    0 n2o:new-context >o rdrop 2dup dest-key  return-addr $10 erase
-    nick-key .ke-pk $@ >d#id >o dht-host ['] c:insert-host $[]map o> ;
-
-: nat:connect ( addr u -- )
-    init-cache' n2o:lookup
-    ." trying to connect to: " return-addr $10 xtype cr
-    $10000 $100000 n2o:connect +flow-control +resend
-    ." Connected!" cr
-    c:test-rest ;
-
 \ ?nextarg [IF] s>number drop [ELSE] 1 [THEN] c:tests
 
-script? [IF] "bob" nat:connect bye [THEN]
+script? [IF] "bob" nat:connect c:test-rest bye [THEN]

client-tests.fs

@@ -116,12 +116,12 @@ previous
     net2o-code
       expect-reply
       log !time .time s" Download test " $, type 1 ulit, . pi float, f. cr endwith
-      get-ip 0 ulit,
+      get-ip
       $400 blocksize! $400 blockalign! stat( request-stats )
       "net2o.fs" "net2o.fs" >cache n2o:copy
       "data/2011-05-13_11-26-57-small.jpg" "photo000s.jpg" >cache n2o:copy
       "data/2011-05-20_17-01-12-small.jpg" "photo001s.jpg" >cache n2o:copy
-      n2o:done push' log words push' cr push' endwith
+      n2o:done push' log 0 ulit, words push' cr push' endwith
     end-code| n2o:close-all ['] .time $err ;
 
 : c:download2 ( -- )
@@ -137,7 +137,7 @@ previous
       "data/2011-06-27_19-33-04-small.jpg" "photo006s.jpg" >cache n2o:copy
       "data/2011-06-27_19-55-48-small.jpg" "photo007s.jpg" >cache n2o:copy
       "data/2011-06-28_06-54-09-small.jpg" "photo008s.jpg" >cache n2o:copy
-      n2o:done
+      n2o:done push' log 55 ulit, words push' cr push' endwith
     end-code| n2o:close-all ['] .time $err ;
 
 : c:download3 ( -- )
@@ -214,6 +214,39 @@ event: ->throw dup DoError throw ;
     0 ?DO  I c:test& req-ms# ms test# 1+ to test#  LOOP
     requests->0 ;
 
+\ lookup for other users
+
+: c:lookup ( addr u -- id u )
+  $2000 $10000 "test" ins-ip c:connect
+    2dup c:addme-fetch-host
+    nick-key >o ke-pk $@
+    BEGIN  >d#id >o 0 dht-host $[]@ o> over c@ '!' =  WHILE
+	    replace-key o> >o ke-pk $@ ." replace key: " 2dup 85type cr
+	    o o> >r 2dup c:fetch-id r> >o
+    REPEAT  o> 2drop do-disconnect ;
+: c:insert-host ( addr u -- )
+    ." check host: " 2dup .host cr
+    host>$ IF
+	[: check-addr1 0= IF  2drop  EXIT  THEN
+	  insert-address temp-addr ins-dest
+	  ." insert host: " temp-addr $10 xtype cr
+	  return-addr $10 0 skip nip 0= IF
+	      temp-addr return-addr $10 move
+\	      temp-addr return-address $10 move
+	  THEN ;] $>sock
+    ELSE  2drop  THEN ;
+
+: n2o:lookup ( addr u -- )
+    2dup c:lookup
+    0 n2o:new-context >o rdrop 2dup dest-key  return-addr $10 erase
+    nick-key .ke-pk $@ >d#id >o dht-host ['] c:insert-host $[]map o> ;
+
+: nat:connect ( addr u -- )
+    init-cache' n2o:lookup
+    ." trying to connect to: " return-addr $10 xtype cr
+    $10000 $100000 n2o:connect +flow-control +resend
+    ." Connected!" cr ;
+
 \ some more helpers
 
 : sha-3 ( addr u -- ) c:0key

net2o-cmd.fs

@@ -483,6 +483,8 @@ $10 net2o: <req ( -- ) ; \ stub: push own id in reply
     $> cmdnest ;
 +net2o: req> ( -- ) \ end of request
     endwith ;
++net2o: request-done ( ureq -- ) 64>n \ signal request is completed
+    o 0<> own-crypt? and IF  n2o:request-done  ELSE  drop  THEN ;
 
 \ inspection
 
@@ -543,8 +545,6 @@ log-table >table
 +net2o: new-code ( addr addr u -- ) \ crate new code mapping
     o 0<> tmp-crypt? and own-crypt? or IF  64>n  n2o:new-code  EXIT  THEN
     64drop 64drop 64drop  un-cmd ;
-+net2o: request-done ( ureq -- ) 64>n \ signal request is completed
-    o 0<> own-crypt? and IF  n2o:request-done  ELSE  drop  THEN ;
 +net2o: set-rtdelay ( utimestamp -- ) \ set round trip delay
     o IF  rtdelay!  EXIT  THEN
     own-crypt? IF
@@ -556,6 +556,8 @@ log-table >table
 	    ticker 64@ connect-timeout# 64- 64u< 0= ?EXIT
 	THEN
     ELSE  64drop  THEN  un-cmd ;
++net2o: disconnect ( -- ) \ close connection
+    o 0= ?EXIT n2o:dispose-context un-cmd ;
 
 : n2o:create-map
     { 64: addrs ucode udata 64: addrd -- addrd ucode udata addrs }
@@ -631,6 +633,10 @@ net2o-base
 
 +net2o: punch? ( -- ) \ Request punch addresses
     gen-punch ;
++net2o: set-ip ( $:string -- ) \ set address information
+    $> setip-xt perform ;
++net2o: get-ip ( -- ) \ request address information
+    >sockaddr $, set-ip [: $, set-ip ;] n2oaddrs ;
 
 \ create commands to send back
 
@@ -712,8 +718,6 @@ gen-table $freeze
 +net2o: slurp ( -- ) \ slurp in tracked files
     n2o:slurp swap ulit, flag, set-top
     ['] do-track-seek n2o:track-all-seeks net2o:send-chunks ;
-+net2o: disconnect ( -- ) \ close connection
-    o 0= ?EXIT n2o:dispose-context un-cmd ;
 
 \ flow control functions
 
@@ -760,11 +764,6 @@ net2o' emit net2o: ack-addrtime ( utime addr -- ) \ packet at addr received at t
 gen-table $freeze
 ' context-table is gen-table
 
-$60 net2o: set-ip ( $:string -- ) \ set address information
-    $> setip-xt perform ;
-+net2o: get-ip ( -- ) \ request address information
-    >sockaddr $, set-ip [: $, set-ip ;] n2oaddrs ;
-
 : net2o:gen-resend ( -- )
     recv-flag @ invert resend-toggle# and ulit, ack-resend ;
 : net2o:ackflush ( n -- ) ulit, ack-flush ;
@@ -1103,7 +1102,7 @@ forth-local-words:
     (
      (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
       "[ \t\n]" t name (font-lock-function-name-face . 3))
-     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
+     ("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
       ")" nil comment (font-lock-comment-face . 1))
     )
 forth-local-indent-words:

net2o-dht.fs

@@ -294,7 +294,7 @@ Variable revtoken
 
 get-current also net2o-base definitions
 
-$70 net2o: dht-id ( $:string -- o:o ) $> >d#id dht( ." set dht to: " dup hex. F cr ) n:>o ;
+$51 net2o: dht-id ( $:string -- o:o ) $> >d#id dht( ." set dht to: " dup hex. F cr ) n:>o ;
 \g set dht id for further operations on it
 dht-table >table
 

net2o-msg.fs

+\ messages                                           06aug2014py
+
+\ Copyright (C) 2013   Bernd Paysan
+
+\ This program is free software: you can redistribute it and/or modify
+\ it under the terms of the GNU Affero General Public License as published by
+\ the Free Software Foundation, either version 3 of the License, or
+\ (at your option) any later version.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+\ GNU Affero General Public License for more details.
+
+\ You should have received a copy of the GNU Affero General Public License
+\ along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+$52 net2o: msg ( -- ) \ push a message object
+    msg-context @ n:>o ;
+
+msg-table >table
+
+reply-table $@ inherit-table msg-table
+
+$20 net2o: msg-at ( timestamp -- ) \ specify sender time
+    ." msg at: " .ticks space ;
++net2o: msg-text ( $:msg -- ) \ specify message string
+    $> F type F cr ;
++net2o: msg-object ( $:hash -- ) \ specify an object, e.g. an image
+    $> F ." wrapped object: " 85type F cr ;
+
+gen-table $freeze
+' context-table is gen-table
+
+0 [IF]
+Local Variables:
+forth-local-words:
+    (
+     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
+      "[ \t\n]" t name (font-lock-function-name-face . 3))
+     ("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
+      ")" nil comment (font-lock-comment-face . 1))
+    )
+forth-local-indent-words:
+    (
+     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
+     (("[:") (0 . 1) (0 . 1) immediate)
+     ((";]") (-1 . 0) (0 . -1) immediate)
+    )
+End:
+[THEN]
\ No newline at end of file

net2o.fs

@@ -823,6 +823,7 @@ Variable reply-table
 Variable log-table
 Variable setup-table
 Variable ack-table
+Variable msg-table
 
 cmd-class class
     64field: dest-vaddr
@@ -871,6 +872,9 @@ cmd-class class
     64field: last-time
 end-class ack-class
 
+cmd-class class
+end-class msg-class
+
 cmd-class class
     field: code-map
     field: code-rmap
@@ -878,6 +882,7 @@ cmd-class class
     field: data-rmap
     field: log-context
     field: ack-context
+    field: msg-context
     field: codebuf#
     field: context#
     field: wait-task
@@ -1091,6 +1096,8 @@ UValue connection
     cmd-class new >o  log-table @ token-table ! o o> ;
 : n2o:new-ack ( -- o )
     o ack-class new >o  parent !  ack-table @ token-table ! o o> ;
+: n2o:new-msg ( -- o )
+    o msg-class new >o  parent !  msg-table @ token-table ! o o> ;
 
 : n2o:new-context ( addr -- o )
     context-class new >o timeout( ." new context: " o hex. cr )
@@ -1107,6 +1114,7 @@ UValue connection
     filestate-lock 0 pthread_mutex_init drop
     n2o:new-log log-context !
     n2o:new-ack ack-context !
+    n2o:new-msg msg-context !
     o o> ;
 
 \ insert address for punching
@@ -2483,6 +2491,7 @@ con-cookie >osize @ buffer: cookie-adder
 
 require net2o-cmd.fs
 require net2o-dht.fs
+require net2o-msg.fs
 require net2o-keys.fs \ extra cmd space
 
 0 [IF]

tests/msg.fs

+\ net2o tests - msg
+
+require ../client-tests.fs
+
++db stat(
++debug
+%droprate
+script? [IF] debug-task [THEN]
+test-keys \ we want the test keys - never use this in production!
+
+i'm alice
+
+init-client
+
+!time
+
+?nextarg [IF] net2o-host $! [THEN]
+?nextarg [IF] s>number drop to net2o-port [THEN]
+
+: c:msg-test ( -- )
+    [: .time ." Download test: 1 text file and 2 photos" cr ;] $err
+    net2o-code
+      expect-reply
+      log !time .time s" Message test" $, type cr endwith
+      msg ticks lit, msg-at
+      "This is a test message" $, msg-text endwith
+      cookie+request
+    end-code| ['] .time $err
+    >timing do-disconnect [: .packets profile( .times ) ;] $err ;
+
+script? [IF] "bob" nat:connect c:msg-test bye [THEN]