...
 
Commits (5)
......@@ -15,7 +15,7 @@ dnl Process this file with autoconf to produce a configure script.
# 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/>.
AC_INIT([net2o], [0.9.7-20200514], [bernd@net2o.de], [net2o], [https://fossil.net2o.de/net2o/reportlist])
AC_INIT([net2o], [0.9.7-20200521], [bernd@net2o.de], [net2o], [https://fossil.net2o.de/net2o/reportlist])
AC_PREREQ([2.59])
AC_CONFIG_MACRO_DIR([m4])
AC_USE_SYSTEM_EXTENSIONS
......
......@@ -227,7 +227,7 @@ Sema id-sema
pk@ key| $, pubkey $@len 0> keypad$ nip keysize u<= and IF
pubkey $@ key| $, keypair
pubkey $@ drop sk@ drop key-stage2
ELSE !!nokey!! THEN
ELSE true !!nokey!! THEN
update-key all-ivs ;
: reply-key ( -- ) crypt( ." Reply key: " tmpkey@ .nnb forth:cr )
reply-key, ( cookie+request ) time-offset! context
......
......@@ -1298,8 +1298,9 @@ Variable current-player
THEN
caller-w .text$ play$ $@ str=
IF
addr data $@ >msg-audio-player
pause$ $@ caller-w >o to text$ o> +sync
addr data $@ ['] >msg-audio-player catch 0= IF
pause$ $@ caller-w >o to text$ o> +sync
ELSE 2drop THEN
ELSE
pause-play
play$ $@ caller-w >o to text$ o> +sync
......
......@@ -328,9 +328,9 @@ hash: fetch-finish#
Variable fetch-queue[]
also fetcher
:noname fetching# state ! ; fetcher-class is fetch
:noname fetching# to state ; fetcher-class is fetch
' 2drop fetcher-class is fetching
:noname have# state ! ; fetcher-class is got-it
:noname have# to state ; fetcher-class is got-it
previous
: .@host.id ( pk+host u -- )
......@@ -354,12 +354,13 @@ previous
r> to msg-group-o throw ;
: msg:ihave ( id u1 hash u2 -- )
\ ." ihave:" 2over dump 2dup dump
fetch( ." ihave:" 2over .@host.id 2dup bounds U+DO
forth:cr I keysize 85type keysize +LOOP forth:cr )
2dup ihave$ $+! 2over mehave$ $!
bounds U+DO 2dup I keysize have# #!ins[] keysize +LOOP 2drop ;
: pk.host ( -- addr u ) [: pk@ type host$ $. ;] $tmp ;
: >ihave ( hash u -- )
0 .pk.host 2over msg:ihave >send-have ;
0 .pk.host 2over msg:ihave 2drop ( >send-have ) ;
: push-msg ( o:parent -- )
up@ receiver-task <> IF
......@@ -633,11 +634,9 @@ event: :>hash-finished { d: hash -- }
bounds U+DO
net2o-code expect+slurp $10 blocksize! $A blockalign!
I' I U+DO
false I keysize have# $@ dup IF
bounds U+DO
I $@ pk$ $@ str= or
cell +LOOP
ELSE 2drop THEN
false I keysize have# $@ bounds U+DO
I $@ pk$ $@ str= or
cell +LOOP
IF
I keysize tsk fetch-hash
1 +to hashs
......@@ -647,15 +646,25 @@ event: :>hash-finished { d: hash -- }
end-code| net2o:close-all
keysize hashs * 0 to hashs +LOOP ;
: fetch-queue ( task want# -- )
0 .pk.host $make { tsk w^ want# w^ pk$ -- }
want# tsk pk$ [{: tsk pk$ :}l { item }
item $@ pk$ $@ str= ?EXIT \ don't fetch from myself
item $@ $8 $E pk-connect? IF
+resend +flow-control
item cell+ $@ tsk item fetch-hashs
disconnect-me
THEN ;] #map
: fetch-queue { tsk w^ want# -- }
0 .pk.host $make { w^ pk$ }
want# tsk pk$ [{: tsk pk$ :}l { want }
want $@ pk$ $@ str= IF
msg( ." I really should have this myself" forth:cr )
\ don't fetch from myself
ELSE
want $@ [: $8 $E pk-connect? ;] catch 0=
IF
IF
+resend +flow-control
want cell+ $@ tsk want fetch-hashs
disconnect-me
THEN
ELSE
fetch( ." failed, doesn't connect" forth:cr )
nothrow 2drop
THEN
THEN rdrop ;] #map
want# #frees
pk$ $free ;
......@@ -663,13 +672,11 @@ event: :>hash-finished { d: hash -- }
{ | w^ want# }
fetch# want# [{: want# :}l
dup cell+ $@ drop cell+ >o fetcher:state o> 0= IF
$@ 2dup have# #@ dup IF
bounds U+DO
2dup I $@ want# #+!
cell +LOOP 2drop
ELSE 2drop 2drop THEN
$@ 2dup have# #@ bounds U+DO
2dup I $@ want# #+!
cell +LOOP 2drop
ELSE drop THEN ;] #map
want# ;
want# @ ;
fetcher-class ' new static-a with-allocater Constant fetcher-prototype
: >fetch# ( addr u -- )
......@@ -693,12 +700,13 @@ event: :>queued ( queue -- )
forward need-hashed?
: >have-group ( addr u -- )
last# >r
msg-group-o { w^ grp }
2dup have-group# #@ nip IF
grp last# cell+ +unique$
grp last# cell+ +unique$ 2drop
ELSE
grp cell 2swap have-group# #!
THEN ;
THEN r> to last# ;
: >fetch-queue ( addr u -- )
2dup need-hashed? IF
......@@ -1531,17 +1539,18 @@ also net2o-base
c:0key sigonly@ >hash hashtmp hash#128 forth:type ;] $tmp $, msg-chain ;
: ihave, ( -- )
ihave$ $@ dup IF
maxstring over 4 + - mehave$ $@len - dup 0< IF 2drop EXIT THEN
drop keysize negate and dup >r
$, mehave$ $@ $, msg-ihave
maxstring dup -1 = 1 rshift and
over 4 + - mehave$ $@len - min 0 max
keysize negate and dup >r
dup IF $, mehave$ $@ $, msg-ihave ELSE 2drop 2drop THEN
ihave$ 0 r> $del
ELSE 2drop THEN ;
: push, ( -- )
push$ $@ dup IF $, nestsig ELSE 2drop THEN ;
: (send-avalanche) ( xt -- addr u flag )
[: 0 >o [: <msg msg-start execute msg> ihave, ;] gen-cmd$ o>
+last-signed msg-log, ;] [group] ;
[: 0 >o [: <msg msg-start execute msg> ;] gen-cmd$ o>
+last-signed msg-log, ;] [group] ;
previous
: send-avalanche ( xt -- )
......@@ -1778,6 +1787,12 @@ also net2o-base scope: /chat
umethod /have ( addr u -- )
\U have print out have list
\G have: print out the hashes and their providers
umethod /want ( addr u -- )
\U want print out want list
\G want: print out the hashes I want
umethod /fetch ( addr u -- )
\U fetch trigger fetching
\G fetch: fetch the hashes I want
umethod /imgs ( addr u -- )
\U imgs print out img list
\G imgs: print out hashes for album viewer
......@@ -1933,7 +1948,24 @@ is /help
:noname ( addr u -- )
2drop [:
remote-host$ $. ." @" pubkey $@ .simple-id ." :" forth:cr
true ;] search-context ; is /connections
true ;] search-context ; is /connections
:noname ( addr u -- ) 2drop enqueue ; is /fetch
:noname ( addr u -- ) 2drop
." Want:" forth:cr
fetch# [: { item }
." hash: " item $@ 85type space
case item cell+ $@ drop cell+ .fetcher:state
0 of ." want from"
item $@ have# #@ bounds U+DO
forth:cr I @ .@host.id
cell +LOOP
endof
1 of ." fetching..." endof
2 of ." got it" endof
endcase forth:cr
;] #map ; is /want
}scope
: ?slash ( addr u -- addr u flag )
......@@ -2009,8 +2041,11 @@ forward hash-in
: jpeg? ( addr u -- flag )
dup 4 - 0 max safe/string ".jpg" str= ;
: >have+group ( addr u -- addr u )
2dup key| 2dup >have-group >ihave ;
: file-in ( addr u -- hash u )
slurp-file over >r hash-in r> free throw 2dup key| >ihave ;
slurp-file over >r hash-in r> free throw >have+group ;
: img-rec ( addr u -- .. token )
2dup "img:" string-prefix? IF
......@@ -2023,7 +2058,7 @@ forward hash-in
r> free throw THEN
ELSE #0. THEN
2swap file-in
2swap dup IF 2dup key| >ihave THEN
2swap dup IF >have+group THEN
[: dup IF $, msg:thumbnail# ulit, msg-object ELSE 2drop THEN
$, msg:image# ulit, msg-object ;]
r> free throw r> to last->in ;]
......
......@@ -165,7 +165,16 @@ event: :>kill ( task -- )
kill-seconds# 1+ #1000000000 um* 2constant kill-timeout# \ 3s
#5000000. 2Constant kill-wait2# \ 5ms wait for threads to terminate
0 Value sender-task \ asynchronous sender thread (unused)
0 Value receiver-task \ receiver thread
0 Value timeout-task \ for handling timeouts
0 Value query-task \ for background queries initiated in other tasks
: net2o-kills ( -- )
0 to sender-task
0 to receiver-task
0 to timeout-task
0 to query-task
net2o-tasks get-stack kills ! net2o-tasks $free
kills @ 0 ?DO send-kill LOOP
ntime kill-timeout# d+ { d: timeout }
......@@ -1187,10 +1196,6 @@ end-structure
Variable chunks
Variable chunks+
Create chunk-adder chunks-struct allot
0 Value sender-task \ asynchronous sender thread (unused)
0 Value receiver-task \ receiver thread
0 Value timeout-task \ for handling timeouts
0 Value query-task \ for background queries initiated in other tasks
: .0depth ( -- ) <warn> "Stack should always be empty!" type cr <default> ;
: !!0depth!! ( -- ) ]] depth IF .0depth ~~bt clearstack THEN [[ ; immediate
......@@ -1529,7 +1534,7 @@ Variable timeout-tasks
: o+timeout ( -- ) 0timeout
timeout( ." +timeout: " o hex. ." task: " task# ? addr timeout-xt @ .name cr )
o timeout-tasks +unique$
timeout-task wake ;
timeout-task ?dup-IF wake THEN ;
: o-timeout ( -- )
0timeout timeout( ." -timeout: " o hex. ." task: " task# ? cr )
[: o timeout-tasks del$cell ;] resize-sema c-section ;
......
# Commands #
Version 0.9.7-20200514.
Version 0.9.7-20200521.
net2o separates data and commands. Data is passed through to higher
layers, commands are interpreted when they arrive. For connection
......