Artifact
b09f625f5e8cca6dfc168098f424595f7d56d5be:
- File
dvcs.fs
— part of check-in
[557d941bc0]
at
2019-06-21 12:43:23
on branch trunk
— More fixes for chat structure
(user:
bernd
size: 32355)
\ net2o distributed version control system
\ Copyright (C) 2016-2019 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/>.
Variable dvcs-objects \ hash of objects
Variable dvcs-table
vocabulary project
cmd-class class
scope: dvcs
field: in-files$
field: patch$
field: out-files$
method read
method rm
method rmdir
method patch
method write
method unzip
method ref
}scope
end-class dvcs-abstract
dvcs-abstract class
scope{ dvcs
field: refs[]
}scope
end-class dvcs-refs
dvcs-abstract class
scope{ dvcs
field: commits \ msg class for commits
field: searchs \ msg class for searchs
field: id$ \ commit id
field: branch$
field: message$ \ commit message
field: fileref[] \ file refs
field: files# \ snapshot config
field: oldfiles# \ old state to compare to
field: out-fileoff
field: fileentry$
field: oldid$
field: hash$
field: type
field: rmdirs[] \ sorted array of dirs to be delete
field: outfiles[] \ sorted array of files to write out
}scope
scope{ project \ per-project configuration values
field: chain$
field: revision$
field: branch$
field: project$
}scope
end-class dvcs-class
scope{ dvcs
begin-structure filehash
64field: timestamp
wfield: perm
0 +field name
end-structure
}scope
msg-class class
field: id>patch# \ convert an ID to a patch+reference list
field: id>snap# \ convert an ID to a snapshot (starting point)
field: id$
field: re$
field: object$
end-class commit-class
msg-class class
scope: match
field: tag$
field: flag
field: id$
}scope
end-class search-class
msg-class class
scope: dvcs-log
field: sig$
field: tag$
field: id$
field: action$
field: text$
field: chain$
field: urls[]
}scope
end-class dvcs-log-class
: /name ( addr u -- addr' u' )
[ hash#128 dvcs:name ]L /string ;
: fn-split ( hash+ts+perm+fn u -- hash+ts+perm u1 fname u2 )
[ hash#128 dvcs:name ]L >r 2dup r@ umin 2swap r> /string ;
: .mode ( u -- )
dup S_IFMT and 12 rshift "0pc3d5b7frlBsDEF" drop + c@ emit space
S_IFMT invert and ['] . 8 base-execute ;
: .file+hash ( addr u -- )
over hash#128 85type space hash#128 /string
over dvcs:timestamp le-64@ .ticks space
over dvcs:perm le-uw@ .mode
0 dvcs:name /string type cr ;
: +fileentry ( addr u o:dvcs -- )
\G add a file entry and replace same file if it already exists
dvcs( ." +f: " 2dup .file+hash ) fn-split dvcs:files# #! ;
: -fileentry ( addr u o:dvcs -- )
dvcs( ." -f: " 2dup .file+hash ) /name dvcs:files# #free ;
: create-symlink-f ( addrdest udest addrlink ulink perm -- ) { perm }
\G create symlink and overwrite existing file
2over 2over symlink dup -1 = IF
errno EEXIST = IF drop
2dup delete-file throw 2over 2over symlink
THEN
THEN ?ior 2drop 2drop ;
: create-file-f ( addr u addrfile ufile perm -- ) { perm }
r/w create-file throw >r
dvcs( ." write " dup . ." bytes" cr )
r@ write-file throw
r@ fileno perm fchmod ?ior
r> close-file throw ;
: create-dir-f ( addr 0 addrdir udir perm -- ) { perm }
2dup delete-file drop \ try deleting it as file
2dup perm mkdir-parents
dup file-exist# = IF drop ELSE throw THEN
perm chmod ?ior
2drop ;
S_IFMT $1000 invert and Constant S_IFMT?
: dvcs-outfile-name ( hash+perm-addr u1 fname u2 -- )
2>r 2dup key| dvcs-objects #@ 2swap hash#128 /string
drop dvcs:perm le-uw@ { perm } 2r>
perm S_IFMT? and case
S_IFLNK of perm create-symlink-f endof
S_IFREG of perm create-file-f endof
S_IFDIR of perm create-dir-f endof \ no content in directory
dvcs( ." unhandled type " hex. type space hex. drop cr 0 )else(
2drop 2drop ) \ unhandled types
endcase ;
\ encrypted hash stuff, using signature secret as PSK
\ probably needs padding...
: write-enc-hashed ( addr1 u1 -- addrhash85 u2 )
$make { w^ enc-pad$ } enc-pad$ $@
keyed-hash-out hash#128 ['] 85type $tmp 2>r
enchash 2>r
2dup c:encrypt
?.net2o/objects 2r> hash>filename spit-file
enc-pad$ $free 2r> ;
: enchash>filename ( hash1 u1 -- filename u2 )
keyed-hash-out hash#128 smove
enchash hash>filename ;
Variable patch-in$
: read-enc-hashed ( hash1 u1 -- )
\ 2dup 85type space
2dup enchash>filename patch-in$ $slurp-file
patch-in$ $@ c:decrypt
patch-in$ $@ >file-hash \ 2dup 85type cr
str= 0= !!wrong-hash!! ;
: ?read-enc-hashed ( hash1 u1 -- addr u )
2dup dvcs-objects #@ 2dup d0= IF
2drop 2dup read-enc-hashed
patch-in$ $@ 2swap dvcs-objects #!
ELSE
2drop 2drop
THEN last# cell+ $@ ;
\ in-memory file hash+contents database
: dvcs-outfile-hash ( baddr u1 fhash u2 -- )
hash#128 umin dvcs-objects #! ;
: ?fileentry-hash ( -- )
dvcs:fileentry$ $@ hash#128 umin
2dup dvcs-objects #@ d0<> IF 2drop EXIT THEN
read-enc-hashed
patch-in$ $@ dvcs:fileentry$ $@ dvcs-outfile-hash ;
: dvcs-in-hash ( addr u -- )
dvcs( ." +read: " 2dup 85type cr )
dvcs-objects #@ over 0= !!dvcs-hash!!
dvcs:in-files$ $+! ;
: filelist-print ( filelist -- )
[: >r r@ cell+ $@ 85type space r> $@ type cr ;] #map ;
: filelist-out ( o:dvcs -- )
".n2o/files" [: >r dvcs:files# ['] filelist-print r> outfile-execute ;]
new-file ;
: filelist-loop ( -- )
BEGIN refill WHILE
source bl $split 2>r base85>$ 2r> dvcs:files# #!
REPEAT ;
: filelist-in ( addr u o:dvcs -- )
r/o open-file throw ['] filelist-loop execute-parsing-file ;
scope{ net2o-base
\g
\g ### DVCS patch commands ###
\g
\g DVCS metadata is stored in messages, containing message text, refs
\g and patchset objects. Patchset objects are constructed in a way
\g that makes identical transactions have the same hash.
\g
reply-table $@ inherit-table dvcs-table
net2o' emit net2o: dvcs-read ( $:hash -- ) \g read in an object
1 !!>=order? $> dvcs:read ;
+net2o: dvcs-rm ( $:hash+name -- ) \g delete file
2 !!>=order? $> dvcs:rm ;
+net2o: dvcs-rmdir ( $:name -- ) \g delete directory
4 !!>=order? $> dvcs:rmdir ;
+net2o: dvcs-patch ( $:diff len -- ) \g apply patch, len is the size of the result
8 !!>order? $> dvcs:patch ;
+net2o: dvcs-write ( $:perm+name size -- ) \g write out file
$10 !!>=order? $> dvcs:write ;
+net2o: dvcs-unzip ( $:diffgz size algo -- $:diff ) \g unzip an object
1 !!>=order? 64>n $> dvcs:unzip ;
+net2o: dvcs-ref ( $:hash+perm+name -- ) \g external hash reference
$10 !!>=order? $> dvcs:ref ;
}scope
dvcs-table $save
' dvcs-in-hash ( addr u -- ) dvcs-class is dvcs:read
:noname ( addr u -- )
2dup hash#128 /string ?sane-file
dvcs( ." -f: " 2dup forth:type forth:cr ) dvcs:files# #free
hash#128 umin dvcs-in-hash ; dvcs-class is dvcs:rm
:noname ( addr u -- )
2dup 2 /string ?sane-file 2drop
dvcs( ." -f: " 2dup forth:type forth:cr ) dvcs:files# #free
; dvcs-class is dvcs:rmdir
:noname ( 64len addr u -- )
dvcs:patch$ $! dvcs( ." -patch: " 64dup u64. )
dvcs:out-fileoff off
64dup config:patchlimit& 2@ d>64 64u> !!patch-limit!!
dvcs:patch$ bpatch$len 64<> !!patch-size!! \ sanity check!
dvcsfiles( ." ===== in files =====" cr dvcs:in-files$ $. cr )
dvcs( ." ===== diff =====" cr
dvcs:in-files$ dvcs:patch$ color-bpatch$2 )
dvcs:out-files$ $free
dvcs:in-files$ dvcs:patch$ ['] bpatch$2 dvcs:out-files$ $exec
dvcsfiles( ." ===== " dvcs:out-files$ $@len u. ." =====" cr
dvcs:out-files$ $. ." ========================" cr )
; dvcs-class is dvcs:patch
:noname ( 64size addr u -- )
2dup 2 /string ?sane-file 2drop
2>r dvcs( ." -write: " 64dup u64. cr )
64>n { fsize }
dvcs:out-files$ $@ dvcs:out-fileoff @ safe/string fsize umin
2dup >file-hash 2r> 2swap dvcs:fileentry$ $free
[: forth:type ticks { 64^ ts } ts 1 64s forth:type forth:type ;]
dvcs:fileentry$ $exec dvcs:fileentry$ $@
2dup +fileentry dvcs-outfile-hash
fsize dvcs:out-fileoff +! ; dvcs-class is dvcs:write
' !!FIXME!! ( 64size algo addr u --- ) dvcs-class is dvcs:unzip
:noname ( addr u -- ) \ hash+perm+name
0 patch-in$ !@ >r
dvcs:fileentry$ $free
[: over hash#128 forth:type ticks { 64^ ts } ts 1 64s forth:type
hash#128 /string forth:type ;] dvcs:fileentry$ $exec
dvcs:fileentry$ $@ +fileentry
?fileentry-hash
patch-in$ $free r> patch-in$ !
; dvcs-class is dvcs:ref
\ DVCS refs are scanned for in patchsets, and then fetched
' 2drop dvcs-refs is dvcs:read
' 2drop dvcs-refs is dvcs:rm
' 2drop dvcs-refs is dvcs:rmdir
:noname 2drop 64drop ; dup dvcs-refs is dvcs:patch
dvcs-refs is dvcs:write
:noname 2drop drop 64drop ; dvcs-refs is dvcs:unzip
:noname ( addr u -- )
hash#128 umin 2dup dvcs-objects #@ d0<> IF 2drop EXIT THEN
2dup enchash>filename file-status nip no-file# <> IF 2drop EXIT THEN
dvcs:refs[] $+[]! ; dvcs-refs is dvcs:ref
scope{ dvcs
: new-dvcs ( -- o )
dvcs-class new >o dvcs-table @ token-table !
commit-class new >o msg-table @ token-table ! o o> dvcs:commits !
search-class new >o msg-table @ token-table ! o o> dvcs:searchs !
o o> ;
: new-dvcs-refs ( -- o )
dvcs-refs new >o dvcs-table @ token-table ! o o> ;
: clean-delta ( o:dvcs -- )
in-files$ $free out-files$ $free patch$ $free ;
: dispose-commit ( o:commit -- )
id$ $free re$ $free object$ $free dispose ;
: dispose-search ( o:commit -- )
match:id$ $free match:tag$ $free dispose ;
: dispose-dvcs-refs ( o:dvcs -- )
dvcs:refs[] $[]free dispose ;
: dispose-dvcs ( o:dvcs -- )
dvcs:branch$ $free dvcs:message$ $free dvcs:fileref[] $[]free
dvcs:files# #frees dvcs:oldfiles# #frees
dvcs:rmdirs[] $[]off dvcs:outfiles[] $[]off
clean-delta dvcs:fileentry$ $free
dvcs:hash$ $free
dvcs:id$ $free dvcs:oldid$ $free
project:revision$ $free project:chain$ $free
project:branch$ $free project:project$ $free
dvcs:commits @ .dvcs:dispose-commit
dvcs:searchs @ .dvcs:dispose-search
dispose ;
}scope
Variable new-files[]
Variable ref-files[]
Variable del-files[]
Variable old-files[]
Variable new-file$
Variable branches[]
: clean-up ( -- )
new-files[] $[]off ref-files[] $[]off
del-files[] $[]off old-files[] $[]off
branches[] $[]off new-file$ $free ;
User tmp1$
: $tmp1 ( xt -- ) tmp1$ $free tmp1$ $exec tmp1$ $@ ;
: mode@ ( -- mode )
statbuf st_mode [ sizeof st_mode 2 = ] [IF] w@ [ELSE] l@ [THEN] ;
: mode! ( -- mode )
statbuf st_mode [ sizeof st_mode 2 = ] [IF] w! [ELSE] l! [THEN] ;
$1000 Constant path-max#
Defer xstat ' lstat is xstat
Defer xfiles[] ' new-files[] is xfiles[]
Defer hash-import ' noop is hash-import
: ref-hash-import ( hash u -- hash u )
2>r new-file$ $@ write-enc-hashed 2drop 2r> ;
: hashstat-rest ( addr u -- addr' u' )
[: mode@ { | w^ perm } perm le-w!
statbuf st_mtime ntime@ d>64 64#0 { 64^ timestamp } timestamp le-64!
perm le-uw@ S_IFMT? and case
S_IFLNK of path-max# new-file$ $!len \ pathmax: 4k
2dup new-file$ $@ readlink
dup ?ior new-file$ $!len endof
S_IFREG of 2dup new-file$ $slurp-file endof
0 new-file$ $!len
endcase
new-file$ $@ >file-hash 2dup type hash-import
new-file$ $@ 2swap dvcs-objects #!
timestamp 1 64s type perm 2 type type
;] $tmp1 ;
: file-hashstat ( addr u -- addr' u' )
2dup statbuf xstat ?ior hashstat-rest ;
: $ins[]f ( addr u array -- ) [ hash#128 dvcs:name ]L $ins[]/ drop ;
: new-files-loop ( -- )
BEGIN refill WHILE \ source type cr
source file-hashstat xfiles[] $ins[]f REPEAT ;
: new-files-in ( addr u -- )
r/o open-file dup no-file# = IF 2drop EXIT THEN throw
['] new-files-loop execute-parsing-file ;
: do-refs ( xt -- )
[: stat mode@ $1000 or mode! ;] is xstat
['] ref-files[] is xfiles[]
['] ref-hash-import is hash-import
catch
['] lstat is xstat
['] new-files[] is xfiles[]
['] noop is hash-import
throw ;
: ref-hashstat ( addr u -- addr' u' )
['] file-hashstat do-refs ;
: ref-files-in ( addr u -- )
['] new-files-in do-refs ;
: config>dvcs ( o:dvcs -- )
"~+/.n2o/config" ['] project >body read-config
project:revision$ $@ base85>$ dvcs:oldid$ $! ;
: files>dvcs ( o:dvcs -- )
"~+/.n2o/files" filelist-in ;
: new>dvcs ( o:dvcs -- )
"~+/.n2o/reffiles" ref-files-in
"~+/.n2o/newfiles" new-files-in ;
: mode<> ( mode1 mode2 -- flag )
over S_IFMT invert and over S_IFMT invert and <> >r
S_IFMT and swap S_IFMT and dup $1000 and IF
$-2000 and swap dup S_IFLNK = IF drop S_IFREG THEN
THEN <> r> or ;
: dvcs?modified ( o:dvcs -- )
dvcs:files# [: >r
r@ cell+ $@ drop hash#128 + dvcs:perm le-uw@ { perm }
r@ $@ statbuf perm $1000 and IF stat ELSE lstat THEN
0< IF errno ENOENT = IF
r> [: dup cell+ $. $. ;] $tmp1 del-files[] $ins[]f
EXIT THEN -1 ?ior THEN
r@ cell+ $@ drop hash#128 + dvcs:timestamp le-64@
statbuf st_mtime ntime@ d>64 64<>
perm mode@ mode<> or IF
r@ $@ hashstat-rest 2dup fn-split dvcs:files# #@
hash#128 umin 2swap hash#128 umin
str=
IF 2drop
ELSE new-files[] $ins[]f
r@ [: dup cell+ $. $. ;] $tmp1 old-files[] $ins[]f
THEN
THEN rdrop
;] #map dvcs(
." --- old files:" cr old-files[] ['] .file+hash $[]map
." +++ new files:" cr new-files[] ['] .file+hash $[]map
." +++ ref files:" cr ref-files[] ['] .file+hash $[]map
." ===" cr
) ;
: dvcs+in ( hash u -- )
dvcs( ." read in: " 2dup 85type forth:cr )
hash#128 umin dvcs-objects #@ over 0= !!wrong-hash!!
dvcs:in-files$ $+! ;
: dvcs+out ( hash u -- )
hash#128 umin dvcs-objects #@ over 0= !!wrong-hash!!
dvcs:out-files$ $+! ;
: file-lsize@ ( addr u -- 64size )
statbuf lstat ?ior statbuf st_size 64@
mode@ S_IFMT? and S_IFDIR <> n>64 64and ;
: file-size@ ( addr u -- 64size )
statbuf stat ?ior statbuf st_size 64@
mode@ S_IFMT? and S_IFDIR <> n>64 64and ;
also net2o-base
: read-old-fs ( -- ) dvcs:in-files$ $free
old-files[] [: hash#128 umin 2dup $, dvcs-read dvcs+in ;] $[]map ;
: read-del-fs ( -- )
del-files[] [: over hash#128 dvcs:perm + le-uw@
S_IFMT? and S_IFDIR = IF /name $, dvcs-rmdir
ELSE 2dup [: over hash#128 forth:type /name forth:type ;] $tmp1 $,
dvcs-rm hash#128 umin dvcs+in THEN ;] $[]map ;
: read-new-fs ( -- )
new-files[] ['] dvcs+out $[]map ;
: dvcs+hash ( addr u -- ) 2drop ; \ !!STUB!!
: read-ref-fs ( -- )
ref-files[] ['] dvcs+hash $[]map ;
: write-new-fs ( -- )
new-files[] [: 2dup hash#128 dvcs:perm /string $,
/name file-lsize@ lit, dvcs-write ;] $[]map ;
: write-ref-fs ( -- )
ref-files[] [:
[: over hash#128 forth:type
hash#128 dvcs:perm /string forth:type ;] $tmp $,
dvcs-ref ;] $[]map ;
: compute-patch ( -- )
dvcsfiles( ." ===== in-files$ ====" forth:cr dvcs:in-files$ $.
." ===== out-files$ =====" forth:cr dvcs:out-files$ $. )
dvcs:in-files$ dvcs:out-files$ ['] bdelta$2 dvcs:patch$ $exec
dvcs:patch$ $@ $, dvcs:out-files$ $@len ulit, dvcs-patch ;
: compute-diff ( -- )
read-old-fs read-del-fs read-new-fs read-ref-fs
compute-patch write-new-fs write-ref-fs ;
Variable id-files[]
: dvcs-gen-id ( -- addr u )
id-files[] $[]off
dvcs:files# [: dup cell+ $@ 2>r $@ 2r> [: forth:type forth:type ;] $tmp
id-files[] $ins[] drop ;] #map \ sort filenames
[: id-files[] [: drop hash#128 $, dvcs-read ;] $[]map
id-files[] [: hash#128 /string
0 dvcs:perm /string 2dup $,
2 /string file-lsize@ lit, dvcs-write
;] $[]map ;] gen-cmd$
dup IF >file-hash THEN ;
previous
: 85$! ( addr u $addr -- )
['] 85type swap $set ;
: save-project ( -- )
dvcs( ." saving '" dvcs:id$ $@ 85type cr )
dvcs:id$ $@ project:revision$ 85$!
"~+/.n2o/config" ['] project >body write-config ;
\ init project
: dvcs-init ( project u -- )
".n2o" $1FF init-dir drop
".n2o/files" touch
dvcs:new-dvcs >o
'#' $split dup 0= IF 2drop "master" ELSE 2swap THEN
project:branch$ $! project:project$ $!
save-project dvcs:dispose-dvcs o> ;
\ append a line
: append-line ( addr u file u -- )
2dup w/o open-file dup no-file# = IF
2drop w/o create-file throw ELSE throw nip nip THEN
>r r@ file-size throw r@ reposition-file throw
r@ write-line throw r> close-file throw ;
\ patch stuff
\ read in branches, new version
: hash+type ( addr u type addr1 -- ) >r r@ $free
[: { w^ x } type x cell type ;] r> $exec ;
' 2drop commit-class is msg:tag
' 2drop commit-class is msg:start
' 2drop commit-class is msg:coord
' 2drop commit-class is msg:signal
' 2drop commit-class is msg:text
' 2drop commit-class is msg:url
' 2drop commit-class is msg:action
' 2drop commit-class is msg:chain
' drop commit-class is msg:like
' noop commit-class is msg:end
' drop commit-class is msg:redisplay
:noname ( addr u -- )
re$ $+! ; commit-class is msg:re
:noname ( addr u -- )
id$ $! re$ $free ; commit-class is msg:id
:noname ( addr u type -- )
object$ hash+type
object$ $@ key| id$ $@
id>patch# id>snap# re$ $@len select #!
re$ $@len IF
re$ $@ last# cell+ $+!
THEN ; commit-class is msg:object
\ search for a specific id
' 2drop search-class is msg:start
' 2drop search-class is msg:coord
' 2drop search-class is msg:signal
' 2drop search-class is msg:text
' 2drop search-class is msg:action
' 2drop search-class is msg:chain
' 2drop search-class is msg:re
' 2drop search-class is msg:url
' noop search-class is msg:end
' drop search-class is msg:like
' drop search-class is msg:redisplay
: 3drop 2drop drop ;
:noname match:tag$ $@ str= match:flag ! ; search-class is msg:tag
:noname match:flag @ IF match:id$ $! ELSE 2drop THEN ; search-class is msg:id
' 3drop search-class is msg:object
' 2drop dvcs-log-class is msg:re
' 2drop dvcs-log-class is msg:coord
' 3drop dvcs-log-class is msg:object
' noop dvcs-log-class is msg:end
:noname dvcs-log:sig$ $! ; dvcs-log-class is msg:start
:noname dvcs-log:tag$ $! ; dvcs-log-class is msg:tag
:noname dvcs-log:id$ $! ; dvcs-log-class is msg:id
:noname dvcs-log:text$ $! ; dvcs-log-class is msg:text
:noname dvcs-log:action$ $! ; dvcs-log-class is msg:action
:noname dvcs-log:chain$ $! ; dvcs-log-class is msg:chain
:noname dvcs-log:urls[] $+[]! ; dvcs-log-class is msg:url
' drop dvcs-log-class is msg:like
' drop dvcs-log-class is msg:redisplay
: chat>dvcs ( o:dvcs -- )
project:project$ $@ @/ 2drop load-msg ;
: .hash ( addr -- )
[: dup $@ 85type ." -> " cell+ $@ 85type cr ;] #map ;
: chat>branches-loop ( o:commit -- )
msg-log@ over { log } bounds ?DO
re$ $free object$ $free
I $@ ['] msg:display catch IF ." invalid entry" cr 2drop THEN
cell +LOOP log free throw
dvcs( ." === id>patch ===" cr id>patch# .hash
." === id>snap ===" cr id>snap# .hash ) ;
: chat>branches ( o:dvcs -- )
project:project$ $@ @/ 2drop >group dvcs:commits @ .chat>branches-loop ;
: >branches ( addr u -- )
$make branches[] >back ;
User id-check# \ check hash
: id>branches-loop ( addr u -- )
BEGIN 2dup id-check# #@ d0<> IF 2drop EXIT THEN
s" !" 2over id-check# #!
2dup id>snap# #@ 2dup d0<> IF >branches 2drop EXIT THEN
2drop id>patch# #@ 2dup d0<> WHILE
2dup hash#128 umin >branches
hash#128 safe/string hash#128 - 2dup + >r
bounds U+DO I hash#128 recurse hash#128 +LOOP
r> hash#128 \ tail recursion optimization
REPEAT 2drop ;
: id>branches ( addr u -- )
id-check# #frees
branches[] $[]off dvcs:commits @ .id>branches-loop
id-check# #frees
dvcs( ." re:" cr branches[] [: 85type cr ;] $[]map ) ;
: branches>dvcs ( -- )
branches[] [: dup IF
dvcs( ." read enc hash: " 2dup 85type cr )
?read-enc-hashed c-state off do-cmd-loop
dvcs:clean-delta
ELSE 2drop THEN
;] $[]map ;
\ push out a revision
: >revision ( addr u -- )
2dup >file-hash dvcs:hash$ $!
dvcs( ." ===== ci '" dvcs:hash$ $@ 85type ." ' =====" cr )
write-enc-hashed 2drop ;
: pull-readin ( -- )
config>dvcs chat>dvcs chat>branches ;
: dvcs-readin ( $addr -- )
pull-readin $@ id>branches branches>dvcs
files>dvcs new>dvcs dvcs?modified ;
scope{ dvcs
: new-dvcs-log ( -- o )
dvcs-log-class new >o msg-table @ token-table ! o o> ;
: clear-log ( -- )
dvcs-log:sig$ $free dvcs-log:tag$ $free dvcs-log:id$ $free
dvcs-log:action$ $free dvcs-log:text$ $free dvcs-log:chain$ $free
dvcs-log:urls[] $[]free ;
: dispose-dvcs-log ( o:log -- )
clear-log dispose ;
}scope
: display-logn ( addr u n -- )
project:branch$ $@ { d: branch }
dvcs:new-dvcs-log >o
cells >r >group msg-log@ 2dup { log u }
dup r> - 0 max dup >r /string r> cell/ -rot bounds ?DO
dvcs:clear-log I $@ ['] msg:display catch
IF ." invalid entry" cr 2drop
ELSE
branch dvcs-log:tag$ $@ str= IF
dup 0 .r ." : [" dvcs-log:id$ $@ 85type ." ] "
dvcs-log:sig$ $@ 2dup startdate@ .ticks
dvcs-log:chain$ $@ dup IF
2dup sighash? IF <info> ELSE <err> THEN
." <-" drop le-64@ .ticks <default>
ELSE 2drop THEN space
dvcs-log:action$ $. ." : " dvcs-log:text$ $. space
dvcs-log:urls[] [: <warn> type <default> space ;] $[]map
.key-id?
cr
THEN
THEN 1+
cell +LOOP drop
log free dvcs:dispose-dvcs-log o> throw ;
: .dvcs-log ( -- )
dvcs:new-dvcs >o config>dvcs
project:project$ $@ @/ 2drop 2dup load-msg
config:logsize# @ display-logn
dvcs:dispose-dvcs o> ;
also net2o-base
true Value add-object?
: (dvcs-newsentry) ( type -- )
dvcs:type !
dvcs:hash$ $@len 0= IF #0. last-signed 2! EXIT THEN
msg-group$ @ >r
project:project$ @ msg-group$ !
o [: with dvcs
project:chain$ $@ base85>$
fileref[]
message$ $@
type @
hash$ $@
oldid$ $@
id$ $@
project:branch$ $@
endwith
$, msg-tag
$, msg-id
dup >r
dup IF $, msg-re ELSE 2drop THEN
dup >r dup IF $, ulit, msg-object
ELSE 2drop drop THEN
r> r> IF IF "Patchset" ELSE "Revert" THEN
ELSE drop "Snapshot" THEN $, msg-action
$, msg-text
dup [: [: ." file:" forth:type ;] $tmp $, msg-url ;] $[]map $[]free
dup IF $, msg-chain ELSE 2drop THEN
;] (send-avalanche) IF .chat ELSE 2drop THEN
r> msg-group$ ! ;
previous
: dvcs-snapentry ( -- )
dvcs:oldid$ $free
msg:snapshot# (dvcs-newsentry) ;
: dvcs-newsentry ( -- )
msg:patch# msg:snapshot# dvcs:oldid$ $@len select (dvcs-newsentry) ;
: >id-revision ( addr u -- )
dvcs-gen-id 2dup dvcs:id$ $!
dvcs:commits @ >o
2dup id>patch# #@ d0= >r id>snap# #@ d0= r> and o>
IF >revision ELSE >file-hash dvcs:hash$ $! THEN ;
: ?delete-file ( addr u -- )
delete-file dup no-file# <> and throw ;
: dvcs-sig$ ( -- )
last-signed 2@ sigdate@ over 1 64s 85type 2 64s /string
c:0key >hash hashtmp hash#128 85type ;
: (dvcs-ci) ( addr u o:dvcs -- ) dvcs:message$ $!
dvcs:oldid$ dvcs-readin
ref-files[] $[]# new-files[] $[]# del-files[] $[]# or or 0= IF
." Nothing to do" cr
ELSE
['] compute-diff gen-cmd$
$make { w^ diff$ } diff$ $@ \ 2dup net2o:see
dvcs( ." ===== patch len: " dvcs:patch$ $@len . ." =====" cr )
del-files[] ['] -fileentry $[]map
new-files[] ['] +fileentry $[]map
ref-files[] ['] +fileentry $[]map
>id-revision my-key >r
my-key-default to my-key dvcs-newsentry
r> to my-key
['] dvcs-sig$ project:chain$ $set
save-project filelist-out
"~+/.n2o/newfiles" ?delete-file
"~+/.n2o/reffiles" ?delete-file
diff$ $free
THEN clean-up ;
: dvcs-ci ( addr u -- ) \ checkin command
dvcs:new-dvcs >o now>never (dvcs-ci) dvcs:dispose-dvcs o> ;
: dvcs-diff ( -- )
dvcs:new-dvcs >o dvcs:oldid$ dvcs-readin
['] compute-diff gen-cmd$ 2drop
dvcs( ." ===== diff len: " dvcs:patch$ $@len . ." =====" cr )
dvcs:in-files$ dvcs:patch$ color-bpatch$2
clean-up dvcs:dispose-dvcs o> ;
: ci-args ( -- message u )
?nextarg 0= IF "untitled checkin" THEN
2dup "-m" str= IF ?nextarg IF 2nip THEN THEN ;
: dvcs-add ( addr u -- )
2dup dirname dup 0<> + dup IF recurse ELSE 2drop THEN
2dup dvcs:files# #@ drop IF 2drop EXIT
ELSE
\ "dummy128dummy128dummy128dummy128" 2over dvcs:files# #!
"~+/.n2o/newfiles" append-line THEN ;
: dvcs-ref ( addr u -- )
2dup dirname dup 0<> + dup IF dvcs-add ELSE 2drop THEN
2dup dvcs:files# #@ drop IF 2drop EXIT
ELSE "~+/.n2o/reffiles" append-line THEN ;
: dvcs-snap ( addr u -- )
dvcs:new-dvcs >o dvcs:message$ $!
config>dvcs files>dvcs
dvcs:files# [:
dup cell+ $@ drop hash#128 + dvcs:perm le-uw@ $1000 and
IF $@ ref-hashstat ref-files[]
ELSE $@ file-hashstat new-files[] THEN
$ins[]f ;] #map
['] compute-diff gen-cmd$ >id-revision
now>never dvcs-snapentry
save-project clean-up dvcs:dispose-dvcs o> ;
: del-oldfile ( hash-entry -- )
dup cell+ $@ drop hash#128 dvcs:perm + le-uw@
S_IFMT? and S_IFDIR = IF
$@ dvcs( ." rd " 2dup type cr ) dvcs:rmdirs[] $ins[] drop
ELSE dup $@ dvcs( ." rm " 2dup type cr )
delete-file dup 0< IF
<warn> >r ." can't delete file " $. ." : "
r> error$ type <default> cr
ELSE 2drop THEN
THEN ;
: new->old ( -- ) dvcs( ." === remove old files ===" cr )
dvcs:rmdirs[] $[]off
dvcs:oldfiles# [: dup $@ dvcs:files# #@ drop 0= IF
del-oldfile
ELSE dup cell+ $@ last# cell+ $@ str= 0= IF
del-oldfile THEN
THEN ;] #map
dvcs:rmdirs[] $@ bounds cell- swap cell- U-DO
I $@ rmdir 0< IF
errno strerror <warn>
." can't delete directory " I $. ." : " type <default> cr
THEN
cell -LOOP
dvcs:rmdirs[] $[]off ;
: old->new ( -- ) dvcs( ." === write out new files ===" cr )
dvcs:outfiles[] $[]off
dvcs:files# [: $@ dvcs:outfiles[] $ins[] drop ;] #map \ sort filenames
dvcs:outfiles[] [: dvcs:files# #@ d0<> IF
last# dup >r $@ dvcs:oldfiles# #@ over IF
r@ cell+ $@ str=
ELSE drop
THEN 0= IF
dvcs( ." out " r@ $. space r@ cell+ $@ 85type cr )
r@ cell+ $@ r@ $@ dvcs-outfile-name
THEN rdrop THEN ;] $[]map
dvcs:outfiles[] $[]off ;
: co-rest ( -- )
0 dvcs:files# !@ dvcs:oldfiles# !
branches>dvcs new->old old->new
save-project filelist-out ;
: dvcs-co ( addr u -- ) \ checkout revision
base85>$ dvcs:new-dvcs >o
config>dvcs dvcs:id$ $! dvcs:id$ dvcs-readin co-rest
dvcs:dispose-dvcs o> ;
: chat>searchs-loop ( o:commit -- )
msg-log@ over { log } bounds ?DO
I $@ ['] msg:display catch IF ." invalid entry" cr 2drop THEN
cell +LOOP log free throw ;
: search-last-rev ( -- addr u )
project:project$ $@ @/ 2drop >group
project:branch$ $@
dvcs:searchs @ >o match:tag$ $!
chat>searchs-loop match:id$ $@ o> ;
: dvcs-up ( -- ) \ checkout latest revision
dvcs:new-dvcs >o
pull-readin files>dvcs new>dvcs dvcs?modified
new-files[] $[]# del-files[] $[]# d0= IF
search-last-rev 2dup dvcs:id$ $!
2dup dvcs:oldid$ $@ str= IF
2drop ." already up to date" cr
ELSE id>branches co-rest THEN
ELSE
." Local changes, don't update" cr
THEN
dvcs:dispose-dvcs o> ;
: dvcs-revert ( -- ) \ restore to last revision
dvcs:new-dvcs >o
pull-readin dvcs:oldid$ $@ 2dup dvcs:id$ $!
id>branches co-rest
dvcs:dispose-dvcs o> ;
hash#128 buffer: hash-save
: hash-in ( addr u -- hash u )
2dup >file-hash hash-save hash#128 smove
write-enc-hashed 2drop
hash-save hash#128 ;
: hash-add ( addr u -- )
slurp-file hash-in 2drop ;
: hash-out ( addr u -- )
base85>$ 2dup 2>r read-enc-hashed patch-in$ $@ 2r> hash-85 spit-file ;
\ pull and sync a database
$B $E 2Value dvcs-bufs#
Variable dvcs-request#
Variable sync-file-list[]
$10 Constant /sync-files
$20 /sync-files * Constant /sync-reqs
: dvcs-sync-none ( -- )
-1 dvcs-request# +!@ 0<= IF dvcs-request# off THEN ;
event: :>dvcs-sync-done ( o -- ) >o
file-reg# off file-count off
msg-group$ $@ >group ?save-msg 0 dvcs-request# !
msg( ." === metadata sync done ===" forth:cr ) o> ;
: dvcs-sync-done ( -- )
msg( ." dvcs-sync-done" forth:cr )
net2o:close-all
msg( ." dvcs-sync-done closed" forth:cr )
<event o elit, :>dvcs-sync-done wait-task @ event> ;
: +dvcs-sync-done ( -- )
['] dvcs-sync-done is sync-done-xt
['] dvcs-sync-none is sync-none-xt ;
also net2o-base
: dvcs-join, ( -- )
[: msg-join last?, ;] [msg,] ;
previous
: dvcs-greet ( -- )
net2o-code expect-msg
log !time end-with dvcs-join, get-ip end-code ;
: dvcs-connect ( addr u -- )
dvcs-bufs# chat#-connect? IF 2 dvcs-request# ! dvcs-greet THEN ;
: dvcs-connect-key ( addr u -- )
key>group ?load-msgn
2dup search-connect ?dup-IF >o +group rdrop 2drop EXIT THEN
\ check for disconnected here or in pk-peek?
2dup pk-peek? IF dvcs-connect ELSE 2drop THEN ;
: dvcs-connects? ( -- flag )
chat-keys ['] dvcs-connect-key $[]map dvcs-request# @ 0> ;
: wait-dvcs-request ( -- )
BEGIN dvcs-request# @ WHILE stop REPEAT ;
: +needed ( addr u -- )
2dup enchash>filename file-status nip no-file# = IF
dvcs( ." need: " 2dup 85type cr )
sync-file-list[] $ins[] drop
ELSE dvcs( ." don't need: " 2dup 85type cr ) 2drop THEN ;
: #needed ( hash -- )
cell+ $@ key| +needed ;
: dvcs-needed-files ( -- )
id>patch# ['] #needed #map
id>snap# ['] #needed #map ;
: get-needed-files { list -- } +resend
list $[]# 0 ?DO
I /sync-reqs + I' umin I U+DO
net2o-code expect+slurp
$10 blocksize! 0 blockalign!
I /sync-files + I' umin I U+DO
I list $[]@ net2o:copy#
LOOP
\ I /sync-files + I' u>= IF
end-code| net2o:close-all -map-resend
I /sync-files + I' u>= IF
+resend +flow-control
net2o-code expect+slurp close-all ack rewind end-with
[ previous ]
THEN
\ ELSE end-code THEN
/sync-files +LOOP
/sync-reqs +LOOP ;
: dvcs-data-sync ( -- )
sync-file-list[] $[]off branches[] $[]off
msg-group$ $@ >group
dvcs:commits @ .chat>branches-loop
dvcs:commits @ .dvcs-needed-files
sync-file-list[] $[]# 0> connection and
IF sync-file-list[] connection .get-needed-files THEN ;
: dvcs-ref-sync ( -- )
search-last-rev id>branches
dvcs:new-dvcs-refs >o
branches>dvcs
dvcs:refs[] $[]# 0 ?DO
." ref: " I dvcs:refs[] $[]@ 85type cr LOOP
dvcs:refs[] $[]# 0> connection and
IF dvcs:refs[] connection .get-needed-files THEN
dvcs:dispose-dvcs-refs o> ;
: handle-fetch ( -- ) ?.net2o/objects
dvcs:new-dvcs >o pull-readin
msg( ." === syncing metadata ===" forth:cr )
0 >o dvcs-connects? IF +dvcs-sync-done wait-dvcs-request THEN o>
msg( ." === syncing data ===" forth:cr )
dvcs-data-sync
msg( ." === data sync done ===" forth:cr )
dvcs-ref-sync
msg( ." === ref sync done ===" forth:cr )
connection ?dup-IF
.data-rmap IF msg-group$ $@ >group last# silent-leave-chat THEN
THEN
dvcs:dispose-dvcs o> ;
: handle-clone ( -- )
0 chat-keys !@ { w^ clone-keys }
clone-keys [: >dir 2dup chat-keys $+[]!
[: @/ 2swap
'#' $split dup 0= IF 2drop ELSE 2nip THEN
2dup $1FF init-dir drop 2dup set-dir throw
[: type '@' emit .key-id? ;] $tmp dvcs-init
handle-fetch dvcs-up ;] catch
chat-keys $[]free dir> throw
;] $[]map
clone-keys @ chat-keys ! ;
\\\
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-z0-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)
)
End: