#! /usr/bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
package require pki
package require sha256
package require sqlite3
package require {ycl bits struct}
package require {ycl dir scan}
package require {ycl string chan}
aliases {
{ycl bits}
{ycl string cdc} {
cut
cuts
signature_sha256
}
{ycl comm ucsd}
{ycl db sqlite util} {
blockscript
dbget_ get
selectalias [yclprefix]::db::sqlite::util::selectalias
}
{ycl dir}
{ycl keep keep}
{ycl list} {
take
}
{ycl proc} {
checkargs
lambda
optswitch
}
{ycl string} {
schan chan
}
{ycl math rand} {
randbytes
}
{ycl string printable}
{ycl struct tree}
}
namespace eval doc {}
proc .id {. _} {
$_ dbget {select v from system where e = 0 and a = 'id'}
}
.my .method .id
proc .init {. _ args} {
$_ .vars keepdir pkikey port fsdb fsdir
while {[llength $args]} {
set args [lassign $args[set args {}] opt val]
switch $opt {
cmd {
set cmd [list $val {*}$args]
break
}
pkikey {
set $opt val
}
workdir {
set $opt $val
}
default {
error [list {unknown option} $opt]
}
}
}
namespace ensemble create -command [
$_ .namespace]::device -parameters {. _} -map {
add device_add
rm device_rm
}
$_ .eval [list $_ .method device]
namespace ensemble create -command [
$_ .namespace]::devicetype -parameters {. _} -map {
add devicetype_add
exists devicetype_exists
}
$_ .eval [list $_ .method devicetype]
namespace ensemble create -command [
$_ .namespace]::repo -parameters {. _} -map {
add repo_add
}
$_ .eval [list $_ .method repo]
namespace ensemble create -command [
$_ .namespace]::scan -parameters {. _} -map {
list scan_list
run scan_run
}
$_ .eval [list $_ .method scan]
namespace ensemble create -command [
$_ .namespace]::remote -parameters {. _} -map {
add remote_add
list remote_list
push remote_push
}
$_ .eval [list $_ .method remote]
$_ workdir $workdir
if {![$_ devicetype exists unknown]} {
$_ devicetype add unknown
}
if {![$_ devicetype exists local]} {
$_ devicetype add local scanner [list ::apply [list name {
package require {ycl dir scanner local}
[yclprefix] dir scanner local .new $name
}]]
}
set port 7480
if {[info exists cmd]} {
tailcall $_ cmdline {*}$cmd
}
return $_
}
.my .method .init
proc addcutslist {. _ signature cutssignature} {
$_ .vars cutslists
#set csnode [$_ tree node pivot $cutslists $signature]
#$_ tree node ls& $csnode {
# upvar _ _
# set val [$_ tree node val $node]
# set val [printable tcl 0 $val]
#}
$_ tree node forge $cutslists $signature $cutssignature
}
.my .method addcutslist
proc archive {. _ epoch} {
$_ .vars cutslists streamnotstorednode
set archived 0
set completedsize 0
set existed 0
set failedsize 0
set storefailure 0
set epochsize [$_ fs size $epoch]
puts [list now archiving]
$_ fs list $epoch [list ::apply [list {
_ rowid epoch pathid info size stream hash
} {
upvar archived archived completedsize completedsize \
cutslists cutslists epochsize epochsize \
failedsize failedsize storefailure storefailure \
streamnotstorednode streamnotstorednode
set errmsg {}
if {$hash ne {}} {
set file [file join {*}[$_ fs path $pathid]]
if {[$_ tree node exists $cutslists $hash]} {
puts [list {already stored} $file]
return -code continue
}
try {
lassign [$_ cutfile $file] signature cuts
} on ok {} {
incr archived
incr completedsize $size
if {$signature eq $hash} {
try {
puts [list storing file $file]
lassign [$_ storeartifact $file $signature $cuts] \
size newbytes cutssignature
} on error {tres topts} {
set errmsg $tres
}
} else {
set errmsg {stored signature doesn't match}
}
} on error {tres topts} {
set errmsg {could node cut file}
}
if {$errmsg ne {}} {
set errmsg $tres
incr failedsize $size
incr storefailure
$_ tree node forge $streamnotstorednode $stream
puts [list {could not store file} file $file error $errmsg]
}
}
puts [list epoch $epoch completed [expr {
entier(double($completedsize) / $epochsize * 100)}]% size $size]
}] $_]
return [list $archived $existed $storefailure]
}
.my .method archive
proc archivefsdb {. _} {
variable scandbheadermagic
$_ .vars fsdir selfbackupdir
set bheadermagic [binary format H* $scandbheadermagic]
set fs [$_ .namespace]::[info cmdcount]_scan
try {
[yclprefix] dir scan .spawn $fs
$fs init workdir $fsdir
set fsid [$fs .id]
if {[string length $fsid] == 0} {
error [list {bad fsid}]
}
$_ fsdb_register $fsid
set fsepoch [$_ dbget {
select v from fs.system where e = 0 and a = 'epoch'
}]
set fsrowid [$_ dbget {
select rowid from filesystems where fsid = @fsid
}]
if {[$_ db exists {
select fsrowid from fsbackups
where fsrowid = $fsrowid and fsepoch = $fsepoch}]
} {
set hash [$_ db onecolumn {
select hash from fsbackups
where fsrowid = $fsrowid and fsepoch = $fsepoch
}]
} else {
#$_ db eval {vacuum fs}
set backupfile [file join $selfbackupdir scansbackup]
$_ db backup fs $backupfile
lassign [$_ cutfile $backupfile] signature cuts
$_ fs insertstream $signature
lassign [$_ storeartifact $backupfile $signature $cuts] \
size newbytes hash
set header $bheadermagic\0[
bits struct encode values $fsid [
bits number encode $fsepoch]]
$_ keep store $header [bits struct encode value $hash]
$_ db eval {
insert into fsbackups values (
null
, $fsrowid
, $fsepoch
, @hash
)
}
file delete $backupfile
}
} finally {
rename $fs {}
}
return $hash
}
.my .method archivefsdb
proc archivegrypdb {. _ fsdbhash keepdbhash} {
variable grypdbheadermagic
$_ .vars selfbackupdir
set bheadermagic [binary format H* $grypdbheadermagic]
set grypid [$_ .id]
set grypepoch [$_ dbget {
select v from system where e = 0 and a = 'epoch'
}]
if {[$_ db exists {select 1 from grypbackups where epoch = $grypepoch}]} {
set hash [$_ dbget {
select hash from grypbackups where epoch = $grypepoch
}]
} else {
set backupfile [file join $selfbackupdir grypbackup]
try {
$_ db backup main $backupfile
lassign [$_ cutfile $backupfile] signature cuts
$_ fs insertstream $signature
lassign [$_ storeartifact $backupfile $signature $cuts] \
size newbytes hash
set header $bheadermagic\0[
bits struct encode values $grypid [
bits number encode $grypepoch]]
$_ keep store $header [
bits struct encode values $hash $fsdbhash $keepdbhash]
$_ db eval {
insert into grypbackups values ($grypepoch ,@hash)
}
} finally {
file delete $backupfile
}
}
return $hash
}
.my .method archivegrypdb
proc archivekeepdb {. _} {
variable keepdbheadermagic
$_ .vars selfbackupdir
set keepid [$_ dbget {select v from keep.system where e = 0 and a = 'id'}]
set keeprowid [$_ dbget {select rowid from keeps where keepid = @keepid}]
set keepepoch [$_ dbget {
select v from keep.system where e = 0 and a = 'epoch'
}]
if {[$_ db exists {
select 1 from keepbackups
where keepepoch = $keepepoch
}]} {
set hash [$_ db onecolumn {
select hash from keepbackups where keepepoch = $keepepoch
}]
} else {
set bheadermagic [binary format H* $keepdbheadermagic]
set keeptmp [$_ .namespace]::[info cmdcount]_keep_tmp
set keepdir [file join $selfbackupdir keepbackup]
file mkdir $keepdir
set backupfile [file join $keepdir system]
try {
[yclprefix] keep keep .new $keeptmp workdir $keepdir
rename $keeptmp {}
$_ db transaction {$_ db eval {
attach $backupfile as keeptmp
; delete from keeptmp.system
; delete from keeptmp.repositories
; delete from keeptmp.repotype
;insert into keeptmp.system
select * from keep.system
;insert into keeptmp.repositories
select * from keep.repositories
;insert into keeptmp.repotype
select * from keep.repotype
}}
$_ db eval {
detach keeptmp
}
lassign [$_ cutfile $backupfile] signature cuts
$_ fs insertstream $signature
lassign [$_ storeartifact $backupfile $signature $cuts] \
size newbytes hash
set header $bheadermagic\0[
bits struct encode values $keepid [
bits number encode $keepepoch]]
$_ keep store $header [bits struct encode value $hash]
$_ db eval {insert or ignore into keepbackups
values (null ,$keeprowid ,$keepepoch ,@hash)}
} finally {
foreach fname [list \
$backupfile [file join $keepdir system-shm] [
file join $keepdir system-wal] $keepdir
] {
if {[file exists $fname]} {
file delete $fname
}
}
}
}
return $hash
}
.my .method archivekeepdb
proc archiveself {. _} {
$_ .vars selfbackupdir
$_ db transaction {
if {[$_ db exists {
select * from system where e = 0 and a = 'inselfbackup'
}]} {
return
}
$_ db eval {
insert into system values (null ,0 ,'inselfbackup' ,1)
}
}
$_ backupdir_rm
file mkdir $selfbackupdir
try {
puts [list do fsbackup]
set fsdbhash [$_ archivefsdb]
set fsbackuprowid [$_ dbget {
select rowid from fsbackups where hash = @fsdbhash
}]
puts [list do keepbackup]
set keepdbhash [$_ archivekeepdb]
set keepbackuprowid [$_ dbget {
select rowid from keepbackups where hash = @keepdbhash
}]
puts [list do grypbackup]
set hash [$_ archivegrypdb $fsdbhash $keepdbhash]
set grypbackuprowid [$_ dbget {
select epoch from grypbackups where hash = @hash
}]
$_ db eval {
insert or ignore into backups values (
null ,$fsbackuprowid ,$grypbackuprowid ,$keepbackuprowid)
}
} finally {
$_ db eval {
delete from system where e = 0 and a = 'inselfbackup'
}
$_ backupdir_rm
}
puts [list self backup complete]
return
}
.my .method archiveself
proc backupdir_rm {. _} {
$_ .vars selfbackupdir
# carefully delete things in the backup directory
foreach fname {
grypbackup
grypbackup-journal
keepbackup
keepbackup-journal
scansbackup
scansbackup-journal
} {
set fname [file join $selfbackupdir $fname]
if {[file exists $fname]} {
file delete $fname
}
}
file delete $selfbackupdir
}
.my .method backupdir_rm
proc cutfile {. _ fname} {
dir noencoding {
set chan [open $fname]
}
try {
chan configure $chan -translation binary
cut $chan
read $chan
set cuts [cuts $chan]
set signature [signature_sha256 $chan]
} finally {
close $chan
}
list $signature $cuts
}
.my .method cutfile
proc dbarchive {. _ filename} {
}
.my .method dbarchive
proc dbget {. _ query} {
tailcall dbget_ [list $_ db] $query
}
.my .method dbget
proc dbsetup {. _} {
variable magicb
$_ .vars dbcreated workdir
set dbname [$_ .namespace]::db
sqlite3 $dbname [file join $workdir system]
$_ .eval [list $_ .routine db]
set dbcreated 0
$_ db transaction {
if {[$_ db exists {select * from sqlite_master}]} {
try {
set dbmagic [$_ db onecolumn {
select v from system where e = 0 and a = 'typeid'
}]
} on error {tres topts} {
puts stderr [list gryp {error querying database} $tres]
}
if {![info exists dbmagic] || $dbmagic ne $magicb} {
error [list {not a valid gryp workdir}]
}
}
$_ db eval {
create table if not exists backups (
rowid integer primary key
, fsbackupid numeric
, grypbackupid numeric
, keepbackupid numeric
)
; create unique index if not exists c_unique on backups (
fsbackupid ,grypbackupid ,keepbackupid
)
; create table if not exists filesystems (
rowid integer primary key
,fsid blob unique
)
; create trigger if not exists trigger_filesystems_insert
insert on filesystems
begin
update system set v = v + 1 where e = 0 and a = 'epoch'
; end
; create table if not exists fsbackups (
rowid integer primary key
, fsrowid numeric
, fsepoch numeric
, hash blob
)
; create unique index if not exists c_unique on fsbackups (
fsrowid ,fsepoch
)
; create table if not exists grypbackups (
epoch integer primary key
,hash blob
)
; create table if not exists keepbackups (
rowid integer primary key
, keeprowid numeric
, keepepoch numeric
, hash blob
)
; create unique index if not exists c_unique on keepbackups (
keeprowid ,keepepoch
)
; create table if not exists keeps (
rowid integer primary key
,keepid blob unique
)
; create trigger if not exists trigger_keeps_insert
insert on keeps
begin
update system set v = v + 1 where e = 0 and a = 'epoch'
; end
; create table if not exists system (
rowid integer primary key
,e
,a
,v
)
; create table if not exists remotes (
rowid integer primary key
, address
, port
, constraint c_unique unique (
address ,port
)
)
; create trigger if not exists trigger_remotes_insert
insert on remotes
begin
update system set v = v + 1 where e = 0 and a = 'epoch'
; end
}
if {![$_ db exists {select 1 from system where e = 0 and a = 'typeid'}]} {
set id [$_ randbytes]
$_ db eval {
;insert into system values (null ,0 ,'typeid' ,@magicb)
;insert into system values (null ,0 ,'id' ,@id)
;insert into system values (null ,0 ,'version' , '0.0.1')
;insert into system values (null ,0 ,'epoch' , 0)
}
set dbcreated 1
}
#-- ; pragma journal_mode=WAL
#-- ; pragma main.synchronous=OFF
}
return
}
.my .method dbsetup
proc cmd_retrieve {. _ hexsig args} {
set sig [binary format H* $hexsig]
$_ retrieve $sig {*}$args
}
.my .method cmd_retrieve
proc cmdline {. _ name args} {
switch $name {
archive - archiveself - keep - listen - remote
- repo - restore - scan - storefile - track {
$_ $name {*}$args
exit 0
}
retrieve {
$_ cmd_retrieve {*}$args
exit 0
}
ui {
$_ $name {*}$args
}
default {
error [list {unknown command} $name]
}
}
}
.my .method cmdline
proc device_add {. _ name type args} {
$_ .vars devicesnode devicetypesnode
dict size $args
if {![$_ tree node exists $devicetypesnode $type]} {
error [list {unknown device type} $type]
}
lassign [$_ tree node forge $devicesnode $name] devicenode created
if {!$created} {
error [list {device already exists}]
}
$_ tree node forge $devicenode type $type
while {[llength $args]} {
take args opt val
$_ tree node forge $devicenode $opt $val
}
return $devicenode
}
.my .method device_add
proc device_rm {. _ name} {
$_ .vars devicesnode
set devicenode [$_ tree node pivot $devicesnode $name]
if {[$_ tree node exists $devicenode epochs]} {
error [list {can not remove device} {scans exist}]
} else {
$_ tree node rm $devicesnode $devicenode
}
}
.my .method device_rm
proc devices {. _ args} {
$_ .vars devicesnode
uplevel 1 [list $_ tree node ls& $devicesnode {*}$args]
}
.my .method devices
proc device_next {. _ device args} {
uplevel 1 [list $_ tree node next& $device {*}$args]
}
.my .method device_next
proc device_previous {. _ device args} {
uplevel 1 [list $_ tree node previous& $device {*}$args]
}
.my .method device_previous
proc devicetype_add {. _ name args} {
$_ .vars devicetypesnode
lassign [$_ tree node forge $devicetypesnode $name] devicetypenode created
if {!$created} {
error [list {device type already exits} $name]
}
while {[llength $args]} {
take args opt val
$_ tree node forge $devicetypenode $opt $val
}
return
}
.my .method devicetype_add
proc devicetype_exists {. _ name} {
$_ .vars devicetypesnode
$_ tree node exists $devicetypesnode $name
}
.my .method devicetype_exists
proc distribute {. _} {
$_ keep distribute
}
.my .method distribute
proc fsbackups {. _ args} {
if {[llength $args]} {
lassign [blockscript {rowid fsrowid fsepoch hash} {*}$args] spec script
set query "select $spec from fsbackups"
$_ db eval $query $script
} else {
$_ db eval $query
}
}
.my .method fsbackups
proc fsdb_register {. _ id} {
$_ db transaction {
$_ db eval {
insert or ignore into filesystems values (null ,@id)
}
}
}
.my .method fsdb_register
proc fssetup {. _} {
$_ .vars devicesnode fsdb fsdir
set name [$_ .namespace]::fs
[yclprefix] dir scan new $name
$name init workdir $fsdir
set fsdbid [$name .id]
$_ .eval [list $_ .routine fs]
#$name init workdir $fsdir path $path
$_ db eval {
attach database $fsdb as fs
}
$_ fsdb_register $fsdbid
#$_ fs epochs [lambda epoch {
# upvar _ _
# puts [list pidddle $epoch]
#}]
#exit 99
return
}
.my .method fssetup
proc hash {. _ datavar} {
upvar $datavar data
set shatok [::sha2::SHA256Init-critcl]
::sha2::SHA256Update-critcl $shatok $data
set hash [::sha2::SHA256Final-critcl $shatok]
set data $hash
}
.my .method hash
proc keepsetup {. _} {
$_ .vars dbcreated keepdir workdir
file mkdir $keepdir
set keep [[yclprefix] keep keep .new [$_ .namespace]::keep]
if {$dbcreated} {
lappend keepargs create 1
} else {
set keepargs {}
}
$keep .init workdir $keepdir {*}$keepargs
$_ .eval [list $_ .routine keep]
set keepsystem [file join $keepdir system]
$_ db eval {
attach $keepsystem as keep
}
set keepid [$_ dbget {select v from keep.system where e = 0 and a = 'id'}]
$_ db eval {
; insert or ignore into keeps values ( null , @keepid )
}
set keeprepo [file join $workdir repository]
if {$dbcreated} {
$_ keep repository add sqlite path $keeprepo
}
return
}
.my .method keepsetup
proc listen {. _ args} {
$_ .vars port
#package require tls
dict size $args
foreach {opt val} $args {
switch $opt {
port {
set port $val
}
default {
error [list {unknown option} $opt]
}
}
}
#set chan [tls::socket -server [list $_ serve] $port]
set chan [socket -server [list $_ serve] $port]
vwait forever
}
.my .method listen
proc pkisetup {. _} {
$_ .vars pkikey
if {![$_ db exists {select * from system where e = 0 and a = 'pkikey'}]} {
if {![info exists pkikey]} {
puts stderr [list generating keypair]
set pkikey [pki::rsa::generate 2048]
}
$_ db eval {
insert into system values (null ,0 ,'pkikey' ,@pkikey)
}
unset pkikey
}
return
}
.my .method pkisetup
proc prune {. _ dirname} {
variable magic
if {[file exists [file join $dirname .$magic]]} {
return 1
}
return 0
}
.my .method prune
proc randbytes_ {. _} {
randbytes 32
}
.my .method randbytes randbytes_
proc remote_add {. _ args} {
dict size $args
foreach {opt val} $args {
switch $opt {
address - port {
set $opt $val
}
default {
error [list {unknown option} $opt]
}
}
}
set address
$_ db eval {
insert or ignore into remotes values (null ,@address ,@port)
}
}
.my .method remote_add
proc remote_list {. _ args} {
$_ db eval {select address ,port from remotes}
}
.my .method remote_list
proc remote_push {. _ args} {
#package require tls
$_ .vars port
$_ db eval {select address ,port as rport from remotes} {
if {$rport eq {}} {
set rport $port
}
}
#set chan [tls::socket $address $rport]
set chan [socket $address $rport]
error [list to do]
flush $chan
::close $chan
return
}
.my .method remote_push
proc repo_add {. _ args} {
set paths {}
while {[llength $args]} {
set args [lassign $args[set args {}] opt val]
switch $opt {
path {
set path [file dirname [file normalize [file join $val ...]]]
lappend paths $path
}
default {
error [list {unknown option} $opt]
}
}
}
foreach path $paths {
$_ keep repository add sqlite path $path
}
return
}
proc repos {. _} {
set repos [$_ keep repositories]
while 1 {
set repo [$repos]
dict with repo {}
binary scan $instance H* instancehex
dict unset repo instance
dict unset repo rowid
puts $rowid
puts $instancehex
foreach {key val} $repo {
puts [list $key $val]
}
puts {}
}
}
.my .method repos
proc restore {. _ epoch to} {
set restoredfiles 0
set restoreddirs 0
set totalbytes 0
if {[file exists $to]} {
if {![file isdirectory $to]} {
error [list {not a directory}]
}
if {[llength [dir listing -types +hidden -directory $to *]]} {
error [list {not empty}]
}
} else {
file mkdir $to
}
set currentpath {}
$_ fs list $epoch [list ::apply [list {
rowid epoch path info size stream hash
} {
upvar _ _ restoredfiles restoredfiles restoreddirs restoreddirs \
to to totalbytes totalbytes
$_ fs finfo $info {
tailcall foreach link [list $link] linfo [list $linfo] type [
list $type] mtime [list $mtime] {}
}
set file [file join $to {*}[$_ fs path $path]]
set success 0
puts [list restoring $file]
switch $type {
d {
file mkdir $file
set success 1
}
l {
dir link $file to $link type symbolic
}
default {
set newdir [file dirname $file]
if {![file exists $newdir]} {
dir noencoding {
file mkdir $newdir
}
incr restoreddirs
}
$_ retrieve $hash file $file
try {
} on error {tres topts} {
puts [list {could not restore} file $file error $tres]
} on ok {} {
set success 1
incr restoredfiles
incr totalbytes $size
}
}
}
if {$success} {
if {$mtime ne {}} {
file mtime $file $mtime
}
}
} [namespace current]]]
set res [dict create directories $restoreddirs files $restoredfiles \
bytes $totalbytes]
puts [list {restore complete} {*}$res]
return $res
}
.my .method restore
proc restorefsdb {. _ dirname} {
$_ .vars workdir
variable cutsmagic
variable cutsmagicb
set scansdir [dir autocreate named [file join $dirname scans]]
puts [list scansdir is $scansdir]
$_ fsbackups hash fshash {
upvar hash hash
set hash $fshash
}
set cutsmagicsize [string length $cutsmagic]
set cutsmagicbsize [string length $cutsmagicb]
set cutsdata [$_ keep retrieve $hash]
set dlen [string length $cutsdata]
set cutsmagicb2 [string range $cutsdata 0 $cutsmagicbsize-1]
if {$cutsmagicb2 eq $cutsmagicb} {
incr cursor $cutsmagicbsize
} else {
set cutsmagic2 [string range $cutsdata 0 $cutsmagicsize-1]
if {$cutsmagic2 eq $cutsmagic} {
incr cursor $cutsmagicsize
} else {
error [list {wrong magic}]
}
}
set null [string index $cutsdata $cursor]
if {$null ne "\0"} {
error [list {missing null after magic}]
}
incr cursor
lassign [bits struct decode extract $cutsdata $cursor] \
ll l signature
if {$l != 32} {
error [list {wrong signature length}]
}
incr cursor $ll
incr cursor $l
lassign [bits struct decode extract $cutsdata $cursor] \
ll l sigcount
set sigcount [bits number decode $sigcount]
incr cursor $ll
incr cursor $l
set char [string index $cutsdata $cursor]
if {$char ni [list { } \0]} {
error [list {cuts count not followed by space or null}]
}
incr cursor
set indices {}
set sigsize 32
set end [expr {$sigsize - 1}]
set found 0
set gaps 0
set unused 0
set unusedratio 0
set chan [open [file join $scansdir system] w+b]
$_ keep db transaction {
while {$cursor < $dlen} {
set progress [expr {entier($cursor / double($dlen) * 100)}]%
set sig [string range $cutsdata $cursor $cursor+$end]
try {$_ keep retrieve $sig} on ok part {
set lastfound $cursor
incr found
set status found_
dict set indices $cursor {}
puts -nonewline $chan $part
set fsize [tell $chan]
incr cursor $sigsize
## an early version used the space character as the delimiter
#if {[string index $cutsdata $cursor] ni {{ } \0}} {
# error {corrupted cuts list}
#}
#incr cursor
} on error {eres eopts} {
# keep looking
set status unused
set unusedratio [expr {entier($unused / double($dlen) * 100)}]%
if {$cursor - $lastfound - $sigsize >= $sigsize} {
incr gaps
}
incr unused
incr cursor
}
puts [list status $status cursor $cursor \
progress $progress {total found} $found \
unused $unused \
{total unused} $unusedratio \
gaps $gaps
]
}
}
flush $chan
seek $chan 0
puts [list {unused bytes} $unused]
while 1 {
set chunk [read $chan 65536]
if {$chunk eq {} && [eof $chan]} break
set shatok [::sha2::SHA256Init-critcl]
::sha2::SHA256Update-critcl $shatok $chunk
}
close $chan
set hash [::sha2::SHA256Final-critcl $shatok]
set hashlen [string length $hash]
set lastoffset [expr {$hashlen - 1}]
set found -1
# hash should be somewhere near the beginning
for {set i 0} {$i < 4096} {incr i} {
set sig [string range $cutsdata $i [expr {$i + $lastoffset}]]
if {$sig eq $hash} {
set found $i
break
}
}
if {$found < 1} {
error [list {hash of database does not match}]
} else {
puts stderr [list {found hash of database in cuts data at byte} $found]
}
return
}
.my .method restorefsdb
proc retrieve {. _ sig args} {
$_ .vars cutslists
variable cutsmagicb
variable cutscutsmagicb
while {[llength $args]} {
take args opt val
switch $opt {
chan {
set chan $val
}
file {
set file $val
}
}
}
set cutssignature [$_ tree node last $cutslists $sig]
binary scan $cutssignature H* chsig
puts [list must retrieve cuts signature $chsig]
set data [$_ keep retrieve $cutssignature]
set datasig $data
$_ hash datasig
if {$datasig ne $cutssignature} {
error [list {cuts signature doesn't match}]
}
set magiclist [list $cutsmagicb $cutscutsmagicb]
set filesize 0
while 1 {
set datalen [string length $data]
set cursor [string length $cutscutsmagicb]
set first [string range $data 0 $cursor-1]
set iscuts 0
lassign [bits struct decode extract $data $cursor] l ll signature
set cursor [expr {$cursor + $l + $ll}]
lassign [bits struct decode extract $data $cursor] l ll cutcount
set cutcount [bits number decode $cutcount]
set cursor [expr {$cursor + $l + $ll}]
set shatok [::sha2::SHA256Init-critcl]
if {$first eq $cutscutsmagicb} {
set newdata {}
set dopart {append newdata $part}
} elseif {$first eq $cutsmagicb} {
if {$sig ne $signature} {
error [list {cuts file signature does\
not match requested signature}]
}
set iscuts 1
if {[info exists file]} {
set mychan 1
dir noencoding {
set chan [open $file {
CREAT EXCL WRONLY BINARY NONBLOCK}]
}
} else {
set mychan 0
chan configure $chan -blocking 0 -translation binary
}
set dopart {
chan event $chan writable [list [info coroutine]]
yield
chan event $chan writable {}
incr filesize [string length $part]
puts -nonewline $chan $part
}
} else {
error [list {bad cuts data}]
}
while {$cursor < $datalen} {
lassign [bits struct decode extract $data $cursor] l ll signature2
set part [$_ keep retrieve $signature2]
::sha2::SHA256Update-critcl $shatok $part
try $dopart
set cursor [expr {$cursor + $l + $ll}]
}
set newsignature [::sha2::SHA256Final-critcl $shatok]
binary scan $newsignature H* s4
puts [list newsignature $s4]
if {$iscuts} {
if {$mychan} {
close $chan
} else {
flush $chan
}
break
} else {
set data $newdata
}
}
if {$signature ne $newsignature} {
error [list {signatures don't match}]
}
return [list size $filesize]
}
.my .method retrieve
proc scan_list {. _} {
}
proc scan_run {. _ task args} {
$_ .vars tracknode
set paths {}
set scanargs {}
while {[llength $args]} {
set args [lassign $args[set args {}] opt val]
switch $opt {
default {
lappend scanargs $opt $val
}
}
}
set archived 0
set existed 0
set failed 0
set openfailed 0
set readfailed 0
set tasknode [$_ tree node pivot $tracknode $task]
set epoch [$_ scan_do $tasknode {*}$scanargs]
lassign [$_ archive $epoch] archived1 existed1 failed1
incr archived $archived1
incr existed $existed1
incr failed $failed1
puts [list {scan complete} {bytes archived} $archived \
{bytes existing} $existed \
{bytes failed} $failed \
]
return $epoch
}
.my .method scan_run
proc scan_do {. _ task args} {
$_ .vars devicesnode devicetypesnode fsdir
set devicename [$_ tree node last $task device]
set devicenode [$_ tree node pivot $devicesnode $devicename]
set type [$_ tree node last $devicenode type]
set path [$_ tree node last $task path]
set typenode [$_ tree node pivot $devicetypesnode $type]
set scanner [$_ tree node last $typenode scanner]
set scanner [[{*}$scanner scanner_[info cmdcount]] .init path $path]
set epoch [$_ fs scan scanner [list $scanner next] prune [
list $_ prune] {*}$args]
$_ tree node forge $task epochs $epoch
$_ tree node forge $devicenode epochs $epoch
return $epoch
}
.my .method scan_do
proc serve {. _ chan address port args} {
error [list to do]
}
.my .method serve
proc storeartifact {. _ fname signature cuts} {
variable cutsmagicb
set chan [open $fname rb]
try {
set res [$_ storecuts $cutsmagicb $signature $cuts $chan]
} finally {
close $chan
}
return $res
}
.my .method storeartifact
proc storecuts {. _ magic signature cuts chan} {
set cutcount [dict size $cuts]
set remaining $cutcount
set cutsdata {}
set cutsdatasize 0
set start 0
set i 0
set batch {}
set indices {}
foreach {last hash} $cuts[set cuts {}] {
lappend indices $last
lappend hashes $hash
}
set existing [$_ keep existing $hashes]
set existingcount [llength [lsearch -exact -all $existing 1]]
puts [list cuts $cutcount existing $existingcount]
set iexisting 0
set newbytes 0
set storedcuts 0
foreach last $indices hash $hashes e1 $existing {
if {$e1} {
} else {
seek $chan $start start
set chunk [read $chan [expr {$last - $start}]]
if {$chunk eq {}} {
error [list {empty chunk}]
}
set chunkhash $chunk
$_ hash chunkhash
if {$chunkhash ne $hash} {
error [list {hashes don't match} start $start]
}
incr newbytes [string length $chunk]
lappend batch $hash $chunk
incr batchsize
if {$batchsize >= 1024} {
puts [list {storing cuts} $batchsize remaining $remaining]
set attempts 0
while 1 {
try {
puts [list send bleep $batchsize to keep]
lassign [$_ keep storebatch $batch] stored bexisting
set storedcuts [expr {$storedcuts + $stored}]
set iexisting [expr {$iexisting + $bexisting}]
} on error {tres topts} {
puts stderr [printable [dict get $topts -errorinfo]]
} on ok {} {
break
}
if {[incr failures] >= 100} {
incr storefailure $batchsize
error [list {failed to store} attempts $failures]
}
# rest before trying again
after 1000 [list [info coroutine]]
yield
}
set remaining [expr {$remaining - $batchsize}]
set batchsize 0
set batch {}
}
}
set encoded [bits struct encode value $hash]
append cutsdata $encoded
incr cutsdatasize [string length $encoded]
set start $last
incr i
}
if {[llength $batch]} {
lassign [$_ keep storebatch $batch] stored bexisting
set storedcuts [expr {$storedcuts + $stored}]
set iexisting [expr {$iexisting + $bexisting}]
set remaining [expr {$remaining - $batchsize}]
set batchsize 0
set batch {}
}
set header $magic[bits struct encode values $signature [
bits number encode $cutcount
]]$cutsdata
if 0 {
there was a bug here where "header" was passed instead of $header
so there are probably many things incorrectly stored in the keep under
the signagure for "header", i.e.:
1e0584a25d9f43bf5cbd0aec01eb1af2220ed085b4e7f1837b0d89958cae353a
to do {
scan the keep repositories and make sure values match keys
}
}
set hash $header
$_ hash hash
binary scan $hash H* hexsig
puts [list cutsdatasize $cutsdatasize hashheader $hexsig]
if {$cutsdatasize > 8192} {
return [$_ storecutscuts $header]
} else {
$_ keep store $hash $header
return [list $last $newbytes $hash $storedcuts $iexisting]
}
}
.my .method storecuts
proc storecutscuts {. _ data} {
variable cutscutsmagicb
set chan [schan open access rb data $data]
chan configure $chan -translation binary
try {
cut $chan
read $chan
set cuts [cuts $chan]
set signature [signature_sha256 $chan]
} finally {
close $chan
}
set chan [schan open access rb data $data]
try {
$_ storecuts $cutscutsmagicb $signature $cuts $chan
} finally {
close $chan
}
}
.my .method storecutscuts
proc storebatch {. _ batch} {
error [list {to do}]
}
.my .method storebatch
proc storefile {. _ file args} {
set del 0
while {[llength $args]} {
take args arg
optswitch $arg {
del {
take args del
}
}
}
puts [list cutting]
lassign [$_ cutfile $file] signature cuts
puts [list storing]
lassign [$_ storeartifact $file $signature $cuts] \
size newbytes cutssignature storedcuts iexisting
binary scan $cutssignature H* chsig
puts [list the cuts signature is $chsig]
$_ addcutslist $signature $cutssignature
binary scan $signature H* hsig
set size [lindex $cuts end-1]
set chan [file tempfile tmpfile]
try {
chan configure $chan -translation binary
$_ retrieve $signature chan $chan
flush $chan
seek $chan 0
lassign [$_ cutfile $file] signature2 cuts
if {$signature ne $signature2} {
error [list {could not retrieve saved file}]
}
} finally {
close $chan
if {[file exists $tmpfile]} {
file delete $tmpfile
}
}
if {$del} {
file delete $file
}
puts [list {stored file} size $size new $newbytes cuts [dict size $cuts] \
storedcuts $storedcuts signature $hsig name $file]
puts {}
return [list size $size new $newbytes signature $signature \
{running duplicates} $iexisting]
}
.my .method storefile
variable doc::track {
args {
. {}
_ {}
name {
positional true
}
device { }
path {}
}
}
proc track {. _ name args} {
$_ .vars devicesnode tracknode
checkargs $doc::track {*}$args
if {[$_ tree node exists $tracknode $name]} {
error [list {already exists} $name]
}
lassign [$_ tree node forge $tracknode $name] track created
lassign [$_ tree node forge $track device] devicelink
set devicenode [$_ tree node pivot $devicesnode $device]
$_ tree node link $devicelink $devicenode
$_ tree node forge $track path $path
return
}
.my .method track
proc tracked {. _ args} {
$_ .vars tracknode
uplevel 1 [list $_ tree node ls& $tracknode {*}$args]
}
.my .method tracked
proc tracknode {. _ args} {
$_ .vars tracknode
return $tracknode
}
.my .method tracknode
proc ui {. _ args} {
package require {ycl gryp session}
package require {ycl gryp ui}
package require Tk
set sessionname [$_ .namespace]::session
set z [[yclprefix] gryp session .new $sessionname]
$z .init gryp $_
$_ .eval [list $_ .routine session $sessionname]
set uiname [$_ .namespace]::ui_[info cmdcount]
while 1 {
set frame .frame_[incr i]
if {[namespace which $frame] eq {}} break
}
set frame [frame $frame]
pack $frame -in . -expand 1 -fill both
[[yclprefix] gryp ui .new $uiname] .init top $frame {*}$args gryp $_
return $uiname
}
.my .method ui
proc untrack {. _ tracked} {
$_ .vars tracknode
$_ tree node rm $tracked
return
}
.my .method untrack
proc versionupdate {. _} {
if 0 {
earlier in 0.0.1
cutslists stored the cust signature under the stream id that came
from the scans database
now it stores the cuts list under the stream hash
extract each cuts signature stored under stream id's
retrieve the hash
and store the custsignature under the hash instead
then bump the version
}
}
.my .method versionupdate
proc workdir {. _ args} {
variable magic
$_ .vars cutslists devicesnode devicetypesnode keepdir fsdb fsdir \
selfbackupdir streamnotstorednode tracknode workdir
if {[llength $args] == 1} {
if {[info exists workdir]} {
error [list {work directory already set}]
}
set workdir [file dirname [file normalize [
file join [lindex $args 0] ...]]]
# to do
# make this atomic
file mkdir $workdir
set magicfile [file join $workdir .$magic]
if {![file exists $magicfile]} {
set glob [glob -nocomplain -directory $workdir *]
if {[llength $glob]} {
error [list {not a gryp project directory}]
}
set magicchan [open $magicfile {EXCL CREAT WRONLY}]
set glob [glob -nocomplain -directory $workdir *]
if {[llength $glob]} {
error [list {gryp project directory already contains files}]
}
close $magicchan
}
set keepdir [file join $workdir keep]
set fsdir [file join $workdir scans]
set selfbackupdir [file join $workdir selfbackup]
set fsdb [file join $fsdir system]
$_ dbsetup
$_ versionupdate
[tree .new [$_ .namespace]::tree] .init dbconn [list $_ db] dbitemprefix tree
$_ .eval [list $_ .routine tree]
lassign [$_ tree node forge {} cutslists] cutslists
lassign [$_ tree node forge {} devices] devicesnode
#$_ tree node rm $devicesnode
#puts [list schlonk [$_ tree node val 91]]
#$_ tree node rm 70
lassign [$_ tree node forge {} stream notstored] streamnotstorednode
lassign [$_ tree node forge {} devicetypes] devicetypesnode
lassign [$_ tree node forge {} track] tracknode
$_ pkisetup
$_ keepsetup
$_ fssetup
#set devicenode [$_ tree node pivot? $devicesnode {no device}]
#if {$devicenode eq {}} {
# $_ device add {no device} unknown
#}
} elseif {[llength $args]} {
error [list {wrong # args}]
}
if {[info exists workdir]} {
return $workdir
} else {
return {}
}
}
.my .method workdir
variable magic e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855
variable magicb [binary format H* $magic]
# The only place the binary form of these values should ever be written to disk
# is at the beginning of a list of cuts their respective database backups
variable scandbheadermagic 669d31589b710168388baf7924c66f9af928c63df0ecbe40270d2a2316c1d7d1
variable keepdbheadermagic 5a647ebecdaa96c3861c598de5a2d2df6c3b44cb5605872b2da837df69d1ff79
variable grypdbheadermagic 27fad3c8b860db01d42967339936d4c6228549cf4576e998fdb1d472b260615e
variable grypsetheadermagic 73bada9f70ea330b31c5e6d482e966b7cfbb3bafeacf9822c80b20d787280e5c
variable cutsmagic cf8ffd1e022974d166769272bb9eff3df68e58b752065cd1b152386324a19dfb
variable cutsmagicb [binary format H* $cutsmagic]
variable cutscutsmagic 35e5024a18bc51d64da2a29e9a61abb6aff85ad703dcdb2aa35c10243f295a1e
variable cutscutsmagicb [binary format H* $cutscutsmagic]
if {[string length $cutsmagicb] ne [string length $cutscutsmagicb]} {
error [list {the lengths of custmagic and cutscutsmagic differ}]
}