Artifact dd173533549df9802435edd34aead635a0823b7b:

• File packages/gryp/lib/gryp.tcl — part of check-in [56ea300bbf] at 2020-05-18 13:50:56 on branch trunk — cdc silenced some compiler warnings

  gryp keep

  first working encrypted remote file storage and retrieval

  (user: pooryorick size: 39050)

#! /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 dict deep}
	{ycl dict} {
		ddict deep
	}
	{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 set $header [bits struct encode value $hash]
			$_ db eval {
				insert into fsbackups (
					rowid ,fsrowid ,fsepoch ,hash
				) 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 set $header [
				bits struct encode values $hash $fsdbhash $keepdbhash]
			$_ db eval {
				insert into grypbackups (epoch ,hash)
					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 set $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 (
				rowid ,fsbackupid ,grypbackupid ,keepbackupid
			) 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 (rowid ,e ,a ,v)
					values (null ,0 ,'typeid' ,@magicb)
				;insert into system (rowid ,e ,a ,v)
					values (null ,0 ,'id' ,@id)
				;insert into system (rowid ,e ,a ,v)
					values (null ,0 ,'version' , '0.0.1')
				;insert into system (rowid ,e ,a ,v)
					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  {
			set res [$_ $name {*}$args]
			ddict pretty res
			puts stderr $res
			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 (rowid ,fsid) 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 (rowid ,e ,a ,v) 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 {. _ type args} {
	optswitch $type {
		sqlite {
		}
	}
	$_ keep repository add $type {*}$args
	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 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 storecuts 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 {
						lassign [$_ keep setbatch $batch] \
							stored bexisting notstored
						if {[llength $notstored]} {
							error [list {could not store all cuts} \
								{not stored} [llength $notstored]]
						}
						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 setbatch $batch] \
			stored bexisting notstored
		if {[llength $notstored]} {
			error [list {could not store all cuts} {not stored} $notstored]
		}
		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 set $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 setbatch {. _ batch} {
	error [list {to do}]
}
.my .method setbatch


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]

	set success 0
	# iterate twice, if necessary, so that  failures to retrieve in the first
	# iteration cause the keeps to mark those as nonexisting so that the cuts
	# are picked up the second time they are stored.
	for {set i 0} {$i < 2} {incr i} {
		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 eq $signature2} {
				set success 1
				break
			}
		} finally {
			close $chan 
			if {[file exists $tmpfile]} {
				file delete $tmpfile
			}
		}
	}

	if {!$success} {
		error [list {could not retrieve saved file}]
	}
	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


proc trystorefile {} {
}
.my .method trystorefile


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}]
}